eesupp/src/global_sum_tile.F

b043311a0b Jean*0001 #include "CPP_EEOPTIONS.h"
                0002
52aaad098a Jean*0003 C--   File global_sum_tile.F: Routines that perform global sum
                0004 C                             on a tile array
5237154b93 Jean*0005 C--    Contents
                0006 C--    o GLOBAL_SUM_TILE_RL
                0007 C--    o GLOBAL_SUM_TILE_RS <- not yet coded
52aaad098a Jean*0008
b043311a0b Jean*0009 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
52aaad098a Jean*0010 CBOP
                0011 C     !ROUTINE: GLOBAL_SUM_TILE_RL
                0012
                0013 C     !INTERFACE:
                0014       SUBROUTINE GLOBAL_SUM_TILE_RL(
                0015      I                       phiTile,
                0016      O                       sumPhi,
                0017      I                       myThid )
b043311a0b Jean*0018
52aaad098a Jean*0019 C     !DESCRIPTION:
                0020 C     *==========================================================*
                0021 C     | SUBROUTINE GLOBAL\_SUM\_TILE\_RL
                0022 C     | o Handle sum for _RL data.
                0023 C     *==========================================================*
                0024 C     | Apply sum on an array of one value per tile
                0025 C     |  and operate over all tiles & all the processes.
                0026 C     *==========================================================*
                0027
                0028 C     !USES:
b043311a0b Jean*0029       IMPLICIT NONE
                0030
52aaad098a Jean*0031 C     == Global data ==
                0032 #include "SIZE.h"
                0033 #include "EEPARAMS.h"
                0034 #include "EESUPPORT.h"
                0035 #include "GLOBAL_SUM.h"
                0036
                0037 C     !INPUT/OUTPUT PARAMETERS:
                0038 C     == Routine arguments ==
                0039 C     phiTile :: Input array with one value per tile
                0040 C     sumPhi  :: Result of sum.
                0041 C     myThid  :: My thread id.
                0042       _RL     phiTile(nSx,nSy)
                0043       _RL     sumPhi
                0044       INTEGER myThid
                0045
                0046 C     !LOCAL VARIABLES:
                0047 C     == Local variables ==
1071dbe8ca Jean*0048 C     bi,bj   :: Loop counters
                0049 C     mpiRC   :: MPI return code
52aaad098a Jean*0050 C- type declaration of: sumMyPr, sumAllP, localBuf and shareBufGSR8 :
                0051 C         all 4 needs to have the same length as MPI_DOUBLE_PRECISION
                0052       INTEGER bi,bj
                0053 #ifdef ALLOW_USE_MPI
                0054 #ifdef GLOBAL_SUM_SEND_RECV
1071dbe8ca Jean*0055       INTEGER biG, bjG, np, pId
52aaad098a Jean*0056       INTEGER lbuff, idest, itag, ready_to_receive
                0057       INTEGER istatus(MPI_STATUS_SIZE), ierr
                0058       Real*8  localBuf (nSx,nSy)
                0059       Real*8  globalBuf(nSx*nPx,nSy*nPy)
fe6019498a Jean*0060 #elif defined (GLOBAL_SUM_ORDER_TILES)
                0061       INTEGER biG, bjG, lbuff
                0062       Real*8  localBuf (nSx*nPx,nSy*nPy)
                0063       Real*8  globalBuf(nSx*nPx,nSy*nPy)
52aaad098a Jean*0064 #endif
1071dbe8ca Jean*0065       INTEGER mpiRC
52aaad098a Jean*0066 #endif /* ALLOW_USE_MPI */
1071dbe8ca Jean*0067       Real*8  sumMyPr
52aaad098a Jean*0068       Real*8  sumAllP
                0069 CEOP
                0070
f0eee60ee1 Jean*0071 C     this barrier is not necessary:
                0072 c     CALL BAR2( myThid )
52aaad098a Jean*0073
                0074 C--   write local sum into shared-buffer array
                0075       DO bj = myByLo(myThid), myByHi(myThid)
                0076        DO bi = myBxLo(myThid), myBxHi(myThid)
                0077          shareBufGSR8(bi,bj) = phiTile(bi,bj)
                0078        ENDDO
                0079       ENDDO
                0080
                0081 C--   Master thread cannot start until everyone is ready:
                0082       CALL BAR2( myThid )
                0083       _BEGIN_MASTER( myThid )
                0084
