source: branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/LBC/mpp_bdy_generic.h90 @ 8882

Last change on this file since 8882 was 8882, checked in by flavoni, 3 years ago

dev_CNRS_2017 branch: merged dev_r7881_ENHANCE09_RK3 with trunk r8864

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