eesupp/src/gather_2d_rx.template

C $Header: /u/gcmpack/MITgcm/eesupp/src/gather_2d_rx.template,v 1.2 2009/05/12 19:53:02 jmc Exp $
C $Name:  $

#include "PACKAGES_CONFIG.h"
#include "CPP_EEOPTIONS.h"

CBOP
C !ROUTINE: GATHER_2D_RX
C !INTERFACE:
      SUBROUTINE GATHER_2D_RX(
     O                  gloBuff,
     I                  myField,
     I                  xSize, ySize,
     I                  useExch2GlobLayOut,
     I                  zeroBuff,
     I                  myThid )
C !DESCRIPTION:
C     Gather elements of a global 2-D array from all mpi processes to process 0.

C     !USES:
      IMPLICIT NONE
#include "SIZE.h"
#include "EEPARAMS.h"
#include "EESUPPORT.h"
#ifdef ALLOW_EXCH2
#include "W2_EXCH2_SIZE.h"
#include "W2_EXCH2_TOPOLOGY.h"
#endif /* ALLOW_EXCH2 */

C     !INPUT/OUTPUT PARAMETERS:
C gloBuff   ( _RX ) :: full-domain 2D IO-buffer array             (Output)
C myField   ( _RX ) :: tiled, local (i.e. my Proc. tiles) 2D array (Input)
C xSize    (integer):: global buffer 1rst dim (x)
C ySize    (integer):: global buffer 2nd  dim (y)
C useExch2GlobLayOut:: =T: Use Exch2 global-map layout (only with EXCH2)
C zeroBuff (logical):: =T: initialise the buffer to zero before copy
C myThid   (integer):: my Thread Id number

      INTEGER xSize, ySize
      _RX     gloBuff(xSize,ySize)
      _RX     myField(1:sNx,1:sNy,nSx,nSy)
      LOGICAL useExch2GlobLayOut
      LOGICAL zeroBuff
      INTEGER myThid
CEOP

C !LOCAL VARIABLES:
      INTEGER i,j, bi,bj
      INTEGER iG, jG
      INTEGER iBase, jBase
#ifdef ALLOW_EXCH2
      INTEGER iGjLoc, jGjLoc
      INTEGER tN
#endif /* ALLOW_EXCH2 */
#ifdef ALLOW_USE_MPI
      INTEGER np0, np
      _RX     temp(1:sNx,1:sNy,nSx,nSy)
      INTEGER istatus(MPI_STATUS_SIZE), ierr
      INTEGER lbuff, idest, itag, ready_to_receive
#endif /* ALLOW_USE_MPI */

C--   Make everyone wait except for master thread.
      _BARRIER
      _BEGIN_MASTER( myThid )

      IF( myProcId .EQ. 0 ) THEN
C--   Process 0 fills-in its local data

#ifdef ALLOW_EXCH2
        IF ( useExch2GlobLayOut ) THEN
C--   If using blank-tiles, buffer will not be completely filled;
C     safer to reset to zero to avoid unknown values in output file
          IF ( zeroBuff ) THEN
            DO j=1,ySize
             DO i=1,xSize
               gloBuff(i,j) = 0.
             ENDDO
            ENDDO
          ENDIF

c         DO bj=1,nSy
          bj=1
           DO bi=1,nSx
             tN = W2_myTileList(bi)
             IF   ( exch2_mydNx(tN) .GT. xSize ) THEN
C-           face x-size larger than glob-size : fold it
               iGjLoc = 0
               jGjLoc = exch2_mydNx(tN) / xSize
             ELSEIF ( exch2_tNy(tN) .GT. ySize ) THEN
C-           tile y-size larger than glob-size : make a long line
               iGjLoc = exch2_mydNx(tN)
               jGjLoc = 0
             ELSE
C-           default (face fit into global-IO-array)
               iGjLoc = 0
               jGjLoc = 1
             ENDIF

             DO j=1,sNy
#ifdef TARGET_NEC_SX
!cdir novector
#endif
              iG=exch2_txGlobalo(tN)+iGjLoc*(j-1)-1
              jG=exch2_tyGlobalo(tN)+jGjLoc*(j-1)
              DO i=1,sNx
                gloBuff(iG+i,jG) = myField(i,j,bi,bj)
              ENDDO
             ENDDO

           ENDDO
c         ENDDO

        ELSE
#else /* ALLOW_EXCH2 */
        IF (.TRUE.) THEN
#endif /* ALLOW_EXCH2 */

          iBase = 0
          jBase = 0
c         iBase = myXGlobalLo-1
c         jBase = myYGlobalLo-1

          DO bj=1,nSy
           DO bi=1,nSx
             DO j=1,sNy