5237154b93 Jean*0085 #if (defined GLOBAL_SUM_SEND_RECV && defined ALLOW_USE_MPI )
1071dbe8ca Jean*0086       IF ( usingMPI ) THEN
52aaad098a Jean*0087
1071dbe8ca Jean*0088         lbuff = nSx*nSy
                0089         idest = 0
                0090         itag  = 0
                0091         ready_to_receive = 0
52aaad098a Jean*0092
1071dbe8ca Jean*0093         IF ( mpiMyId.NE.0 ) THEN
52aaad098a Jean*0094
                0095 C--   All proceses except 0 wait to be polled then send local array
                0096 #ifndef DISABLE_MPI_READY_TO_RECEIVE
                0097           CALL MPI_RECV (ready_to_receive, 1, MPI_INTEGER,
                0098      &         idest, itag, MPI_COMM_MODEL, istatus, ierr)
                0099 #endif
                0100           CALL MPI_SEND (shareBufGSR8, lbuff, MPI_DOUBLE_PRECISION,
                0101      &         idest, itag, MPI_COMM_MODEL, ierr)
                0102
                0103 C--   All proceses except 0 receive result from process 0
                0104           CALL MPI_RECV (sumAllP, 1, MPI_DOUBLE_PRECISION,
                0105      &         idest, itag, MPI_COMM_MODEL, istatus, ierr)
                0106
1071dbe8ca Jean*0107         ELSE
                0108 C-      case mpiMyId = 0
52aaad098a Jean*0109
                0110 C--   Process 0 fills-in its local data
1071dbe8ca Jean*0111          np = 1
                0112          DO bj=1,nSy
52aaad098a Jean*0113           DO bi=1,nSx
1071dbe8ca Jean*0114             biG = (mpi_myXGlobalLo(np)-1)/sNx+bi
                0115             bjG = (mpi_myYGlobalLo(np)-1)/sNy+bj
52aaad098a Jean*0116             globalBuf(biG,bjG) = shareBufGSR8(bi,bj)
                0117           ENDDO
1071dbe8ca Jean*0118          ENDDO
52aaad098a Jean*0119
                0120 C--   Process 0 polls and receives data from each process in turn
1071dbe8ca Jean*0121          DO np = 2, nPx*nPy
                0122           pId = np - 1
52aaad098a Jean*0123 #ifndef DISABLE_MPI_READY_TO_RECEIVE
                0124           CALL MPI_SEND (ready_to_receive, 1, MPI_INTEGER,
1071dbe8ca Jean*0125      &           pId, itag, MPI_COMM_MODEL, ierr)
52aaad098a Jean*0126 #endif
                0127           CALL MPI_RECV (localBuf, lbuff, MPI_DOUBLE_PRECISION,
1071dbe8ca Jean*0128      &           pId, itag, MPI_COMM_MODEL, istatus, ierr)
52aaad098a Jean*0129
                0130 C--   Process 0 gathers the local arrays into a global array.
                0131           DO bj=1,nSy
                0132            DO bi=1,nSx
1071dbe8ca Jean*0133              biG = (mpi_myXGlobalLo(np)-1)/sNx+bi
                0134              bjG = (mpi_myYGlobalLo(np)-1)/sNy+bj
                0135              globalBuf(biG,bjG) = localBuf(bi,bj)
52aaad098a Jean*0136            ENDDO
                0137           ENDDO
1071dbe8ca Jean*0138 C-       end loop on np
                0139          ENDDO
52aaad098a Jean*0140
                0141 C--   Sum over all tiles:
1071dbe8ca Jean*0142          sumAllP = 0.
                0143          DO bjG = 1,nSy*nPy
                0144           DO biG = 1,nSx*nPx
52aaad098a Jean*0145            sumAllP = sumAllP + globalBuf(biG,bjG)
1071dbe8ca Jean*0146           ENDDO
52aaad098a Jean*0147          ENDDO
                0148
                0149 C--   Process 0 sends result to all other processes
1071dbe8ca Jean*0150          lbuff = 1
                0151          DO np = 2, nPx*nPy
                0152           pId = np - 1
52aaad098a Jean*0153           CALL MPI_SEND (sumAllP, 1, MPI_DOUBLE_PRECISION,
1071dbe8ca Jean*0154      &                   pId, itag, MPI_COMM_MODEL, ierr)
                0155          ENDDO
