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_lnk_generic.h90 in NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC – NEMO

source: NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/mpp_lnk_generic.h90 @ 10329

Last change on this file since 10329 was 10329, checked in by smasson, 6 years ago

dev_r10164_HPC09_ESIWACE_PREP_MERGE: action 3c: slight cleanning/optimisation of lbc_lnk, see #2133

  • Property svn:keywords set to Id
  • Property svn:mime-type set to text/x-fortran
File size: 13.3 KB
Line 
1#if defined MULTI
2#   define NAT_IN(k)                cd_nat(k)   
3#   define SGN_IN(k)                psgn(k)
4#   define F_SIZE(ptab)             kfld
5#   define OPT_K(k)                 ,ipf
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 F_SIZE(ptab)             1
29#   define OPT_K(k)                 
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_LNK( cdname, ptab, cd_nat, psgn, kfld, cd_mpp, pval )
49      INTEGER                     , INTENT(in   ) ::   kfld        ! number of pt3d arrays
50#else
51   SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn      , cd_mpp, pval )
52#endif
53      ARRAY_TYPE(:,:,:,:,:)                                        ! array or pointer of arrays on which the boundary condition is applied
54      CHARACTER(len=*)            , INTENT(in   ) ::   cdname      ! name of the calling subroutine
55      CHARACTER(len=1)            , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points
56      REAL(wp)                    , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary
57      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp      ! fill the overlap area only
58      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval        ! background value (used at closed boundaries)
59      !
60      INTEGER  ::    ji,  jj,  jk,  jl, jh, jf   ! dummy loop indices
61      INTEGER  ::   ipi, ipj, ipk, ipl, ipf      ! dimension of the input array
62      INTEGER  ::   imigr, iihom, ijhom          ! local integers
63      INTEGER  ::   ml_req1, ml_req2, ml_err     ! for key_mpi_isend
64      INTEGER  ::   ierr
65      REAL(wp) ::   zland
66      INTEGER , DIMENSION(MPI_STATUS_SIZE)      ::   ml_stat        ! for key_mpi_isend
67      REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! north-south & south-north  halos
68      REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! east -west  & west - east  halos
69      !!----------------------------------------------------------------------
70      !
71      ipk = K_SIZE(ptab)   ! 3rd dimension
72      ipl = L_SIZE(ptab)   ! 4th    -
73      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers)
74      !
75      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. )
76      !
77      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
78      ELSE                         ;   zland = 0._wp     ! zero by default
79      ENDIF
80
81      ! ------------------------------- !
82      !   standard boundary treatment   !    ! CAUTION: semi-column notation is often impossible
83      ! ------------------------------- !
84      !
85      IF( .NOT. PRESENT( cd_mpp ) ) THEN     !==  standard close or cyclic treatment  ==!
86         !
87         DO jf = 1, ipf                      ! number of arrays to be treated
88            !
89            !                                ! East-West boundaries
90            IF( l_Iperio ) THEN                    !* cyclic
91               ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf)
92               ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN(  2  ,:,:,:,jf)
93            ELSE                                   !* closed
94               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(     1       :nn_hls,:,:,:,jf) = zland    ! east except F-point
95                                               ARRAY_IN(nlci-nn_hls+1:jpi   ,:,:,:,jf) = zland    ! west
96            ENDIF
97            !                                ! North-South boundaries
98            IF( l_Jperio ) THEN                    !* cyclic (only with no mpp j-split)
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    ! south except F-point
103                                               ARRAY_IN(:,nlcj-nn_hls+1:jpj   ,:,:,jf) = zland    ! north
104            ENDIF
105         END DO
106         !
107      ENDIF
108
109      ! ------------------------------- !
110      !      East and west exchange     !
111      ! ------------------------------- !
112      ! we play with the neigbours AND the row number because of the periodicity
113      !
114      IF( ABS(nbondi) == 1 ) ALLOCATE( zt3ew(jpj,nn_hls,ipk,ipl,ipf,1), zt3we(jpj,nn_hls,ipk,ipl,ipf,1) )
115      IF(     nbondi  == 0 ) ALLOCATE( zt3ew(jpj,nn_hls,ipk,ipl,ipf,2), zt3we(jpj,nn_hls,ipk,ipl,ipf,2) )
116      !
117      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
118      CASE ( -1 )
119         iihom = nlci-nreci
120         DO jf = 1, ipf
121            DO jl = 1, ipl
122               DO jk = 1, ipk
123                  DO jh = 1, nn_hls
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 DO
129      CASE ( 0 )
130         iihom = nlci-nreci
131         DO jf = 1, ipf
132            DO jl = 1, ipl
133               DO jk = 1, ipk
134                  DO jh = 1, nn_hls
135                     zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf)
136                     zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf)
137                  END DO
138               END DO
139            END DO
140         END DO
141      CASE ( 1 )
142         iihom = nlci-nreci
143         DO jf = 1, ipf
144            DO jl = 1, ipl
145               DO jk = 1, ipk
146                  DO jh = 1, nn_hls
147                     zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf)
148                  END DO
149               END DO
150            END DO
151         END DO
152      END SELECT
153      !                           ! Migrations
154      imigr = nn_hls * jpj * ipk * ipl * ipf     
155      !
156      IF( ln_timing ) CALL tic_tac(.TRUE.)
157      !
158      SELECT CASE ( nbondi )
159      CASE ( -1 )
160         CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req1 )
161         CALL mpprecv( 1, zt3ew(1,1,1,1,1,1), imigr, noea )
162         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err)
163      CASE ( 0 )
164         CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 )
165         CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req2 )
166         CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea )
167         CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe )
168         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err)
169         IF(l_isend)   CALL mpi_wait(ml_req2, ml_stat, ml_err)
170      CASE ( 1 )
171         CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 )
172         CALL mpprecv( 2, zt3we(1,1,1,1,1,1), imigr, nowe )
173         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err )
174      END SELECT
175      !
176      IF( ln_timing ) CALL tic_tac(.FALSE.)
177      !
178      !                           ! Write Dirichlet lateral conditions
179      iihom = nlci-nn_hls
180      !
181      SELECT CASE ( nbondi )
182      CASE ( -1 )
183         DO jf = 1, ipf
184            DO jl = 1, ipl
185               DO jk = 1, ipk
186                  DO jh = 1, nn_hls
187                     ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,1)
188                  END DO
189               END DO
190            END DO
191         END DO
192      CASE ( 0 )
193         DO jf = 1, ipf
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                     ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)
199                  END DO
200               END DO
201            END DO
202         END DO
203      CASE ( 1 )
204         DO jf = 1, ipf
205            DO jl = 1, ipl
206               DO jk = 1, ipk
207                  DO jh = 1, nn_hls
208                     ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,1)
209                  END DO
210               END DO
211            END DO
212         END DO
213      END SELECT
214      !
215      IF( nbondi /= 2 ) DEALLOCATE( zt3ew, zt3we )
216
217      ! 3. North and south directions
218      ! -----------------------------
219      ! always closed : we play only with the neigbours
220      !
221      IF( ABS(nbondj) == 1 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,1), zt3sn(jpi,nn_hls,ipk,ipl,ipf,1) )
222      IF(     nbondj  == 0 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2) )
223      !
224      SELECT CASE ( nbondj )
225      CASE ( -1 )
226         ijhom = nlcj-nrecj
227         DO jf = 1, ipf
228            DO jl = 1, ipl
229               DO jk = 1, ipk
230                  DO jh = 1, nn_hls
231                     zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf)
232                  END DO
233               END DO
234            END DO
235         END DO
236      CASE ( 0 )
237         ijhom = nlcj-nrecj
238         DO jf = 1, ipf
239            DO jl = 1, ipl
240               DO jk = 1, ipk
241                  DO jh = 1, nn_hls
242                     zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf)
243                     zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf)
244                  END DO
245               END DO
246            END DO
247         END DO
248      CASE ( 1 )
249         ijhom = nlcj-nrecj
250         DO jf = 1, ipf
251            DO jl = 1, ipl
252               DO jk = 1, ipk
253                  DO jh = 1, nn_hls
254                     zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf)
255                  END DO
256               END DO
257            END DO
258         END DO
259      END SELECT
260      !
261      !                           ! Migrations
262      imigr = nn_hls * jpi * ipk * ipl * ipf
263      !
264      IF( ln_timing ) CALL tic_tac(.TRUE.)
265      !
266      SELECT CASE ( nbondj )
267      CASE ( -1 )
268         CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req1 )
269         CALL mpprecv( 3, zt3ns(1,1,1,1,1,1), imigr, nono )
270         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
271      CASE ( 0 )
272         CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
273         CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req2 )
274         CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono )
275         CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso )
276         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err )
277         IF(l_isend)   CALL mpi_wait(ml_req2, ml_stat, ml_err )
278      CASE ( 1 )
279         CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
280         CALL mpprecv( 4, zt3sn(1,1,1,1,1,1), imigr, noso )
281         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err )
282      END SELECT
283      !
284      IF( ln_timing ) CALL tic_tac(.FALSE.)
285      !                           ! Write Dirichlet lateral conditions
286      ijhom = nlcj-nn_hls
287      !
288      SELECT CASE ( nbondj )
289      CASE ( -1 )
290         DO jf = 1, ipf
291            DO jl = 1, ipl
292               DO jk = 1, ipk
293                  DO jh = 1, nn_hls
294                     ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,1)
295                  END DO
296               END DO
297            END DO
298         END DO
299      CASE ( 0 )
300         DO jf = 1, ipf
301            DO jl = 1, ipl
302               DO jk = 1, ipk
303                  DO jh = 1, nn_hls
304                     ARRAY_IN(:,      jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2)
305                     ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2)
306                  END DO
307               END DO
308            END DO
309         END DO
310      CASE ( 1 )
311         DO jf = 1, ipf
312            DO jl = 1, ipl
313               DO jk = 1, ipk
314                  DO jh = 1, nn_hls
315                     ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,1)
316                  END DO
317               END DO
318            END DO
319         END DO
320      END SELECT
321      !
322      IF( nbondj /= 2 ) DEALLOCATE( zt3ns, zt3sn )
323
324      ! 4. north fold treatment
325      ! -----------------------
326      !
327      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
328         !
329         SELECT CASE ( jpni )
330         CASE ( 1 )     ;   CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! only 1 northern proc, no mpp
331         CASE DEFAULT   ;   CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! for all northern procs.
332         END SELECT
333         !
334      ENDIF
335      !
336   END SUBROUTINE ROUTINE_LNK
337
338#undef ARRAY_TYPE
339#undef NAT_IN
340#undef SGN_IN
341#undef ARRAY_IN
342#undef K_SIZE
343#undef L_SIZE
344#undef F_SIZE
345#undef OPT_K
Note: See TracBrowser for help on using the repository browser.