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