52aaad098a Jean*0156
1071dbe8ca Jean*0157 C       End if/else mpiMyId = 0
                0158         ENDIF
52aaad098a Jean*0159
1071dbe8ca Jean*0160       ELSE
5237154b93 Jean*0161 #elif (defined GLOBAL_SUM_ORDER_TILES && defined ALLOW_USE_MPI )
fe6019498a Jean*0162       IF ( usingMPI ) THEN
                0163
                0164 C--   Initialise local buffer
                0165         DO bjG=1,nSy*nPy
                0166          DO biG=1,nSx*nPx
                0167            localBuf(biG,bjG) = 0.
                0168          ENDDO
                0169         ENDDO
                0170
                0171 C--   Put my own data in local buffer
                0172         DO bj=1,nSy
                0173          DO bi=1,nSx
                0174            biG = (myXGlobalLo-1)/sNx+bi
                0175            bjG = (myYGlobalLo-1)/sNy+bj
                0176            localBuf(biG,bjG) = shareBufGSR8(bi,bj)
                0177          ENDDO
                0178         ENDDO
                0179
                0180 C--   Collect data from all procs
                0181         lbuff = nSx*nPx*nSy*nPy
                0182         CALL MPI_Allreduce( localBuf, globalBuf, lbuff,
                0183      &           MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_MODEL, mpiRC )
                0184
                0185 C--   Sum over all tiles:
                0186          sumAllP = 0.
                0187          DO bjG = 1,nSy*nPy
                0188           DO biG = 1,nSx*nPx
                0189            sumAllP = sumAllP + globalBuf(biG,bjG)
                0190           ENDDO
                0191          ENDDO
                0192
                0193       ELSE
                0194 #else /* not ((GLOBAL_SUM_SEND_RECV | GLOBAL_SUM_ORDER_TILES) & ALLOW_USE_MPI) */
1071dbe8ca Jean*0195       IF ( .TRUE. ) THEN
fe6019498a Jean*0196 #endif /* not ((GLOBAL_SUM_SEND_RECV | GLOBAL_SUM_ORDER_TILES) & ALLOW_USE_MPI) */
52aaad098a Jean*0197
                0198 C--   Sum over all tiles (of the same process) first
1071dbe8ca Jean*0199         sumMyPr = 0.
                0200         DO bj = 1,nSy
                0201          DO bi = 1,nSx
52aaad098a Jean*0202           sumMyPr = sumMyPr + shareBufGSR8(bi,bj)
1071dbe8ca Jean*0203          ENDDO
52aaad098a Jean*0204         ENDDO
                0205
fe6019498a Jean*0206 C     in case MPI is not used:
1071dbe8ca Jean*0207         sumAllP = sumMyPr
52aaad098a Jean*0208
                0209 #ifdef ALLOW_USE_MPI
1071dbe8ca Jean*0210         IF ( usingMPI ) THEN
                0211          CALL MPI_Allreduce(sumMyPr,sumAllP,1,MPI_DOUBLE_PRECISION,
                0212      &                      MPI_SUM,MPI_COMM_MODEL,mpiRC)
                0213         ENDIF
52aaad098a Jean*0214 #endif /* ALLOW_USE_MPI */
                0215
1071dbe8ca Jean*0216       ENDIF
52aaad098a Jean*0217
fe6019498a Jean*0218 C--   Write solution to shared buffer (all threads can see it)
1071dbe8ca Jean*0219 c     shareBufGSR8(1,1) = sumAllP
                0220       phiGSR8(1,0) = sumAllP
52aaad098a Jean*0221
                0222       _END_MASTER( myThid )
                0223 C--   Everyone wait for Master thread to be ready
                0224       CALL BAR2( myThid )
                0225
                0226 C--   set result for every threads
b043311a0b Jean*0227 c     sumPhi = shareBufGSR8(1,1)
                0228       sumPhi = phiGSR8(1,0)
52aaad098a Jean*0229
b043311a0b Jean*0230 C--   A barrier was needed here to prevent thread 1 to modify shareBufGSR8(1,1)
f0eee60ee1 Jean*0231 C     (as it would in the following call to this S/R) before all threads get
                0232 C     their global-sum result out.
b043311a0b Jean*0233 C     No longer needed since a dedicated shared var. is used to share the output
                0234 c     CALL BAR2( myThid )
52aaad098a Jean*0235
                0236       RETURN
                0237       END