Warning, /pkg/exch2/exch2_ad_put_rx2.template is written in an unsupported language. File is not indexed.
view on githubraw file Latest commit b9dadda2 on 2020-07-28 16:49:33 UTC
ed81d0a43c Jean*0001 #include "CPP_EEOPTIONS.h"
0002 #include "W2_OPTIONS.h"
0003
0004 CBOP 0
0005 C !ROUTINE: EXCH2_AD_PUT_RX2
0006
0007 C !INTERFACE:
0008 SUBROUTINE EXCH2_AD_PUT_RX2 (
0009 I tIlo1, tIhi1, tIlo2, tIhi2, tiStride,
0010 I tJlo1, tJhi1, tJlo2, tJhi2, tjStride,
0011 I tKlo, tKhi, tkStride,
0012 I oIs1, oJs1, oIs2, oJs2,
0013 I thisTile, nN,
0014 I e2BufrRecSize,
0015 O e2Bufr1_RX, e2Bufr2_RX,
0016 I array1,
0017 I array2,
0018 I i1Lo, i1Hi, j1Lo, j1Hi, k1Lo, k1Hi,
0019 I i2Lo, i2Hi, j2Lo, j2Hi, k2Lo, k2Hi,
0020 O e2_msgHandle,
0021 I commSetting, withSigns, myThid )
0022
0023 C !DESCRIPTION:
0024 C---------------
d6ea3164dc Jean*0025 C AD: IMPORTANT: all comments (except AD:) are taken from the Forward S/R
ed81d0a43c Jean*0026 C AD: and need to be interpreted in the reverse sense: put <-> get,
0027 C AD: send <-> recv, source <-> target ...
0028 C---------------
0029 C Two components vector field Exchange:
0030 C Put into buffer exchanged data from this source tile.
0031 C Those data are intended to fill-in the
0032 C target-neighbour-edge overlap region.
0033
0034 C !USES:
0035 IMPLICIT NONE
0036
0037 #include "SIZE.h"
0038 #include "EEPARAMS.h"
0039 #include "W2_EXCH2_SIZE.h"
0040 #include "W2_EXCH2_TOPOLOGY.h"
7c69cee546 Jean*0041 #ifdef W2_E2_DEBUG_ON
0042 # include "W2_EXCH2_PARAMS.h"
0043 #endif
ed81d0a43c Jean*0044
0045 C !INPUT/OUTPUT PARAMETERS:
0046 C === Routine arguments ===
0047 C tIlo1, tIhi1 :: index range in I that will be filled in target "array1"
0048 C tIlo2, tIhi2 :: index range in I that will be filled in target "array2"
0049 C tIstride :: index step in I that will be filled in target arrays
0050 C tJlo1, tJhi1 :: index range in J that will be filled in target "array1"
0051 C tJlo2, tJhi2 :: index range in J that will be filled in target "array2"
0052 C tJstride :: index step in J that will be filled in target arrays
0053 C tKlo, tKhi :: index range in K that will be filled in target arrays
0054 C tKstride :: index step in K that will be filled in target arrays
0055 C oIs1, oJs1 :: I,J index offset in target to source-1 connection
0056 C oIs2, oJs2 :: I,J index offset in target to source-2 connection
0057 C thisTile :: sending tile Id. number
0058 C nN :: Neighbour entry that we are processing
0059 C e2BufrRecSize :: Number of elements in each entry of e2Bufr[1,2]_RX
0060 C e2Bufr1_RX :: Data transport buffer array. This array is used in one of
0061 C e2Bufr2_RX :: two ways. For PUT communication the entry in the buffer
0062 C :: associated with the source for this receive (determined
0063 C :: from the opposing_send index) is read.
0064 C :: For MSG communication the entry in the buffer associated
0065 C :: with this neighbor of this tile is used as a receive
0066 C :: location for loading a linear stream of bytes.
0067 C array1 :: 1rst Component target array that this receive writes to.
0068 C array2 :: 2nd Component target array that this receive writes to.
0069 C i1Lo, i1Hi :: I coordinate bounds of target array1
0070 C j1Lo, j1Hi :: J coordinate bounds of target array1
0071 C k1Lo, k1Hi :: K coordinate bounds of target array1
0072 C i2Lo, i2Hi :: I coordinate bounds of target array2
0073 C j2Lo, j2Hi :: J coordinate bounds of target array2
0074 C k2Lo, k2Hi :: K coordinate bounds of target array2
0075 C e2_msgHandles :: Synchronization and coordination data structure used to
0076 C :: coordinate access to e2Bufr1_RX or to regulate message
0077 C :: buffering. In PUT communication sender will increment
0078 C :: handle entry once data is ready in buffer. Receiver will
0079 C :: decrement handle once data is consumed from buffer.
d6ea3164dc Jean*0080 C :: For MPI MSG communication MPI_Wait uses handle to check
ed81d0a43c Jean*0081 C :: Isend has cleared. This is done in routine after receives.
0082 C commSetting :: Mode of communication used to exchange with this neighbor
0083 C withSigns :: Flag controlling whether vector field is signed.
0084 C myThid :: my Thread Id. number
0085
0086 INTEGER tIlo1, tIhi1, tIlo2, tIhi2, tiStride
0087 INTEGER tJlo1, tJhi1, tJlo2, tJhi2, tjStride
0088 INTEGER tKlo, tKhi, tkStride
0089 INTEGER oIs1, oJs1, oIs2, oJs2
0090 INTEGER thisTile, nN
0091 INTEGER e2BufrRecSize
0092 _RX e2Bufr1_RX( e2BufrRecSize )
0093 _RX e2Bufr2_RX( e2BufrRecSize )
0094 INTEGER i1Lo, i1Hi, j1Lo, j1Hi, k1Lo, k1Hi
0095 INTEGER i2Lo, i2Hi, j2Lo, j2Hi, k2Lo, k2Hi
0096 _RX array1(i1Lo:i1Hi,j1Lo:j1Hi,k1Lo:k1Hi)
0097 _RX array2(i2Lo:i2Hi,j2Lo:j2Hi,k2Lo:k2Hi)
0098 INTEGER e2_msgHandle(2)
0099 CHARACTER commSetting
0100 LOGICAL withSigns
0101 INTEGER myThid
0102 CEOP
0103
0104 C !LOCAL VARIABLES:
0105 C == Local variables ==
0106 C itl,jtl,ktl :: Loop counters
0107 C :: itl etc... target local
0108 C :: itc etc... target canonical
0109 C :: isl etc... source local
0110 C :: isc etc... source canonical
0111 C tgT :: Target tile
0112 C itb, jtb :: Target local to canonical offsets
0113 C iBufr1 :: number of buffer-1 elements filled in
0114 C iBufr2 :: number of buffer-2 elements filled in
0115 INTEGER itl, jtl, ktl
0116 INTEGER itc, jtc
0117 INTEGER isc, jsc
0118 INTEGER isl, jsl
0119 INTEGER tgT
0120 INTEGER itb, jtb
0121 INTEGER isb, jsb
7c69cee546 Jean*0122 INTEGER iBufr1, iBufr2, iLoc
ed81d0a43c Jean*0123 INTEGER pi(2), pj(2)
0124 _RX sa1, sa2, val1, val2
0125
0126 CHARACTER*(MAX_LEN_MBUF) msgBuf
7c69cee546 Jean*0127 #ifdef W2_E2_DEBUG_ON
0128 LOGICAL prtFlag
ed81d0a43c Jean*0129 #endif
0130
0131 IF ( commSetting .EQ. 'P' ) THEN
0132 C AD: 1 Need to check and spin on data ready assertion for multithreaded mode,
0133 C AD: for now, ensure global sync using barrier.
0134 C AD: 2 get directly data from 1rst level buffer (sLv=1);
0135 ENDIF
0136
0137 tgT = exch2_neighbourId(nN, thisTile )
0138 itb = exch2_tBasex(tgT)
0139 jtb = exch2_tBasey(tgT)
0140 isb = exch2_tBasex(thisTile)
0141 jsb = exch2_tBasey(thisTile)
0142 pi(1)=exch2_pij(1,nN,thisTile)
0143 pi(2)=exch2_pij(2,nN,thisTile)
0144 pj(1)=exch2_pij(3,nN,thisTile)
0145 pj(2)=exch2_pij(4,nN,thisTile)
0146
0147 C Extract into bufr1 (target i-index array)
0148 C if pi(1) is 1 then +i in target <=> +i in source so bufr1 should get +array1
0149 C if pi(1) is -1 then +i in target <=> -i in source so bufr1 should get -array1
0150 C if pj(1) is 1 then +i in target <=> +j in source so bufr1 should get +array2
0151 C if pj(1) is -1 then +i in target <=> -j in source so bufr1 should get -array2
0152 sa1 = pi(1)
0153 sa2 = pj(1)
0154 IF ( .NOT. withSigns ) THEN
0155 sa1 = ABS(sa1)
0156 sa2 = ABS(sa2)
0157 ENDIF
0158 C if pi(1) is 1 then +i in source aligns with +i in target
0159 C if pj(1) is 1 then +i in source aligns with +j in target
0160 #ifdef W2_E2_DEBUG_ON
7c69cee546 Jean*0161 IF ( ABS(W2_printMsg).GE.2 ) THEN
b9dadda204 Mart*0162 WRITE(msgBuf,'(2A,I8,I3,A,I8)') 'EXCH2_AD_PUT_RX2',
7c69cee546 Jean*0163 & ' sourceTile,neighb=', thisTile, nN, ' : targetTile=', tgT
0164 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0165 I SQUEEZE_BOTH, myThid )
0166 ENDIF
0167 prtFlag = ABS(W2_printMsg).GE.3
ed81d0a43c Jean*0168 #endif /* W2_E2_DEBUG_ON */
0169 iBufr1=0
0170 DO ktl=tKlo,tKhi,tkStride
0171 DO jtl=tJlo1, tJhi1, tjStride
0172 DO itl=tIlo1, tIhi1, tiStride
0173 iBufr1=iBufr1+1
0174 itc = itl+itb
0175 jtc = jtl+jtb
0176 isc = pi(1)*itc+pi(2)*jtc+oIs1
0177 jsc = pj(1)*itc+pj(2)*jtc+oJs1
0178 isl = isc-isb
0179 jsl = jsc-jsb
0180 #ifdef W2_E2_DEBUG_ON
7c69cee546 Jean*0181 IF ( prtFlag ) THEN
0182 WRITE(msgBuf,'(A,2I5)')
0183 & 'EXCH2_AD_PUT_RX2 target u(itl,jtl) =', itl, jtl
ed81d0a43c Jean*0184 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0185 I SQUEEZE_RIGHT, myThid )
7c69cee546 Jean*0186 IF ( pi(1) .EQ. 1 ) THEN
0187 C i index aligns
0188 WRITE(msgBuf,'(A,2I5)')
0189 & ' source +u(isl,jsl) =', isl, jsl
0190 ELSEIF ( pi(1) .EQ. -1 ) THEN
0191 C reversed i index aligns
0192 WRITE(msgBuf,'(A,2I5)')
0193 & ' source -u(isl,jsl) =', isl, jsl
0194 ELSEIF ( pj(1) .EQ. 1 ) THEN
0195 WRITE(msgBuf,'(A,2I5)')
0196 & ' source +v(isl,jsl) =', isl, jsl
0197 ELSEIF ( pj(1) .EQ. -1 ) THEN
0198 WRITE(msgBuf,'(A,2I5)')
0199 & ' source -v(isl,jsl) =', isl, jsl
0200 ENDIF
ed81d0a43c Jean*0201 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0202 I SQUEEZE_RIGHT, myThid )
0203 ENDIF
0204 IF ( isl .LT. i1Lo .OR. isl .GT. i1Hi ) THEN
0205 C Forward mode send getting from points outside of the
0206 C tiles exclusive domain bounds in X. This should not happen
7c69cee546 Jean*0207 WRITE(msgBuf,'(2A,I4,A,2I4,A)') 'EXCH2_AD_PUT_RX2:',
0208 & ' isl=', isl, ' is out of bounds (i1Lo,Hi=',i1Lo,i1Hi,')'
0209 CALL PRINT_ERROR ( msgBuf, myThid )
0210 WRITE(msgBuf,'(2A,2I4,A,3I6)') 'EXCH2_AD_PUT_RX2:',
0211 & ' for itl,jtl=', itl, jtl, ' itc,jtc,isc=', itc, jtc, isc
0212 CALL PRINT_ERROR ( msgBuf, myThid )
0213 STOP 'ABNORMAL END: S/R EXCH2_AD_PUT_RX2 (isl out of bounds)'
ed81d0a43c Jean*0214 ENDIF
0215 IF ( jsl .LT. j1Lo .OR. jsl .GT. j1Hi ) THEN
0216 C Forward mode send getting from points outside of the
0217 C tiles exclusive domain bounds in Y. This should not happen
7c69cee546 Jean*0218 WRITE(msgBuf,'(2A,I4,A,2I4,A)') 'EXCH2_AD_PUT_RX2:',
0219 & ' jsl=', jsl, ' is out of bounds (j1Lo,Hi=',j1Lo,j1Hi,')'
0220 CALL PRINT_ERROR ( msgBuf, myThid )
0221 WRITE(msgBuf,'(2A,2I4,A,3I6)') 'EXCH2_AD_PUT_RX2:',
0222 & ' for itl,jtl=', itl, jtl, ' itc,jtc,jsc=', itc, jtc, jsc
0223 CALL PRINT_ERROR ( msgBuf, myThid )
0224 STOP 'ABNORMAL END: S/R EXCH2_AD_PUT_RX2 (jsl out of bounds)'
ed81d0a43c Jean*0225 ENDIF
7c69cee546 Jean*0226 #endif /* W2_E2_DEBUG_ON */
0227 #ifdef W2_USE_E2_SAFEMODE
0228 iLoc = MIN( iBufr1, e2BufrRecSize )
0229 #else
0230 iLoc = iBufr1
0231 #endif
0232 val1 = e2Bufr1_RX(iLoc)
ed81d0a43c Jean*0233 array1(isl,jsl,ktl) = array1(isl,jsl,ktl) + sa1*val1
0234 array2(isl,jsl,ktl) = array2(isl,jsl,ktl) + sa2*val1
0235 ENDDO
0236 ENDDO
0237 ENDDO
7c69cee546 Jean*0238 IF ( iBufr1 .GT. e2BufrRecSize ) THEN
0239 C Ran off end of buffer. This should not happen
0240 WRITE(msgBuf,'(2A,I9,A,I9)') 'EXCH2_AD_PUT_RX2:',
0241 & ' iBufr1=', iBufr1, ' exceeds E2BUFR size=', e2BufrRecSize
0242 CALL PRINT_ERROR ( msgBuf, myThid )
0243 STOP 'ABNORMAL END: S/R EXCH2_AD_PUT_RX2 (iBufr1 over limit)'
0244 ENDIF
ed81d0a43c Jean*0245
0246 C Extract values into bufr2
0247 C if pi(2) is 1 then +j in target <=> +i in source so bufr1 should get +array1
0248 C if pi(2) is -1 then +j in target <=> -i in source so bufr1 should get -array1
0249 C if pj(2) is 1 then +j in target <=> +j in source so bufr1 should get +array2
0250 C if pj(2) is -1 then +j in target <=> -j in source so bufr1 should get -array2
0251 sa1 = pi(2)
0252 sa2 = pj(2)
0253 IF ( .NOT. withSigns ) THEN
0254 sa1 = ABS(sa1)
0255 sa2 = ABS(sa2)
0256 ENDIF
0257 iBufr2=0
0258 DO ktl=tKlo,tKhi,tkStride
0259 DO jtl=tJlo2, tJhi2, tjStride
0260 DO itl=tIlo2, tIhi2, tiStride
0261 iBufr2=iBufr2+1
0262 itc = itl+itb
0263 jtc = jtl+jtb
0264 isc = pi(1)*itc+pi(2)*jtc+oIs2
0265 jsc = pj(1)*itc+pj(2)*jtc+oJs2
0266 isl = isc-isb
0267 jsl = jsc-jsb
0268 #ifdef W2_E2_DEBUG_ON
7c69cee546 Jean*0269 IF ( prtFlag ) THEN
0270 WRITE(msgBuf,'(A,2I5)')
0271 & 'EXCH2_AD_PUT_RX2 target v(itl,jtl) =', itl, jtl
ed81d0a43c Jean*0272 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0273 I SQUEEZE_RIGHT, myThid )
7c69cee546 Jean*0274 IF ( pi(2) .EQ. 1 ) THEN
0275 C i index aligns
0276 WRITE(msgBuf,'(A,2I5)')
0277 & ' source +u(isl,jsl) =', isl, jsl
0278 ELSEIF ( pi(2) .EQ. -1 ) THEN
0279 C reversed i index aligns
0280 WRITE(msgBuf,'(A,2I5)')
0281 & ' source -u(isl,jsl) =', isl, jsl
0282 ELSEIF ( pj(2) .EQ. 1 ) THEN
0283 WRITE(msgBuf,'(A,2I5)')
0284 & ' source +v(isl,jsl) =', isl, jsl
0285 ELSEIF ( pj(2) .EQ. -1 ) THEN
0286 WRITE(msgBuf,'(A,2I5)')
0287 & ' source -v(isl,jsl) =', isl, jsl
0288 ENDIF
ed81d0a43c Jean*0289 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0290 I SQUEEZE_RIGHT, myThid )
0291 ENDIF
7c69cee546 Jean*0292 IF ( isl .LT. i2Lo .OR. isl .GT. i2Hi ) THEN
ed81d0a43c Jean*0293 C Forward mode send getting from points outside of the
0294 C tiles exclusive domain bounds in X. This should not happen
7c69cee546 Jean*0295 WRITE(msgBuf,'(2A,I4,A,2I4,A)') 'EXCH2_AD_PUT_RX2:',
0296 & ' isl=', isl, ' is out of bounds (i2Lo,Hi=',i2Lo,i2Hi,')'
0297 CALL PRINT_ERROR ( msgBuf, myThid )
0298 WRITE(msgBuf,'(2A,2I4,A,3I6)') 'EXCH2_AD_PUT_RX2:',
0299 & ' for itl,jtl=', itl, jtl, ' itc,jtc,isc=', itc, jtc, isc
0300 CALL PRINT_ERROR ( msgBuf, myThid )
0301 STOP 'ABNORMAL END: S/R EXCH2_AD_PUT_RX2 (isl out of bounds)'
ed81d0a43c Jean*0302 ENDIF
7c69cee546 Jean*0303 IF ( jsl .LT. j2Lo .OR. jsl .GT. j2Hi ) THEN
ed81d0a43c Jean*0304 C Forward mode send getting from points outside of the
0305 C tiles exclusive domain bounds in Y. This should not happen
7c69cee546 Jean*0306 WRITE(msgBuf,'(2A,I4,A,2I4,A)') 'EXCH2_AD_PUT_RX2:',
0307 & ' jsl=', jsl, ' is out of bounds (j2Lo,Hi=',j2Lo,j2Hi,')'
0308 CALL PRINT_ERROR ( msgBuf, myThid )
0309 WRITE(msgBuf,'(2A,2I4,A,3I6)') 'EXCH2_AD_PUT_RX2:',
0310 & ' for itl,jtl=', itl, jtl, ' itc,jtc,jsc=', itc, jtc, jsc
0311 CALL PRINT_ERROR ( msgBuf, myThid )
0312 STOP 'ABNORMAL END: S/R EXCH2_AD_PUT_RX2 (jsl out of bounds)'
ed81d0a43c Jean*0313 ENDIF
7c69cee546 Jean*0314 #endif /* W2_E2_DEBUG_ON */
0315 #ifdef W2_USE_E2_SAFEMODE
0316 iLoc = MIN( iBufr2, e2BufrRecSize )
0317 #else
0318 iLoc = iBufr2
0319 #endif
0320 val2 = e2Bufr2_RX(iLoc)
ed81d0a43c Jean*0321 array1(isl,jsl,ktl) = array1(isl,jsl,ktl) + sa1*val2
0322 array2(isl,jsl,ktl) = array2(isl,jsl,ktl) + sa2*val2
0323 ENDDO
0324 ENDDO
0325 ENDDO
7c69cee546 Jean*0326 IF ( iBufr2 .GT. e2BufrRecSize ) THEN
0327 C Ran off end of buffer. This should not happen
0328 WRITE(msgBuf,'(2A,I9,A,I9)') 'EXCH2_AD_PUT_RX2:',
0329 & ' iBufr2=', iBufr2, ' exceeds E2BUFR size=', e2BufrRecSize
0330 CALL PRINT_ERROR ( msgBuf, myThid )
0331 STOP 'ABNORMAL END: S/R EXCH2_AD_PUT_RX2 (iBufr2 over limit)'
0332 ENDIF
ed81d0a43c Jean*0333
0334 RETURN
0335 END
0336
0337 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
0338
0339 CEH3 ;;; Local Variables: ***
0340 CEH3 ;;; mode:fortran ***
0341 CEH3 ;;; End: ***
