eesupp/src/cumulsum_z_tile.F

e5d1763db4 Jean*0001 #include "PACKAGES_CONFIG.h"
                0002 #include "CPP_EEOPTIONS.h"
                0003
                0004 C--   File cumulsum_z_tile.F: Routines that perform cumulated sum
                0005 C                             on a tiled array, corner grid-cell location
                0006 C      Contents
                0007 C      o CUMULSUM_Z_TILE_RL
                0008 C      o CUMULSUM_Z_TILE_RS <- not yet coded
                0009
                0010 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0011 CBOP
                0012 C     !ROUTINE: CUMULSUM_Z_TILE_RL
                0013
                0014 C     !INTERFACE:
                0015       SUBROUTINE CUMULSUM_Z_TILE_RL(
                0016      O                       psiZ, psiLoc,
                0017      I                       dPsiX, dPsiY, myThid )
                0018
                0019 C     !DESCRIPTION:
                0020 C     *==========================================================*
                0021 C     | SUBROUTINE CUMULSUM\_Z\_TILE\_RL
                0022 C     | o Handle cumulated sum for _RL tile data.
                0023 C     *==========================================================*
                0024 C     | Cumulate sum on tiled array, corner grid-cell location:
                0025 C     |  Starts from 1rst tile and, going through all tiles & all
                0026 C     |  the processes, add increment in both directions
                0027 C     *==========================================================*
                0028
                0029 C     !USES:
                0030       IMPLICIT NONE
                0031
                0032 C     == Global data ==
                0033 #include "SIZE.h"
                0034 #include "EEPARAMS.h"
                0035 #include "EESUPPORT.h"
700d941f16 Jean*0036 #include "CUMULSUM.h"
e5d1763db4 Jean*0037
                0038 C     !INPUT/OUTPUT PARAMETERS:
                0039 C     == Routine arguments ==
                0040 C     psiZ    :: results of cumulated sum, corresponds to tile South-East corner
                0041 C     psiLoc  :: cumulated sum at special locations
                0042 C     dPsiX   :: tile increment in X direction
                0043 C     dPsiY   :: tile increment in Y direction
                0044 C     myThid  :: my Thread Id. number
                0045       _RL     psiZ  (nSx,nSy)
                0046       _RL     psiLoc(2)
                0047       _RL     dPsiX (nSx,nSy)
                0048       _RL     dPsiY (nSx,nSy)
                0049       INTEGER myThid
                0050
                0051 C     !LOCAL VARIABLES:
                0052 #ifndef ALLOW_EXCH2
                0053 C     == Local variables ==
                0054 C     bi,bj   :: tile indices
                0055 C- type declaration of: loc[1,2]Buf and shareBufCS[1,2]_R8 :
                0056 C         all 4 needs to have the same length as MPI_DOUBLE_PRECISION
                0057       INTEGER bi,bj
                0058       INTEGER nf
                0059 #ifdef ALLOW_USE_MPI
                0060       INTEGER biG, bjG, npe, np1
                0061       INTEGER lbuf1, lbuf2, idest, itag, ready_to_receive
                0062       INTEGER istatus(MPI_STATUS_SIZE), ierr
                0063       Real*8  loc1Buf  (nSx,nSy)
                0064       Real*8  loc2Buf(2,nSx,nSy)
                0065       Real*8  globalBuf(3,nSx*nPx,nSy*nPy)
                0066 #endif /* ALLOW_USE_MPI */
                0067 #endif /* ALLOW_EXCH2 */
                0068 CEOP
                0069
                0070 #ifdef ALLOW_EXCH2
700d941f16 Jean*0071       CALL W2_CUMULSUM_Z_TILE_RL(
                0072      O                       psiZ, psiLoc,
                0073      I                       dPsiX, dPsiY, myThid )
