Warning, /eesupp/src/gather_2d_rx.template is written in an unsupported language. File is not indexed.
view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTC
2c3e6deece Jean*0001 #include "PACKAGES_CONFIG.h"
0002 #include "CPP_EEOPTIONS.h"
0003
0004 CBOP
0005 C !ROUTINE: GATHER_2D_RX
0006 C !INTERFACE:
0007 SUBROUTINE GATHER_2D_RX(
0008 O gloBuff,
0009 I myField,
0010 I xSize, ySize,
17eb230979 Jean*0011 I useExch2GlobLayOut,
2c3e6deece Jean*0012 I zeroBuff,
0013 I myThid )
0014 C !DESCRIPTION:
0015 C Gather elements of a global 2-D array from all mpi processes to process 0.
1707a3cb3a Jean*0016 C Note: done by Master-Thread ; might need barrier calls before and after
0017 C this S/R call.
2c3e6deece Jean*0018
0019 C !USES:
0020 IMPLICIT NONE
0021 #include "SIZE.h"
0022 #include "EEPARAMS.h"
0023 #include "EESUPPORT.h"
0024 #ifdef ALLOW_EXCH2
1cc6effca6 Jean*0025 #include "W2_EXCH2_SIZE.h"
2c3e6deece Jean*0026 #include "W2_EXCH2_TOPOLOGY.h"
0027 #endif /* ALLOW_EXCH2 */
0028
0029 C !INPUT/OUTPUT PARAMETERS:
0030 C gloBuff ( _RX ) :: full-domain 2D IO-buffer array (Output)
0031 C myField ( _RX ) :: tiled, local (i.e. my Proc. tiles) 2D array (Input)
0032 C xSize (integer):: global buffer 1rst dim (x)
0033 C ySize (integer):: global buffer 2nd dim (y)
17eb230979 Jean*0034 C useExch2GlobLayOut:: =T: Use Exch2 global-map layout (only with EXCH2)
2c3e6deece Jean*0035 C zeroBuff (logical):: =T: initialise the buffer to zero before copy
0036 C myThid (integer):: my Thread Id number
0037
0038 INTEGER xSize, ySize
0039 _RX gloBuff(xSize,ySize)
0040 _RX myField(1:sNx,1:sNy,nSx,nSy)
17eb230979 Jean*0041 LOGICAL useExch2GlobLayOut
2c3e6deece Jean*0042 LOGICAL zeroBuff
0043 INTEGER myThid
0044 CEOP
0045
0046 C !LOCAL VARIABLES:
0047 INTEGER i,j, bi,bj
0048 INTEGER iG, jG
0049 INTEGER iBase, jBase
0050 #ifdef ALLOW_EXCH2
0051 INTEGER iGjLoc, jGjLoc
0052 INTEGER tN
0053 #endif /* ALLOW_EXCH2 */
0054 #ifdef ALLOW_USE_MPI
1071dbe8ca Jean*0055 INTEGER np, pId
2c3e6deece Jean*0056 _RX temp(1:sNx,1:sNy,nSx,nSy)
0057 INTEGER istatus(MPI_STATUS_SIZE), ierr
0058 INTEGER lbuff, idest, itag, ready_to_receive
0059 #endif /* ALLOW_USE_MPI */
0060
0061 _BEGIN_MASTER( myThid )
0062
0063 IF( myProcId .EQ. 0 ) THEN
0064 C-- Process 0 fills-in its local data
0065
0066 #ifdef ALLOW_EXCH2
17eb230979 Jean*0067 IF ( useExch2GlobLayOut ) THEN
2c3e6deece Jean*0068 C-- If using blank-tiles, buffer will not be completely filled;
0069 C safer to reset to zero to avoid unknown values in output file
0070 IF ( zeroBuff ) THEN
0071 DO j=1,ySize
0072 DO i=1,xSize
0073 gloBuff(i,j) = 0.
0074 ENDDO
0075 ENDDO
0076 ENDIF
0077
6e33c64afb Jean*0078 DO bj=1,nSy
2c3e6deece Jean*0079 DO bi=1,nSx
6e33c64afb Jean*0080 tN = W2_myTileList(bi,bj)
2c3e6deece Jean*0081 IF ( exch2_mydNx(tN) .GT. xSize ) THEN
0082 C- face x-size larger than glob-size : fold it
0083 iGjLoc = 0
0084 jGjLoc = exch2_mydNx(tN) / xSize
0085 ELSEIF ( exch2_tNy(tN) .GT. ySize ) THEN
0086 C- tile y-size larger than glob-size : make a long line
0087 iGjLoc = exch2_mydNx(tN)
0088 jGjLoc = 0
0089 ELSE
0090 C- default (face fit into global-IO-array)
0091 iGjLoc = 0
0092 jGjLoc = 1
0093 ENDIF
0094
0095 DO j=1,sNy
0096 #ifdef TARGET_NEC_SX
0097 !cdir novector
0098 #endif
0099 iG=exch2_txGlobalo(tN)+iGjLoc*(j-1)-1
0100 jG=exch2_tyGlobalo(tN)+jGjLoc*(j-1)
0101 DO i=1,sNx
0102 gloBuff(iG+i,jG) = myField(i,j,bi,bj)
0103 ENDDO
0104 ENDDO
0105
0106 ENDDO
6e33c64afb Jean*0107 ENDDO
2c3e6deece Jean*0108
0109 ELSE
0110 #else /* ALLOW_EXCH2 */
0111 IF (.TRUE.) THEN
0112 #endif /* ALLOW_EXCH2 */
0113
df6a8765ed Jean*0114 iBase = myXGlobalLo-1
0115 jBase = myYGlobalLo-1
2c3e6deece Jean*0116
0117 DO bj=1,nSy
0118 DO bi=1,nSx
0119 DO j=1,sNy
0120 #ifdef TARGET_NEC_SX
0121 !cdir novector
0122 #endif
0123 iG = iBase+(bi-1)*sNx
0124 jG = jBase+(bj-1)*sNy+j
0125 DO i=1,sNx
0126 gloBuff(iG+i,jG) = myField(i,j,bi,bj)
0127 ENDDO
0128 ENDDO
0129 ENDDO
0130 ENDDO
0131
17eb230979 Jean*0132 C end if-else useExch2GlobLayOut
2c3e6deece Jean*0133 ENDIF
0134
0135 C- end if myProcId = 0
0136 ENDIF
0137
0138 #ifdef ALLOW_USE_MPI
1071dbe8ca Jean*0139 IF ( usingMPI ) THEN
2c3e6deece Jean*0140
1071dbe8ca Jean*0141 lbuff = sNx*nSx*sNy*nSy
0142 idest = 0
0143 itag = 0
0144 ready_to_receive = 0
2c3e6deece Jean*0145
1071dbe8ca Jean*0146 IF( mpiMyId .EQ. 0 ) THEN
2c3e6deece Jean*0147
0148 C-- Process 0 polls and receives data from each process in turn
1071dbe8ca Jean*0149 DO np = 2, nPx*nPy
0150 pId = np - 1
2c3e6deece Jean*0151 #ifndef DISABLE_MPI_READY_TO_RECEIVE
0152 CALL MPI_SEND (ready_to_receive, 1, MPI_INTEGER,
1071dbe8ca Jean*0153 & pId, itag, MPI_COMM_MODEL, ierr)
2c3e6deece Jean*0154 #endif
0155 CALL MPI_RECV (temp, lbuff, _MPI_TYPE_RX,
1071dbe8ca Jean*0156 & pId, itag, MPI_COMM_MODEL, istatus, ierr)
2c3e6deece Jean*0157
0158 C-- Process 0 gathers the local arrays into the global buffer.
0159 #ifdef ALLOW_EXCH2
17eb230979 Jean*0160 IF ( useExch2GlobLayOut ) THEN
2c3e6deece Jean*0161
6e33c64afb Jean*0162 DO bj=1,nSy
2c3e6deece Jean*0163 DO bi=1,nSx
6e33c64afb Jean*0164 tN = W2_procTileList(bi,bj,np)
2c3e6deece Jean*0165 IF ( exch2_mydNx(tN) .GT. xSize ) THEN
0166 C- face x-size larger than glob-size : fold it
0167 iGjLoc = 0
0168 jGjLoc = exch2_mydNx(tN) / xSize
0169 ELSEIF ( exch2_tNy(tN) .GT. ySize ) THEN
0170 C- tile y-size larger than glob-size : make a long line
0171 iGjLoc = exch2_mydNx(tN)
0172 jGjLoc = 0
0173 ELSE
0174 C- default (face fit into global-IO-array)
0175 iGjLoc = 0
0176 jGjLoc = 1
0177 ENDIF
0178
0179 DO j=1,sNy
0180 #ifdef TARGET_NEC_SX
0181 !cdir novector
0182 #endif
0183 iG=exch2_txGlobalo(tN)+iGjLoc*(j-1)-1
0184 jG=exch2_tyGlobalo(tN)+jGjLoc*(j-1)
0185 DO i=1,sNx
0186 gloBuff(iG+i,jG) = temp(i,j,bi,bj)
0187 ENDDO
0188 ENDDO
0189
0190 ENDDO
6e33c64afb Jean*0191 ENDDO
2c3e6deece Jean*0192
0193 ELSE
0194 #else /* ALLOW_EXCH2 */
0195 IF (.TRUE.) THEN
0196 #endif /* ALLOW_EXCH2 */
0197
df6a8765ed Jean*0198 iBase = mpi_myXGlobalLo(np)-1
0199 jBase = mpi_myYGlobalLo(np)-1
2c3e6deece Jean*0200
0201 DO bj=1,nSy
0202 DO bi=1,nSx
0203 DO j=1,sNy
0204 #ifdef TARGET_NEC_SX
0205 !cdir novector
0206 #endif
0207 iG = iBase+(bi-1)*sNx
0208 jG = jBase+(bj-1)*sNy+j
0209 DO i=1,sNx
0210 gloBuff(iG+i,jG) = temp(i,j,bi,bj)
0211 ENDDO
0212 ENDDO
0213 ENDDO
0214 ENDDO
0215
17eb230979 Jean*0216 C end if-else useExch2GlobLayOut
2c3e6deece Jean*0217 ENDIF
0218
0219 C- end loop on np
0220 ENDDO
0221
1071dbe8ca Jean*0222 ELSE
2c3e6deece Jean*0223
0224 C-- All proceses except 0 wait to be polled then send local array
0225 #ifndef DISABLE_MPI_READY_TO_RECEIVE
0226 CALL MPI_RECV (ready_to_receive, 1, MPI_INTEGER,
0227 & idest, itag, MPI_COMM_MODEL, istatus, ierr)
0228 #endif
0229 CALL MPI_SEND (myField, lbuff, _MPI_TYPE_RX,
0230 & idest, itag, MPI_COMM_MODEL, ierr)
0231
1071dbe8ca Jean*0232 ENDIF
2c3e6deece Jean*0233
1071dbe8ca Jean*0234 ENDIF
2c3e6deece Jean*0235 #endif /* ALLOW_USE_MPI */
0236
0237 _END_MASTER( myThid )
0238
0239 RETURN
0240 END
