Warning, /pkg/exch2/exch2_ad_put_rx1.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_RX1
0006
0007 C !INTERFACE:
0008 SUBROUTINE EXCH2_AD_PUT_RX1 (
0009 I tIlo, tIhi, tiStride,
0010 I tJlo, tJhi, tjStride,
0011 I tKlo, tKhi, tkStride,
0012 I thisTile, nN,
0013 I e2BufrRecSize,
0014 I e2Bufr1_RX,
0015 U array,
0016 I i1Lo, i1Hi, j1Lo, j1Hi, k1Lo, k1Hi,
0017 O e2_msgHandle,
0018 I commSetting, myThid )
0019
0020 C !DESCRIPTION:
0021 C---------------
d6ea3164dc Jean*0022 C AD: IMPORTANT: all comments (except AD:) are taken from the Forward S/R
ed81d0a43c Jean*0023 C AD: and need to be interpreted in the reverse sense: put <-> get,
0024 C AD: send <-> recv, source <-> target ...
0025 C---------------
0026 C Scalar field (1 component) Exchange:
0027 C Put into buffer exchanged data from this source tile.
d6ea3164dc Jean*0028 C Those data are intended to fill-in the
ed81d0a43c Jean*0029 C target-neighbour-edge overlap region.
0030
0031 C !USES:
0032 IMPLICIT NONE
0033
0034 #include "SIZE.h"
0035 #include "EEPARAMS.h"
0036 #include "W2_EXCH2_SIZE.h"
0037 #include "W2_EXCH2_TOPOLOGY.h"
7c69cee546 Jean*0038 #ifdef W2_E2_DEBUG_ON
0039 # include "W2_EXCH2_PARAMS.h"
0040 #endif
ed81d0a43c Jean*0041
0042 C !INPUT/OUTPUT PARAMETERS:
0043 C === Routine arguments ===
0044 C tIlo, tIhi :: index range in I that will be filled in target "array"
0045 C tIstride :: index step in I that will be filled in target "array"
0046 C tJlo, tJhi :: index range in J that will be filled in target "array"
0047 C tJstride :: index step in J that will be filled in target "array"
0048 C tKlo, tKhi :: index range in K that will be filled in target "array"
0049 C tKstride :: index step in K that will be filled in target "array"
0050 C thisTile :: sending tile Id. number
0051 C nN :: Neighbour entry that we are processing
0052 C e2BufrRecSize :: Number of elements in each entry of e2Bufr1_RX
0053 C e2Bufr1_RX :: Data transport buffer array. This array is used in one of
0054 C :: two ways. For PUT communication the entry in the buffer
0055 C :: associated with the source for this receive (determined
0056 C :: from the opposing_send index) is read.
0057 C :: For MSG communication the entry in the buffer associated
0058 C :: with this neighbor of this tile is used as a receive
0059 C :: location for loading a linear stream of bytes.
0060 C array :: Source array where the data come from
0061 C i1Lo, i1Hi :: I coordinate bounds of target array
0062 C j1Lo, j1Hi :: J coordinate bounds of target array
0063 C k1Lo, k1Hi :: K coordinate bounds of target array
0064 C e2_msgHandles :: Synchronization and coordination data structure used to
0065 C :: coordinate access to e2Bufr1_RX or to regulate message
0066 C :: buffering. In PUT communication sender will increment
0067 C :: handle entry once data is ready in buffer. Receiver will
0068 C :: decrement handle once data is consumed from buffer.
d6ea3164dc Jean*0069 C :: For MPI MSG communication MPI_Wait uses handle to check
ed81d0a43c Jean*0070 C :: Isend has cleared. This is done in routine after receives.
0071 C commSetting :: Mode of communication used to exchange with this neighbor
0072 C myThid :: my Thread Id. number
0073
0074 INTEGER tILo, tIHi, tiStride
0075 INTEGER tJLo, tJHi, tjStride
0076 INTEGER tKLo, tKHi, tkStride
0077 INTEGER i1Lo, i1Hi, j1Lo, j1Hi, k1Lo, k1Hi
0078 INTEGER thisTile, nN
0079 INTEGER e2BufrRecSize
0080 _RX e2Bufr1_RX( e2BufrRecSize )
0081 _RX array(i1Lo:i1Hi,j1Lo:j1Hi,k1Lo:k1Hi)
0082 INTEGER e2_msgHandle(1)
0083 CHARACTER commSetting
0084 INTEGER myThid
0085 CEOP
0086
0087 C !LOCAL VARIABLES:
0088 C == Local variables ==
0089 C itl,jtl,ktl :: Loop counters
0090 C :: itl etc... target local
0091 C :: itc etc... target canonical
0092 C :: isl etc... source local
0093 C :: isc etc... source canonical
0094 C tgT :: Target tile Id. number
0095 C itb, jtb :: Target local to canonical offsets
d6ea3164dc Jean*0096 C iBufr :: number of buffer elements to transfer
ed81d0a43c Jean*0097 INTEGER itl, jtl, ktl
0098 INTEGER itc, jtc
0099 INTEGER isc, jsc
0100 INTEGER isl, jsl
0101 INTEGER tgT
0102 INTEGER itb, jtb
0103 INTEGER isb, jsb
0104 INTEGER pi(2), pj(2), oi, oj
7c69cee546 Jean*0105 INTEGER iBufr, iLoc
ed81d0a43c Jean*0106
0107 CHARACTER*(MAX_LEN_MBUF) msgBuf
7c69cee546 Jean*0108 #ifdef W2_E2_DEBUG_ON
0109 LOGICAL prtFlag
ed81d0a43c Jean*0110 #endif
0111
0112 c IF ( commSetting .EQ. 'P' ) THEN
0113 C AD: 1 Need to check and spin on data ready assertion for multithreaded mode,
0114 C AD: for now, ensure global sync using barrier.
0115 C AD: 2 get directly data from 1rst level buffer (sLv=1);
0116 c ENDIF
0117
0118 tgT = exch2_neighbourId(nN, thisTile )
0119 itb = exch2_tBasex(tgT)
0120 jtb = exch2_tBasey(tgT)
0121 isb = exch2_tBasex(thisTile)
0122 jsb = exch2_tBasey(thisTile)
0123 pi(1)=exch2_pij(1,nN,thisTile)
0124 pi(2)=exch2_pij(2,nN,thisTile)
0125 pj(1)=exch2_pij(3,nN,thisTile)
0126 pj(2)=exch2_pij(4,nN,thisTile)
0127 oi = exch2_oi(nN,thisTile)
0128 oj = exch2_oj(nN,thisTile)
0129 #ifdef W2_E2_DEBUG_ON
7c69cee546 Jean*0130 IF ( ABS(W2_printMsg).GE.2 ) THEN
b9dadda204 Mart*0131 WRITE(msgBuf,'(2A,I8,I3,A,I8)') 'EXCH2_AD_PUT_RX1',
7c69cee546 Jean*0132 & ' sourceTile,neighb=', thisTile, nN, ' : targetTile=', tgT
0133 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0134 I SQUEEZE_BOTH, myThid )
0135 ENDIF
0136 prtFlag = ABS(W2_printMsg).GE.3
ed81d0a43c Jean*0137 #endif /* W2_E2_DEBUG_ON */
0138 iBufr=0
0139 DO ktl=tKlo,tKhi,tKStride
0140 DO jtl=tJLo, tJHi, tjStride
0141 DO itl=tILo, tIHi, tiStride
0142 iBufr=iBufr+1
0143 itc = itl+itb
0144 jtc = jtl+jtb
0145 isc = pi(1)*itc+pi(2)*jtc+oi
0146 jsc = pj(1)*itc+pj(2)*jtc+oj
0147 isl = isc-isb
0148 jsl = jsc-jsb
0149 #ifdef W2_E2_DEBUG_ON
7c69cee546 Jean*0150 IF ( prtFlag ) THEN
ed81d0a43c Jean*0151 WRITE(msgBuf,'(A,2I5)')
7c69cee546 Jean*0152 & 'EXCH2_AD_PUT_RX1 target t(itl,jtl) =', itl, jtl
ed81d0a43c Jean*0153 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0154 I SQUEEZE_RIGHT, myThid )
0155 WRITE(msgBuf,'(A,2I5)')
7c69cee546 Jean*0156 & ' source (isl,jsl) =', isl, jsl
ed81d0a43c Jean*0157 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0158 I SQUEEZE_RIGHT, myThid )
0159 ENDIF
0160 IF ( isl .LT. i1Lo .OR. isl .GT. i1Hi ) THEN
0161 C Forward mode send getting from points outside of the
0162 C tiles exclusive domain bounds in X. This should not happen
7c69cee546 Jean*0163 WRITE(msgBuf,'(2A,I4,A,2I4,A)') 'EXCH2_AD_PUT_RX1:',
0164 & ' isl=', isl, ' is out of bounds (i1Lo,Hi=',i1Lo,i1Hi,')'
0165 CALL PRINT_ERROR ( msgBuf, myThid )
0166 WRITE(msgBuf,'(2A,2I4,A,3I6)') 'EXCH2_AD_PUT_RX1:',
0167 & ' for itl,jtl=', itl, jtl, ' itc,jtc,isc=', itc, jtc, isc
0168 CALL PRINT_ERROR ( msgBuf, myThid )
0169 STOP 'ABNORMAL END: S/R EXCH2_AD_PUT_RX1 (isl out of bounds)'
ed81d0a43c Jean*0170 ENDIF
0171 IF ( jsl .LT. j1Lo .OR. jsl .GT. j1Hi ) THEN
0172 C Forward mode send getting from points outside of the
0173 C tiles exclusive domain bounds in Y. This should not happen
7c69cee546 Jean*0174 WRITE(msgBuf,'(2A,I4,A,2I4,A)') 'EXCH2_AD_PUT_RX1:',
0175 & ' jsl=', jsl, ' is out of bounds (j1Lo,Hi=',j1Lo,j1Hi,')'
0176 CALL PRINT_ERROR ( msgBuf, myThid )
0177 WRITE(msgBuf,'(2A,2I4,A,3I6)') 'EXCH2_AD_PUT_RX1:',
0178 & ' for itl,jtl=', itl, jtl, ' itc,jtc,jsc=', itc, jtc, jsc
0179 CALL PRINT_ERROR ( msgBuf, myThid )
0180 STOP 'ABNORMAL END: S/R EXCH2_AD_PUT_RX1 (jsl out of bounds)'
ed81d0a43c Jean*0181 ENDIF
7c69cee546 Jean*0182 #endif /* W2_E2_DEBUG_ON */
0183 #ifdef W2_USE_E2_SAFEMODE
0184 iLoc = MIN( iBufr, e2BufrRecSize )
0185 #else
0186 iLoc = iBufr
0187 #endif
0188 array(isl,jsl,ktl) = array(isl,jsl,ktl) + e2Bufr1_RX(iLoc)
0189 e2Bufr1_RX(iLoc) = 0. _d 0
ed81d0a43c Jean*0190 ENDDO
0191 ENDDO
0192 ENDDO
7c69cee546 Jean*0193 IF ( iBufr .GT. e2BufrRecSize ) THEN
0194 C Ran off end of buffer. This should not happen
0195 WRITE(msgBuf,'(2A,I9,A,I9)') 'EXCH2_AD_PUT_RX1:',
0196 & ' iBufr =', iBufr, ' exceeds E2BUFR size=', e2BufrRecSize
0197 CALL PRINT_ERROR ( msgBuf, myThid )
0198 STOP 'ABNORMAL END: S/R EXCH2_AD_PUT_RX1 (iBufr over limit)'
0199 ENDIF
ed81d0a43c Jean*0200
0201 RETURN
0202 END
0203
0204 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
0205
0206 CEH3 ;;; Local Variables: ***
0207 CEH3 ;;; mode:fortran ***
0208 CEH3 ;;; End: ***
