Ticket #2224: mpp_bdy_generic.h90

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