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 NEMO/branches/UKMO/dev_r9950_GO8_package/src/OCE/LBC – NEMO

source: NEMO/branches/UKMO/dev_r9950_GO8_package/src/OCE/LBC/mpp_bdy_generic.h90 @ 10326

Last change on this file since 10326 was 10326, checked in by davestorkey, 5 years ago

UKMO/dev_r9950_GO8_package: clear SVN keywords.

  • Property svn:mime-type set to text/x-fortran
File size: 11.9 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( l_Iperio ) 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) THEN                  ! neither subdomain to the north nor to the south
94            !                                      !* Cyclic
95            IF( l_Jperio ) THEN
96               ARRAY_IN(:, 1 ,:,:,jf) = ARRAY_IN(:,jpjm1,:,:,jf)
97               ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:,  2  ,:,:,jf)
98            ELSE                                   !* Closed
99               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:,     1       :nn_hls,:,:,jf) = zland  ! east except F-point
100                                               ARRAY_IN(:,nlcj-nn_hls+1:jpj   ,:,:,jf) = zland  ! west
101            ENDIF
102         ELSEIF(nbondj == -1) THEN              ! subdomain to the east only
103            IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:,1:nn_hls,:,:,jf) = zland     ! south except F-point
104            !
105         ELSEIF(nbondj ==  1) THEN              ! subdomain to the west only
106            ARRAY_IN(:,nlcj-nn_hls+1:jpj,:,:,jf) = zland    ! north
107         ENDIF
108         !
109      END DO
110
111      ! 2. East and west directions exchange
112      ! ------------------------------------
113      ! we play with the neigbours AND the row number because of the periodicity
114      !
115      !
116      DO jf = 1, ipf
117         SELECT CASE ( nbondi_bdy(IBD_IN(jf)) )      ! Read Dirichlet lateral conditions
118         CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
119            iihom = nlci-nreci
120               DO jl = 1, ipl
121                  DO jk = 1, ipk
122                     DO jh = 1, nn_hls
123                        zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf)
124                        zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf)
125                     END DO
126                  END DO
127               END DO
128         END SELECT
129         !
130         !                           ! Migrations
131!!gm      imigr = nn_hls * jpj * ipk * ipl * ipf
132         imigr = nn_hls * jpj * ipk * ipl
133         !
134         SELECT CASE ( nbondi_bdy(IBD_IN(jf)) )
135         CASE ( -1 )
136            CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req1 )
137            CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea )
138            IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
139         CASE ( 0 )
140            CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 )
141            CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req2 )
142            CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea )
143            CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe )
144            IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
145            IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
146         CASE ( 1 )
147            CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 )
148            CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe )
149            IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
150         END SELECT
151         !
152         !                           ! Write Dirichlet lateral conditions
153         iihom = nlci-nn_hls
154         !
155         !
156         SELECT CASE ( nbondi_bdy_b(IBD_IN(jf)) )
157         CASE ( -1 )
158            DO jl = 1, ipl
159               DO jk = 1, ipk
160                  DO jh = 1, nn_hls
161                     ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)
162                  END DO
163               END DO
164            END DO
165         CASE ( 0 )
166            DO jl = 1, ipl
167               DO jk = 1, ipk
168                  DO jh = 1, nn_hls
169                     ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)
170                     ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)
171                  END DO
172               END DO
173            END DO
174         CASE ( 1 )
175            DO jl = 1, ipl
176               DO jk = 1, ipk
177                  DO jh = 1, nn_hls
178                     ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)
179                  END DO
180               END DO
181            END DO
182         END SELECT
183         !
184      END DO
185
186      ! 3. North and south directions
187      ! -----------------------------
188      ! always closed : we play only with the neigbours
189      !
190      DO jf = 1, ipf
191         IF( nbondj_bdy(IBD_IN(jf)) /= 2 ) THEN      ! Read Dirichlet lateral conditions
192            ijhom = nlcj-nrecj
193            DO jl = 1, ipl
194               DO jk = 1, ipk
195                  DO jh = 1, nn_hls
196                     zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf)
197                     zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf)
198                  END DO
199               END DO
200            END DO
201         ENDIF
202         !
203         !                           ! Migrations
204!!gm      imigr = nn_hls * jpi * ipk * ipl * ipf
205         imigr = nn_hls * jpi * ipk * ipl
206         !
207         SELECT CASE ( nbondj_bdy(IBD_IN(jf)) )
208         CASE ( -1 )
209            CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req1 )
210            CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono )
211            IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
212         CASE ( 0 )
213            CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
214            CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req2 )
215            CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono )
216            CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso )
217            IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
218            IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
219         CASE ( 1 )
220            CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
221            CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso )
222            IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
223         END SELECT
224         !
225         !                           ! Write Dirichlet lateral conditions
226         ijhom = nlcj-nn_hls
227         !
228         SELECT CASE ( nbondj_bdy_b(IBD_IN(jf)) )
229         CASE ( -1 )
230            DO jl = 1, ipl
231               DO jk = 1, ipk
232                  DO jh = 1, nn_hls
233                     ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2)
234                  END DO
235               END DO
236            END DO
237         CASE ( 0 )
238            DO jl = 1, ipl
239               DO jk = 1, ipk
240                  DO jh = 1, nn_hls
241                     ARRAY_IN(:,      jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2)
242                     ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2)
243                  END DO
244               END DO
245            END DO
246         CASE ( 1 )
247            DO jl = 1, ipl
248               DO jk = 1, ipk
249                  DO jh = 1, nn_hls
250                     ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2)
251                  END DO
252               END DO
253            END DO
254         END SELECT
255      END DO
256
257      ! 4. north fold treatment
258      ! -----------------------
259      !
260      IF( npolj /= 0) THEN
261         !
262         SELECT CASE ( jpni )
263         CASE ( 1 )     ;   CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! only 1 northern proc, no mpp
264         CASE DEFAULT   ;   CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! for all northern procs.
265         END SELECT
266         !
267      ENDIF
268      !
269      DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we  )
270      !
271   END SUBROUTINE ROUTINE_BDY
272
273#undef ARRAY_TYPE
274#undef NAT_IN
275#undef SGN_IN
276#undef IBD_IN
277#undef ARRAY_IN
278#undef K_SIZE
279#undef L_SIZE
280#undef F_SIZE
281#undef OPT_K
Note: See TracBrowser for help on using the repository browser.