#ifdef TARGET_NEC_SX
!cdir novector
#endif
              iG = iBase+(bi-1)*sNx
              jG = jBase+(bj-1)*sNy+j
              DO i=1,sNx
                gloBuff(iG+i,jG) = myField(i,j,bi,bj)
              ENDDO
             ENDDO
           ENDDO
          ENDDO

C       end if-else useExch2GlobLayOut
        ENDIF

C-    end if myProcId = 0
      ENDIF

#ifdef ALLOW_USE_MPI

      lbuff = sNx*nSx*sNy*nSy
      idest = 0
      itag  = 0
      ready_to_receive = 0

      IF( mpiMyId .EQ. 0 ) THEN

C--   Process 0 polls and receives data from each process in turn
        DO np = 2, numberOfProcs
         np0 = np - 1
#ifndef DISABLE_MPI_READY_TO_RECEIVE
         CALL MPI_SEND (ready_to_receive, 1, MPI_INTEGER,
     &           np0, itag, MPI_COMM_MODEL, ierr)
#endif
         CALL MPI_RECV (temp, lbuff, _MPI_TYPE_RX,
     &           np0, itag, MPI_COMM_MODEL, istatus, ierr)

C--   Process 0 gathers the local arrays into the global buffer.
#ifdef ALLOW_EXCH2
         IF ( useExch2GlobLayOut ) THEN

c         DO bj=1,nSy
          bj=1
           DO bi=1,nSx
             tN = W2_procTileList(bi,np)
             IF   ( exch2_mydNx(tN) .GT. xSize ) THEN
C-           face x-size larger than glob-size : fold it
               iGjLoc = 0
               jGjLoc = exch2_mydNx(tN) / xSize
             ELSEIF ( exch2_tNy(tN) .GT. ySize ) THEN
C-           tile y-size larger than glob-size : make a long line
               iGjLoc = exch2_mydNx(tN)
               jGjLoc = 0
             ELSE
C-           default (face fit into global-IO-array)
               iGjLoc = 0
               jGjLoc = 1
             ENDIF

             DO j=1,sNy
#ifdef TARGET_NEC_SX
!cdir novector
#endif
              iG=exch2_txGlobalo(tN)+iGjLoc*(j-1)-1
              jG=exch2_tyGlobalo(tN)+jGjLoc*(j-1)
              DO i=1,sNx
                gloBuff(iG+i,jG) = temp(i,j,bi,bj)
              ENDDO
             ENDDO

           ENDDO
c         ENDDO

         ELSE
#else /* ALLOW_EXCH2 */
         IF (.TRUE.) THEN
#endif /* ALLOW_EXCH2 */

          iBase = MOD(np0,nPx)
          jBase = np0/nPx
          iBase = iBase*nSx*sNx
          jBase = jBase*nSy*sNy
c         iBase = mpi_myXGlobalLo(np)-1
c         jBase = mpi_myYGlobalLo(np)-1

          DO bj=1,nSy
           DO bi=1,nSx
             DO j=1,sNy
#ifdef TARGET_NEC_SX
!cdir novector
#endif
              iG = iBase+(bi-1)*sNx
              jG = jBase+(bj-1)*sNy+j
              DO i=1,sNx
                gloBuff(iG+i,jG) = temp(i,j,bi,bj)
              ENDDO
             ENDDO
           ENDDO
          ENDDO

C        end if-else useExch2GlobLayOut
         ENDIF

C-      end loop on np
        ENDDO

      ELSE

C--   All proceses except 0 wait to be polled then send local array
#ifndef DISABLE_MPI_READY_TO_RECEIVE
         CALL MPI_RECV (ready_to_receive, 1, MPI_INTEGER,
     &        idest, itag, MPI_COMM_MODEL, istatus, ierr)
#endif
         CALL MPI_SEND (myField, lbuff, _MPI_TYPE_RX,
     &        idest, itag, MPI_COMM_MODEL, ierr)

      ENDIF

#endif /* ALLOW_USE_MPI */

      _END_MASTER( myThid )
      _BARRIER

      RETURN
      END
