New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
mpp_bdy_generic.h90 in branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

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

Last change on this file since 8809 was 8809, checked in by acc, 6 years ago

Branch 2017/dev_r8126_ROBUST08_no_ghost. Remove multi forms of the mpp_bdy_lnk routines generated by mpp_bdy_generic.h90. They are not used and would not be an effective optimisation because of the loop over different boundaries.

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