source: NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/LBC/mpp_bdy_generic.h90 @ 11067

Last change on this file since 11067 was 11067, checked in by girrmann, 20 months ago

dev_r10984_HPC-13 : new implementation of lbc_bdy_lnk in prevision of step 2, regroup communications, see #2285

  • Property svn:keywords set to Id
  • Property svn:mime-type set to text/x-fortran
File size: 12.6 KB
Line 
1#if defined MULTI
2#   define NAT_IN(k)                cd_nat(k)   
3#   define SGN_IN(k)                psgn(k)
4#   define F_SIZE(ptab)             kfld
5#   define OPT_K(k)                 ,ipf
6#   if defined DIM_2d
7#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D)                , INTENT(inout) ::   ptab(f)
8#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j)
9#      define K_SIZE(ptab)             1
10#      define L_SIZE(ptab)             1
11#   endif
12#   if defined DIM_3d
13#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D)                , INTENT(inout) ::   ptab(f)
14#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k)
15#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3)
16#      define L_SIZE(ptab)             1
17#   endif
18#   if defined DIM_4d
19#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D)                , INTENT(inout) ::   ptab(f)
20#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l)
21#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3)
22#      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4)
23#   endif
24#else
25#   define ARRAY_TYPE(i,j,k,l,f)    REAL(wp)                    , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f)
26#   define NAT_IN(k)                cd_nat
27#   define SGN_IN(k)                psgn
28#   define F_SIZE(ptab)             1
29#   define OPT_K(k)                 
30#   if defined DIM_2d
31#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j)
32#      define K_SIZE(ptab)          1
33#      define L_SIZE(ptab)          1
34#   endif
35#   if defined DIM_3d
36#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k)
37#      define K_SIZE(ptab)          SIZE(ptab,3)
38#      define L_SIZE(ptab)          1
39#   endif
40#   if defined DIM_4d
41#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k,l)
42#      define K_SIZE(ptab)          SIZE(ptab,3)
43#      define L_SIZE(ptab)          SIZE(ptab,4)
44#   endif
45#endif
46      !!----------------------------------------------------------------------
47      !!                  ***  routine mpp_lnk_bdy  ***
48      !!
49      !! ** Purpose :   Message passing management
50      !!
51      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries
52      !!      between processors following neighboring subdomains.
53      !!            domain parameters
54      !!                    nlci   : first dimension of the local subdomain
55      !!                    nlcj   : second dimension of the local subdomain
56      !!                    noea   : number for local neighboring processors
57      !!                    nowe   : number for local neighboring processors
58      !!                    noso   : number for local neighboring processors
59      !!                    nono   : number for local neighboring processors
60      !!
61      !! ** Action  :   ptab with update value at its periphery
62      !!
63      !!----------------------------------------------------------------------
64#if defined MULTI
65   SUBROUTINE ROUTINE_BDY( cdname, lsend, lrecv, ptab, cd_nat, psgn, kfld )
66      INTEGER                     , INTENT(in   ) ::   kfld        ! number of pt3d arrays
67#else
68   SUBROUTINE ROUTINE_BDY( cdname, lsend, lrecv, ptab, cd_nat, psgn       )
69#endif
70      CHARACTER(len=*)            , INTENT(in   ) ::   cdname        ! name of the calling subroutine
71      ARRAY_TYPE(:,:,:,:,:)   ! array or pointer of arrays on which the boundary condition is applied
72      CHARACTER(len=1)            , INTENT(in   ) ::   NAT_IN(:)     ! nature of array grid-points
73      REAL(wp)                    , INTENT(in   ) ::   SGN_IN(:)     ! sign used across the north fold boundary
74      LOGICAL, DIMENSION(4)       , INTENT(in   ) ::   lsend, lrecv  ! communication with other 4 proc
75      !
76      INTEGER  ::   ji, jj, jk, jl, jh, jf     ! dummy loop indices
77      INTEGER  ::   ipk, ipl, ipf              ! 3dimension of the input array
78      INTEGER  ::   imigr, iihom, ijhom        ! local integers
79      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
80      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
81      LOGICAL  ::   llsend_we, llsend_ea, llsend_no, llsend_so       ! communication send
82      LOGICAL  ::   llrecv_we, llrecv_ea, llrecv_no, llrecv_so       ! communication receive
83      !
84      REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zsend_no, zsend_so   ! 3d for north-south & south-north send
85      REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zsend_ea, zsend_we   ! 3d for east-west   & west-east   send
86      REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zrecv_no, zrecv_so   ! 3d for north-south & south-north receive
87      REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zrecv_ea, zrecv_we   ! 3d for east-west   & west-east   receive
88      !!----------------------------------------------------------------------
89      !
90      ipk = K_SIZE(ptab)   ! 3rd dimension
91      ipl = L_SIZE(ptab)   ! 4th    -
92      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers)
93      llsend_we = lsend(1);  llsend_ea = lsend(2);  llsend_so = lsend(3);  llsend_no = lsend(4);
94      llrecv_we = lrecv(1);  llrecv_ea = lrecv(2);  llrecv_so = lrecv(3);  llrecv_no = lrecv(4);
95      !
96      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. )
97
98
99      ! 1. standard boundary treatment
100      ! ------------------------------
101      ! Bdy treatment does not update land points
102      DO jf = 1, ipf                   ! number of arrays to be treated
103         IF( nbondi == 2 ) THEN                  ! neither subdomain to the east nor to the west
104            !                                      !* Cyclic East-West boundaries
105            IF( l_Iperio ) THEN
106               ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf)
107               ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN(  2  ,:,:,:,jf)
108            END IF
109         END IF
110         IF( nbondj == 2) THEN                  ! neither subdomain to the north nor to the south
111            !                                      !* Cyclic North-South boundaries
112            IF( l_Jperio ) THEN
113               ARRAY_IN(:, 1 ,:,:,jf) = ARRAY_IN(:,jpjm1,:,:,jf)
114               ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:,  2  ,:,:,jf)
115            END IF
116         END IF
117      END DO
118
119
120      ! 2. East and west directions exchange
121      ! ------------------------------------
122      ! we play with the neigbours AND the row number because of the periodicity
123      !
124      IF( llsend_we )   ALLOCATE( zsend_we(jpj,nn_hls,ipk,ipl,ipf) )
125      IF( llsend_ea )   ALLOCATE( zsend_ea(jpj,nn_hls,ipk,ipl,ipf) )
126      IF( llrecv_we )   ALLOCATE( zrecv_we(jpj,nn_hls,ipk,ipl,ipf) )
127      IF( llrecv_ea )   ALLOCATE( zrecv_ea(jpj,nn_hls,ipk,ipl,ipf) )
128      !
129      ! Load arrays to the east and to the west to be sent
130      IF( llsend_we )   THEN   ! Read Dirichlet lateral conditions
131         DO jf = 1, ipf
132            DO jl = 1, ipl
133               DO jk = 1, ipk
134                  DO jh = 1, nn_hls
135                     zsend_we(:,jh,jk,jl,jf) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf)
136                  END DO
137               END DO
138            END DO
139         END DO
140      END IF
141      !
142      IF( llsend_ea )   THEN   ! Read Dirichlet lateral conditions
143         iihom = nlci-nreci
144         DO jf = 1, ipf
145            DO jl = 1, ipl
146               DO jk = 1, ipk
147                  DO jh = 1, nn_hls
148                     zsend_ea(:,jh,jk,jl,jf) = ARRAY_IN(iihom +jh,:,jk,jl,jf)
149                  END DO
150               END DO
151            END DO
152         END DO
153      END IF
154      !
155      ! Send/receive arrays to the east and to the west                           
156      imigr = nn_hls * jpj * ipk * ipl * ipf   ! Migrations
157      !
158      IF( ln_timing ) CALL tic_tac(.TRUE.)
159      !
160      IF( llsend_ea )   CALL mppsend( 2, zsend_ea(1,1,1,1,1), imigr, noea, ml_req1 )
161      IF( llsend_we )   CALL mppsend( 1, zsend_we(1,1,1,1,1), imigr, nowe, ml_req2 )
162      !
163      IF( llrecv_ea )   CALL mpprecv( 1, zrecv_ea(1,1,1,1,1), imigr, noea )
164      IF( llrecv_we )   CALL mpprecv( 2, zrecv_we(1,1,1,1,1), imigr, nowe )
165      !
166      IF( l_isend .AND. llsend_ea ) CALL mpi_wait(ml_req1, ml_stat, ml_err)
167      IF( l_isend .AND. llsend_we ) CALL mpi_wait(ml_req2, ml_stat, ml_err)
168      !
169      IF( ln_timing ) CALL tic_tac(.FALSE.)
170      !
171      !                           ! Write Dirichlet lateral conditions
172      ! Update with the received arrays
173      IF( llrecv_we )   THEN
174         DO jf = 1, ipf
175            DO jl = 1, ipl
176               DO jk = 1, ipk
177                  DO jh = 1, nn_hls
178                     ARRAY_IN(      jh,:,jk,jl,jf) = zrecv_we(:,jh,jk,jl,jf)
179                  END DO
180               END DO
181            END DO
182         END DO
183      END IF
184      !
185      IF( llrecv_ea )   THEN
186         iihom = nlci-nn_hls
187         DO jf = 1, ipf
188            DO jl = 1, ipl
189               DO jk = 1, ipk
190                  DO jh = 1, nn_hls
191                     ARRAY_IN(iihom+jh,:,jk,jl,jf) = zrecv_ea(:,jh,jk,jl,jf)
192                  END DO
193               END DO
194            END DO
195         END DO
196      END IF
197      !
198      ! Clean up
199      IF( llsend_we )   DEALLOCATE( zsend_we )
200      IF( llsend_ea )   DEALLOCATE( zsend_ea )
201      IF( llrecv_we )   DEALLOCATE( zrecv_we )
202      IF( llrecv_ea )   DEALLOCATE( zrecv_ea )
203
204      ! 3. north fold treatment
205      ! -----------------------
206      !
207      ! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor
208      IF( npolj /= 0) THEN
209         !
210         SELECT CASE ( jpni )
211         CASE ( 1 )     ;   CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! only 1 northern proc, no mpp
212         CASE DEFAULT   ;   CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! for all northern procs.
213         END SELECT
214         !
215      ENDIF
216
217      ! 4. North and south directions
218      ! -----------------------------
219      ! always closed : we play only with the neigbours
220      !
221      IF( llsend_so )   ALLOCATE( zsend_so(jpi,nn_hls,ipk,ipl,ipf) )
222      IF( llsend_no )   ALLOCATE( zsend_no(jpi,nn_hls,ipk,ipl,ipf) )
223      IF( llrecv_so )   ALLOCATE( zrecv_so(jpi,nn_hls,ipk,ipl,ipf) )
224      IF( llrecv_no )   ALLOCATE( zrecv_no(jpi,nn_hls,ipk,ipl,ipf) )
225      !
226      ! Load arrays to the south and to the north to be sent
227      IF( llsend_so )   THEN   ! Read Dirichlet lateral conditions
228         DO jf = 1, ipf
229            DO jl = 1, ipl
230               DO jk = 1, ipk
231                  DO jh = 1, nn_hls
232                     zsend_so(:,jh,jk,jl,jf) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf)
233                  END DO
234               END DO
235            END DO
236         END DO
237      END IF
238      !
239      IF( llsend_no )   THEN   ! Read Dirichlet lateral conditions
240         ijhom = nlcj-nrecj
241         DO jf = 1, ipf
242            DO jl = 1, ipl
243               DO jk = 1, ipk
244                  DO jh = 1, nn_hls
245                     zsend_no(:,jh,jk,jl,jf) = ARRAY_IN(:,ijhom +jh,jk,jl,jf)
246                  END DO
247               END DO
248            END DO
249         END DO
250      END IF
251      !
252      ! Send/receive arrays to the south and to the north
253      imigr = nn_hls * jpi * ipk * ipl * ipf   ! Migrations
254      !
255      IF( ln_timing ) CALL tic_tac(.TRUE.)
256      !
257      IF( llsend_no )   CALL mppsend( 4, zsend_no(1,1,1,1,1), imigr, nono, ml_req1 )
258      IF( llsend_so )   CALL mppsend( 3, zsend_so(1,1,1,1,1), imigr, noso, ml_req2 )
259      !
260      IF( llrecv_no )   CALL mpprecv( 3, zrecv_no(1,1,1,1,1), imigr, nono )
261      IF( llrecv_so )   CALL mpprecv( 4, zrecv_so(1,1,1,1,1), imigr, noso )
262      !
263      IF( l_isend .AND. llsend_no ) CALL mpi_wait(ml_req1, ml_stat, ml_err)
264      IF( l_isend .AND. llsend_so ) CALL mpi_wait(ml_req2, ml_stat, ml_err)
265      !
266      IF( ln_timing ) CALL tic_tac(.FALSE.)
267      !
268      !                           ! Write Dirichlet lateral conditions
269      ! Update with the received arrays
270      IF( llrecv_so )   THEN
271         DO jf = 1, ipf
272            DO jl = 1, ipl
273               DO jk = 1, ipk
274                  DO jh = 1, nn_hls
275                     ARRAY_IN(:,      jh,jk,jl,jf) = zrecv_so(:,jh,jk,jl,jf)
276                  END DO
277               END DO
278            END DO
279         END DO
280      END IF
281      IF( llrecv_no )   THEN
282         ijhom = nlcj-nn_hls
283         DO jf = 1, ipf
284            DO jl = 1, ipl
285               DO jk = 1, ipk
286                  DO jh = 1, nn_hls
287                     ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zrecv_no(:,jh,jk,jl,jf)
288                  END DO
289               END DO
290            END DO
291         END DO
292      END IF
293      !
294      ! Clean up
295      IF( llsend_so )   DEALLOCATE( zsend_so )
296      IF( llsend_no )   DEALLOCATE( zsend_no )
297      IF( llrecv_so )   DEALLOCATE( zrecv_so )
298      IF( llrecv_no )   DEALLOCATE( zrecv_no )
299      !
300   END SUBROUTINE ROUTINE_BDY
301
302#undef ARRAY_TYPE
303#undef NAT_IN
304#undef SGN_IN
305#undef ARRAY_IN
306#undef K_SIZE
307#undef L_SIZE
308#undef F_SIZE
309#undef OPT_K
310
Note: See TracBrowser for help on using the repository browser.