eesupp/src/gather_2d_rx.template

C $Header: /u/gcmpack/MITgcm/eesupp/src/gather_2d_rx.template,v 1.5 2009/06/08 03:34:03 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     Note: done by Master-Thread ; might need barrier calls before and after
C           this S/R call.

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 */

      _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

          DO bj=1,nSy
           DO bi=1,nSx
             tN = W2_myTileList(bi,bj)
             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
          ENDDO

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

          iBase = myXGlobalLo-1
          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

          DO bj=1,nSy
           DO bi=1,nSx
             tN = W2_procTileList(bi,bj,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
          ENDDO

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

          iBase = mpi_myXGlobalLo(np)-1
          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 )

      RETURN
      END
1	jmc	1.6	C $Header: /u/gcmpack/MITgcm/eesupp/src/gather_2d_rx.template,v 1.5 2009/06/08 03:34:03 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	jmc	1.5	C Note: done by Master-Thread ; might need barrier calls before and after
20			C this S/R call.
21	jmc	1.1
22			C !USES:
23			IMPLICIT NONE
24			#include "SIZE.h"
25			#include "EEPARAMS.h"
26			#include "EESUPPORT.h"
27			#ifdef ALLOW_EXCH2
28	jmc	1.2	#include "W2_EXCH2_SIZE.h"
29	jmc	1.1	#include "W2_EXCH2_TOPOLOGY.h"
30			#endif /* ALLOW_EXCH2 */
31
32			C !INPUT/OUTPUT PARAMETERS:
33			C gloBuff ( _RX ) :: full-domain 2D IO-buffer array (Output)
34			C myField ( _RX ) :: tiled, local (i.e. my Proc. tiles) 2D array (Input)
35			C xSize (integer):: global buffer 1rst dim (x)
36			C ySize (integer):: global buffer 2nd dim (y)
37	jmc	1.3	C useExch2GlobLayOut:: =T: Use Exch2 global-map layout (only with EXCH2)
38	jmc	1.1	C zeroBuff (logical):: =T: initialise the buffer to zero before copy
39			C myThid (integer):: my Thread Id number
40
41			INTEGER xSize, ySize
42			_RX gloBuff(xSize,ySize)
43			_RX myField(1:sNx,1:sNy,nSx,nSy)
44	jmc	1.3	LOGICAL useExch2GlobLayOut
45	jmc	1.1	LOGICAL zeroBuff
46			INTEGER myThid
47			CEOP
48
49			C !LOCAL VARIABLES:
50			INTEGER i,j, bi,bj
51			INTEGER iG, jG
52			INTEGER iBase, jBase
53			#ifdef ALLOW_EXCH2
54			INTEGER iGjLoc, jGjLoc
55			INTEGER tN
56			#endif /* ALLOW_EXCH2 */
57			#ifdef ALLOW_USE_MPI
58			INTEGER np0, np
59			_RX temp(1:sNx,1:sNy,nSx,nSy)
60			INTEGER istatus(MPI_STATUS_SIZE), ierr
61			INTEGER lbuff, idest, itag, ready_to_receive
62			#endif /* ALLOW_USE_MPI */
63
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	jmc	1.6	DO bj=1,nSy
82	jmc	1.1	DO bi=1,nSx
83	jmc	1.6	tN = W2_myTileList(bi,bj)
84	jmc	1.1	IF ( exch2_mydNx(tN) .GT. xSize ) THEN
85			C- face x-size larger than glob-size : fold it
86			iGjLoc = 0
87			jGjLoc = exch2_mydNx(tN) / xSize
88			ELSEIF ( exch2_tNy(tN) .GT. ySize ) THEN
89			C- tile y-size larger than glob-size : make a long line
90			iGjLoc = exch2_mydNx(tN)
91			jGjLoc = 0
92			ELSE
93			C- default (face fit into global-IO-array)
94			iGjLoc = 0
95			jGjLoc = 1
96			ENDIF
97
98			DO j=1,sNy
99			#ifdef TARGET_NEC_SX
100			!cdir novector
101			#endif
102			iG=exch2_txGlobalo(tN)+iGjLoc*(j-1)-1
103			jG=exch2_tyGlobalo(tN)+jGjLoc*(j-1)
104			DO i=1,sNx
105			gloBuff(iG+i,jG) = myField(i,j,bi,bj)
106			ENDDO
107			ENDDO
108
109			ENDDO
110	jmc	1.6	ENDDO
111	jmc	1.1
112			ELSE
113			#else /* ALLOW_EXCH2 */
114			IF (.TRUE.) THEN
115			#endif /* ALLOW_EXCH2 */
116
117	jmc	1.4	iBase = myXGlobalLo-1
118			jBase = myYGlobalLo-1
119	jmc	1.1
120			DO bj=1,nSy
121			DO bi=1,nSx
122			DO j=1,sNy
123			#ifdef TARGET_NEC_SX
124			!cdir novector
125			#endif
126			iG = iBase+(bi-1)*sNx
127			jG = jBase+(bj-1)*sNy+j
128			DO i=1,sNx
129			gloBuff(iG+i,jG) = myField(i,j,bi,bj)
130			ENDDO
131			ENDDO
132			ENDDO
133			ENDDO
134
135	jmc	1.3	C end if-else useExch2GlobLayOut
136	jmc	1.1	ENDIF
137
138			C- end if myProcId = 0
139			ENDIF
140
141			#ifdef ALLOW_USE_MPI
142
143			lbuff = sNxnSxsNy*nSy
144			idest = 0
145			itag = 0
146			ready_to_receive = 0
147
148			IF( mpiMyId .EQ. 0 ) THEN
149
150			C-- Process 0 polls and receives data from each process in turn
151			DO np = 2, numberOfProcs
152			np0 = np - 1
153			#ifndef DISABLE_MPI_READY_TO_RECEIVE
154			CALL MPI_SEND (ready_to_receive, 1, MPI_INTEGER,
155			& np0, itag, MPI_COMM_MODEL, ierr)
156			#endif
157			CALL MPI_RECV (temp, lbuff, _MPI_TYPE_RX,
158			& np0, itag, MPI_COMM_MODEL, istatus, ierr)
159
160			C-- Process 0 gathers the local arrays into the global buffer.
161			#ifdef ALLOW_EXCH2
162	jmc	1.3	IF ( useExch2GlobLayOut ) THEN
163	jmc	1.1
164	jmc	1.6	DO bj=1,nSy
165	jmc	1.1	DO bi=1,nSx
166	jmc	1.6	tN = W2_procTileList(bi,bj,np)
167	jmc	1.1	IF ( exch2_mydNx(tN) .GT. xSize ) THEN
168			C- face x-size larger than glob-size : fold it
169			iGjLoc = 0
170			jGjLoc = exch2_mydNx(tN) / xSize
171			ELSEIF ( exch2_tNy(tN) .GT. ySize ) THEN
172			C- tile y-size larger than glob-size : make a long line
173			iGjLoc = exch2_mydNx(tN)
174			jGjLoc = 0
175			ELSE
176			C- default (face fit into global-IO-array)
177			iGjLoc = 0
178			jGjLoc = 1
179			ENDIF
180
181			DO j=1,sNy
182			#ifdef TARGET_NEC_SX
183			!cdir novector
184			#endif
185			iG=exch2_txGlobalo(tN)+iGjLoc*(j-1)-1
186			jG=exch2_tyGlobalo(tN)+jGjLoc*(j-1)
187			DO i=1,sNx
188			gloBuff(iG+i,jG) = temp(i,j,bi,bj)
189			ENDDO
190			ENDDO
191
192			ENDDO
193	jmc	1.6	ENDDO
194	jmc	1.1
195			ELSE
196			#else /* ALLOW_EXCH2 */
197			IF (.TRUE.) THEN
198			#endif /* ALLOW_EXCH2 */
199
200	jmc	1.4	iBase = mpi_myXGlobalLo(np)-1
201			jBase = mpi_myYGlobalLo(np)-1
202	jmc	1.1
203			DO bj=1,nSy
204			DO bi=1,nSx
205			DO j=1,sNy
206			#ifdef TARGET_NEC_SX
207			!cdir novector
208			#endif
209			iG = iBase+(bi-1)*sNx
210			jG = jBase+(bj-1)*sNy+j
211			DO i=1,sNx
212			gloBuff(iG+i,jG) = temp(i,j,bi,bj)
213			ENDDO
214			ENDDO
215			ENDDO
216			ENDDO
217
218	jmc	1.3	C end if-else useExch2GlobLayOut
219	jmc	1.1	ENDIF
220
221			C- end loop on np
222			ENDDO
223
224			ELSE
225
226			C-- All proceses except 0 wait to be polled then send local array
227			#ifndef DISABLE_MPI_READY_TO_RECEIVE
228			CALL MPI_RECV (ready_to_receive, 1, MPI_INTEGER,
229			& idest, itag, MPI_COMM_MODEL, istatus, ierr)
230			#endif
231			CALL MPI_SEND (myField, lbuff, _MPI_TYPE_RX,
232			& idest, itag, MPI_COMM_MODEL, ierr)
233
234			ENDIF
235
236			#endif /* ALLOW_USE_MPI */
237
238			_END_MASTER( myThid )
239
240			RETURN
241			END