1	jmc	1.3	C $Header: /u/gcmpack/MITgcm/eesupp/src/gather_2d_rx.template,v 1.2 2009/05/12 19:53:02 jmc Exp $
2	jmc	1.1	C $Name: $
3
4			#include "PACKAGES_CONFIG.h"
5			#include "CPP_EEOPTIONS.h"
6
7			CBOP
8			C !ROUTINE: GATHER_2D_RX
9			C !INTERFACE:
10			SUBROUTINE GATHER_2D_RX(
11			O gloBuff,
12			I myField,
13			I xSize, ySize,
14	jmc	1.3	I useExch2GlobLayOut,
15	jmc	1.1	I zeroBuff,
16			I myThid )
17			C !DESCRIPTION:
18			C Gather elements of a global 2-D array from all mpi processes to process 0.
19
20			C !USES:
21			IMPLICIT NONE
22			#include "SIZE.h"
23			#include "EEPARAMS.h"
24			#include "EESUPPORT.h"
25			#ifdef ALLOW_EXCH2
26	jmc	1.2	#include "W2_EXCH2_SIZE.h"
27	jmc	1.1	#include "W2_EXCH2_TOPOLOGY.h"
28			#endif /* ALLOW_EXCH2 */
29
30			C !INPUT/OUTPUT PARAMETERS:
31			C gloBuff ( _RX ) :: full-domain 2D IO-buffer array (Output)
32			C myField ( _RX ) :: tiled, local (i.e. my Proc. tiles) 2D array (Input)
33			C xSize (integer):: global buffer 1rst dim (x)
34			C ySize (integer):: global buffer 2nd dim (y)
35	jmc	1.3	C useExch2GlobLayOut:: =T: Use Exch2 global-map layout (only with EXCH2)
36	jmc	1.1	C zeroBuff (logical):: =T: initialise the buffer to zero before copy
37			C myThid (integer):: my Thread Id number
38
39			INTEGER xSize, ySize
40			_RX gloBuff(xSize,ySize)
41			_RX myField(1:sNx,1:sNy,nSx,nSy)
42	jmc	1.3	LOGICAL useExch2GlobLayOut
43	jmc	1.1	LOGICAL zeroBuff
44			INTEGER myThid
45			CEOP
46
47			C !LOCAL VARIABLES:
48			INTEGER i,j, bi,bj
49			INTEGER iG, jG
50			INTEGER iBase, jBase
51			#ifdef ALLOW_EXCH2
52			INTEGER iGjLoc, jGjLoc
53			INTEGER tN
54			#endif /* ALLOW_EXCH2 */
55			#ifdef ALLOW_USE_MPI
56			INTEGER np0, np
57			_RX temp(1:sNx,1:sNy,nSx,nSy)
58			INTEGER istatus(MPI_STATUS_SIZE), ierr
59			INTEGER lbuff, idest, itag, ready_to_receive
60			#endif /* ALLOW_USE_MPI */
61
62			C-- Make everyone wait except for master thread.
63			_BARRIER
64			_BEGIN_MASTER( myThid )
65
66			IF( myProcId .EQ. 0 ) THEN
67			C-- Process 0 fills-in its local data
68
69			#ifdef ALLOW_EXCH2
70	jmc	1.3	IF ( useExch2GlobLayOut ) THEN
71	jmc	1.1	C-- If using blank-tiles, buffer will not be completely filled;
72			C safer to reset to zero to avoid unknown values in output file
73			IF ( zeroBuff ) THEN
74			DO j=1,ySize
75			DO i=1,xSize
76			gloBuff(i,j) = 0.
77			ENDDO
78			ENDDO
79			ENDIF
80
81			c DO bj=1,nSy
82			bj=1
83			DO bi=1,nSx
84			tN = W2_myTileList(bi)
85			IF ( exch2_mydNx(tN) .GT. xSize ) THEN
86			C- face x-size larger than glob-size : fold it
87			iGjLoc = 0
88			jGjLoc = exch2_mydNx(tN) / xSize
89			ELSEIF ( exch2_tNy(tN) .GT. ySize ) THEN
90			C- tile y-size larger than glob-size : make a long line
91			iGjLoc = exch2_mydNx(tN)
92			jGjLoc = 0
93			ELSE
94			C- default (face fit into global-IO-array)
95			iGjLoc = 0
96			jGjLoc = 1
97			ENDIF
98
99			DO j=1,sNy
100			#ifdef TARGET_NEC_SX
101			!cdir novector
102			#endif
103			iG=exch2_txGlobalo(tN)+iGjLoc*(j-1)-1
104			jG=exch2_tyGlobalo(tN)+jGjLoc*(j-1)
105			DO i=1,sNx
106			gloBuff(iG+i,jG) = myField(i,j,bi,bj)
107			ENDDO
108			ENDDO
109
110			ENDDO
111			c ENDDO
112
113			ELSE
114			#else /* ALLOW_EXCH2 */
115			IF (.TRUE.) THEN
116			#endif /* ALLOW_EXCH2 */
117
118			iBase = 0
119			jBase = 0
120			c iBase = myXGlobalLo-1
121			c jBase = myYGlobalLo-1
122
123			DO bj=1,nSy
124			DO bi=1,nSx
125			DO j=1,sNy
126			#ifdef TARGET_NEC_SX
127			!cdir novector
128			#endif
129			iG = iBase+(bi-1)*sNx
130			jG = jBase+(bj-1)*sNy+j
131			DO i=1,sNx
132			gloBuff(iG+i,jG) = myField(i,j,bi,bj)
133			ENDDO
134			ENDDO
135			ENDDO
136			ENDDO
137
138	jmc	1.3	C end if-else useExch2GlobLayOut
139	jmc	1.1	ENDIF
140
141			C- end if myProcId = 0
142			ENDIF
143
144			#ifdef ALLOW_USE_MPI
145
146			lbuff = sNxnSxsNy*nSy
147			idest = 0
148			itag = 0
149			ready_to_receive = 0
150
151			IF( mpiMyId .EQ. 0 ) THEN
152
153			C-- Process 0 polls and receives data from each process in turn
154			DO np = 2, numberOfProcs
155			np0 = np - 1
156			#ifndef DISABLE_MPI_READY_TO_RECEIVE
157			CALL MPI_SEND (ready_to_receive, 1, MPI_INTEGER,
158			& np0, itag, MPI_COMM_MODEL, ierr)
159			#endif
160			CALL MPI_RECV (temp, lbuff, _MPI_TYPE_RX,
161			& np0, itag, MPI_COMM_MODEL, istatus, ierr)
162
163			C-- Process 0 gathers the local arrays into the global buffer.
164			#ifdef ALLOW_EXCH2
165	jmc	1.3	IF ( useExch2GlobLayOut ) THEN
166	jmc	1.1
167			c DO bj=1,nSy
168			bj=1
169			DO bi=1,nSx
170	jmc	1.2	tN = W2_procTileList(bi,np)
171	jmc	1.1	IF ( exch2_mydNx(tN) .GT. xSize ) THEN
172			C- face x-size larger than glob-size : fold it
173			iGjLoc = 0
174			jGjLoc = exch2_mydNx(tN) / xSize
175			ELSEIF ( exch2_tNy(tN) .GT. ySize ) THEN
176			C- tile y-size larger than glob-size : make a long line
177			iGjLoc = exch2_mydNx(tN)
178			jGjLoc = 0
179			ELSE
180			C- default (face fit into global-IO-array)
181			iGjLoc = 0
182			jGjLoc = 1
183			ENDIF
184
185			DO j=1,sNy
186			#ifdef TARGET_NEC_SX
187			!cdir novector
188			#endif
189			iG=exch2_txGlobalo(tN)+iGjLoc*(j-1)-1
190			jG=exch2_tyGlobalo(tN)+jGjLoc*(j-1)
191			DO i=1,sNx
192			gloBuff(iG+i,jG) = temp(i,j,bi,bj)
193			ENDDO
194			ENDDO
195
196			ENDDO
197			c ENDDO
198
199			ELSE
200			#else /* ALLOW_EXCH2 */
201			IF (.TRUE.) THEN
202			#endif /* ALLOW_EXCH2 */
203
204			iBase = MOD(np0,nPx)
205			jBase = np0/nPx
206			iBase = iBasenSxsNx
207			jBase = jBasenSysNy
208			c iBase = mpi_myXGlobalLo(np)-1
209			c jBase = mpi_myYGlobalLo(np)-1
210
211			DO bj=1,nSy
212			DO bi=1,nSx
213			DO j=1,sNy
214			#ifdef TARGET_NEC_SX
215			!cdir novector
216			#endif
217			iG = iBase+(bi-1)*sNx
218			jG = jBase+(bj-1)*sNy+j
219			DO i=1,sNx
220			gloBuff(iG+i,jG) = temp(i,j,bi,bj)
221			ENDDO
222			ENDDO
223			ENDDO
224			ENDDO
225
226	jmc	1.3	C end if-else useExch2GlobLayOut
227	jmc	1.1	ENDIF
228
229			C- end loop on np
230			ENDDO
231
232			ELSE
233
234			C-- All proceses except 0 wait to be polled then send local array
235			#ifndef DISABLE_MPI_READY_TO_RECEIVE
236			CALL MPI_RECV (ready_to_receive, 1, MPI_INTEGER,
237			& idest, itag, MPI_COMM_MODEL, istatus, ierr)
238			#endif
239			CALL MPI_SEND (myField, lbuff, _MPI_TYPE_RX,
240			& idest, itag, MPI_COMM_MODEL, ierr)
241
242			ENDIF
243
244			#endif /* ALLOW_USE_MPI */
245
246			_END_MASTER( myThid )
247			_BARRIER
248
249			RETURN
250			END