e5d1763db4 Jean*0074
ca1d7a672f Jean*0075 #else /* ALLOW_EXCH2 */
e5d1763db4 Jean*0076 C--   write input into shared-buffer array
                0077       DO bj = myByLo(myThid), myByHi(myThid)
                0078        DO bi = myBxLo(myThid), myBxHi(myThid)
                0079          shareBufCS2_R8(1,bi,bj) = dPsiX(bi,bj)
                0080          shareBufCS2_R8(2,bi,bj) = dPsiY(bi,bj)
                0081        ENDDO
                0082       ENDDO
                0083       psiLoc(1) = 0.
                0084       psiLoc(2) = 0.
                0085
                0086 C--   Master thread cannot start until everyone is ready:
                0087       CALL BAR2( myThid )
                0088       _BEGIN_MASTER( myThid )
                0089
                0090 #ifdef ALLOW_USE_MPI
                0091       IF ( usingMPI ) THEN
                0092
                0093         lbuf1 = nSx*nSy
                0094         lbuf2 = 2*lbuf1
                0095         idest = 0
                0096         itag  = 0
                0097         ready_to_receive = 0
                0098
                0099         IF ( mpiMyId.NE.0 ) THEN
                0100
                0101 C--   All proceses except 0 wait to be polled then send local array
                0102 #ifndef DISABLE_MPI_READY_TO_RECEIVE
                0103             CALL MPI_RECV (ready_to_receive, 1, MPI_INTEGER,
                0104      &           idest, itag, MPI_COMM_MODEL, istatus, ierr)
                0105 #endif
                0106             CALL MPI_SEND (shareBufCS2_R8, lbuf2, MPI_DOUBLE_PRECISION,
                0107      &           idest, itag, MPI_COMM_MODEL, ierr)
                0108
                0109 C--   All proceses except 0 receive result from process 0
                0110             CALL MPI_RECV (shareBufCS1_R8, lbuf1, MPI_DOUBLE_PRECISION,
                0111      &           idest, itag, MPI_COMM_MODEL, istatus, ierr)
                0112
                0113         ELSE
                0114
                0115 C--   Process 0 fills-in its local data
                0116           np1 = 1
                0117           DO bj=1,nSy
                0118             DO bi=1,nSx
                0119               biG = (mpi_myXGlobalLo(np1)-1)/sNx+bi
                0120               bjG = (mpi_myYGlobalLo(np1)-1)/sNy+bj
                0121               globalBuf(1,biG,bjG) = shareBufCS2_R8(1,bi,bj)
                0122               globalBuf(2,biG,bjG) = shareBufCS2_R8(2,bi,bj)
                0123             ENDDO
                0124           ENDDO
                0125
                0126 C--   Process 0 polls and receives data from each process in turn
                0127           DO npe = 1, numberOfProcs-1
                0128 #ifndef DISABLE_MPI_READY_TO_RECEIVE
                0129             CALL MPI_SEND (ready_to_receive, 1, MPI_INTEGER,
                0130      &             npe, itag, MPI_COMM_MODEL, ierr)
                0131 #endif
                0132             CALL MPI_RECV (loc2Buf, lbuf2, MPI_DOUBLE_PRECISION,
                0133      &             npe, itag, MPI_COMM_MODEL, istatus, ierr)
                0134
                0135 C--   Process 0 gathers the local arrays into a global array.
                0136             np1 = npe + 1
                0137             DO bj=1,nSy
                0138              DO bi=1,nSx
                0139               biG = (mpi_myXGlobalLo(np1)-1)/sNx+bi
                0140               bjG = (mpi_myYGlobalLo(np1)-1)/sNy+bj
                0141               globalBuf(1,biG,bjG) = loc2Buf(1,bi,bj)
                0142               globalBuf(2,biG,bjG) = loc2Buf(2,bi,bj)
                0143              ENDDO
                0144             ENDDO
                0145           ENDDO
                0146
                0147 C--   Cumulate Sum over all tiles:
                0148           globalBuf(3,1,1) = 0.
                0149           bj = 1
                0150           DO bi = 1,nSx*nPx-1
                0151             globalBuf(3,1+bi,bj) = globalBuf(3,bi,bj)
                0152      &                           + globalBuf(1,bi,bj)
                0153           ENDDO
                0154           DO bj = 1,nSy*nPy-1
                0155            DO bi = 1,nSx*nPx
                0156             globalBuf(3,bi,1+bj) = globalBuf(3,bi,bj)
                0157      &                           + globalBuf(2,bi,bj)
                0158            ENDDO
                0159           ENDDO
                0160
                0161 C--   Process 0 fills-in its local data
                0162           np1 = 1
                0163           DO bj=1,nSy
                0164             DO bi=1,nSx
                0165               biG = (mpi_myXGlobalLo(np1)-1)/sNx+bi
                0166               bjG = (mpi_myYGlobalLo(np1)-1)/sNy+bj
                0167               shareBufCS1_R8(bi,bj) = globalBuf(3,biG,bjG)
                0168             ENDDO
                0169           ENDDO
                0170
                0171 C--   Process 0 sends result to all other processes
                0172           DO npe = 1, numberOfProcs-1
                0173 C-    fill local array with relevant portion of global array
                0174             np1 = npe + 1
                0175             DO bj=1,nSy
                0176              DO bi=1,nSx
                0177               biG = (mpi_myXGlobalLo(np1)-1)/sNx+bi
                0178               bjG = (mpi_myYGlobalLo(np1)-1)/sNy+bj
                0179               loc1Buf(bi,bj) = globalBuf(3,biG,bjG)
                0180              ENDDO
                0181             ENDDO
                0182             CALL MPI_SEND (loc1Buf, lbuf1, MPI_DOUBLE_PRECISION,
                0183      &                     npe, itag, MPI_COMM_MODEL, ierr)
                0184
                0185           ENDDO
                0186
                0187         ENDIF
                0188
                0189       ELSEIF (useCubedSphereExchange) THEN
                0190 #else /* not USE_MPI */
                0191       IF     (useCubedSphereExchange) THEN
                0192 #endif /* ALLOW_USE_MPI */
                0193
                0194 C--   assume 1 tile / face, from bi=1 to 6, no MPI
                0195         shareBufCS1_R8(1,1) = 0.
                0196         bj = 1
                0197         DO bi = 1,nSx-1
                0198            nf = 1 + MOD(1+bi,2)
                0199            shareBufCS1_R8(1+bi,bj) = shareBufCS1_R8(bi,bj)
                0200      &                             + shareBufCS2_R8(nf,bi,bj)
                0201         ENDDO
                0202 C-    fill in missing corner: 1 = North-West corner of face 1
                0203 C-                            2 = South-East corner of face 2
                0204         bi = 1
                0205         psiLoc(1) = shareBufCS1_R8(bi,bj) + shareBufCS2_R8(2,bi,bj)
                0206         bi = MIN(2,nSx)
                0207         psiLoc(2) = shareBufCS1_R8(bi,bj) + shareBufCS2_R8(1,bi,bj)
                0208
                0209       ELSE
                0210
                0211 C--   Cumulate Sum over all tiles:
                0212         shareBufCS1_R8(1,1) = 0.
                0213         bj = 1
                0214         DO bi = 1,nSx-1
                0215            shareBufCS1_R8(1+bi,bj) = shareBufCS1_R8(bi,bj)
                0216      &                             + shareBufCS2_R8(1,bi,bj)
                0217         ENDDO
                0218         DO bj = 1,nSy-1
                0219          DO bi = 1,nSx
                0220            shareBufCS1_R8(bi,1+bj) = shareBufCS1_R8(bi,bj)
                0221      &                             + shareBufCS2_R8(2,bi,bj)
                0222          ENDDO
                0223         ENDDO
                0224
                0225       ENDIF
                0226
                0227       _END_MASTER( myThid )
                0228 C--   Everyone wait for Master thread to be ready
                0229       CALL BAR2( myThid )
                0230
                0231 C--   set result for every threads
                0232       DO bj = myByLo(myThid), myByHi(myThid)
                0233        DO bi = myBxLo(myThid), myBxHi(myThid)
                0234          psiZ(bi,bj) = shareBufCS1_R8(bi,bj)
                0235        ENDDO
                0236       ENDDO
                0237
                0238 #endif /* ALLOW_EXCH2 */
ca1d7a672f Jean*0239       RETURN
e5d1763db4 Jean*0240       END