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