source: branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/mpp_bdy_generic.h90 @ 8591

Last change on this file since 8591 was 8591, checked in by acc, 3 years ago

Branch 2017/dev_r8126_ROBUST08_no_ghost. Add in fixes for mono-processor operation as supplied by gm. Fully Sette-tested at this stage.

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