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 @ 10314

Last change on this file since 10314 was 10314, checked in by smasson, 5 years ago

dev_r10164_HPC09_ESIWACE_PREP_MERGE: action 2: add generic glob_min/max/sum and locmin/max, complete timing and report (including bdy and icb), see #2133
  • Property svn:keywords set to Id
  • Property svn:mime-type set to text/x-fortran
File size: 12.9 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      ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2),   &
78         &      zt3ew(jpj,nn_hls,ipk,ipl,ipf,2), zt3we(jpj,nn_hls,ipk,ipl,ipf,2)  )
79      !
80      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
81      ELSE                         ;   zland = 0._wp     ! zero by default
82      ENDIF
83
84      ! ------------------------------- !
85      !   standard boundary treatment   !    ! CAUTION: semi-column notation is often impossible
86      ! ------------------------------- !
87      !
88      IF( PRESENT( cd_mpp ) ) THEN     !==  halos filled with inner values  ==!
89         !
90         DO jf = 1, ipf                      ! number of arrays to be treated
91            !
92            DO jl = 1, ipl                   ! CAUTION: ptab is defined only between nld and nle
93               DO jk = 1, ipk
94                  DO jj = nlcj+1, jpj                 ! added line(s)   (inner only)
95                     ARRAY_IN(nldi  :nlei  ,jj,jk,jl,jf) = ARRAY_IN(nldi:nlei,nlej,jk,jl,jf)
96                     ARRAY_IN(1     :nldi-1,jj,jk,jl,jf) = ARRAY_IN(nldi     ,nlej,jk,jl,jf)
97                     ARRAY_IN(nlei+1:nlci  ,jj,jk,jl,jf) = ARRAY_IN(     nlei,nlej,jk,jl,jf)
98                  END DO
99                  DO ji = nlci+1, jpi                 ! added column(s) (full)
100                     ARRAY_IN(ji,nldj  :nlej  ,jk,jl,jf) = ARRAY_IN(nlei,nldj:nlej,jk,jl,jf)
101                     ARRAY_IN(ji,1     :nldj-1,jk,jl,jf) = ARRAY_IN(nlei,nldj     ,jk,jl,jf)
102                     ARRAY_IN(ji,nlej+1:jpj   ,jk,jl,jf) = ARRAY_IN(nlei,     nlej,jk,jl,jf)
103                  END DO
104               END DO
105            END DO
106            !
107         END DO
108         !
109      ELSE                              !==  standard close or cyclic treatment  ==!
110         !
111         DO jf = 1, ipf                      ! number of arrays to be treated
112            !
113            !                                ! East-West boundaries
114            IF( l_Iperio ) THEN                    !* cyclic
115               ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf)
116               ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN(  2  ,:,:,:,jf)
117            ELSE                                   !* closed
118               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(     1       :nn_hls,:,:,:,jf) = zland    ! east except F-point
119                                               ARRAY_IN(nlci-nn_hls+1:jpi   ,:,:,:,jf) = zland    ! west
120            ENDIF
121            !                                ! North-South boundaries
122            IF( l_Jperio ) THEN                    !* cyclic (only with no mpp j-split)
123               ARRAY_IN(:, 1 ,:,:,jf) = ARRAY_IN(:, jpjm1,:,:,jf)
124               ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:,   2  ,:,:,jf)
125            ELSE                                   !* closed
126               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:,     1       :nn_hls,:,:,jf) = zland    ! south except F-point
127                                               ARRAY_IN(:,nlcj-nn_hls+1:jpj   ,:,:,jf) = zland    ! north
128            ENDIF
129         END DO
130         !
131      ENDIF
132
133      ! ------------------------------- !
134      !      East and west exchange     !
135      ! ------------------------------- !
136      ! we play with the neigbours AND the row number because of the periodicity
137      !
138      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
139      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
140         iihom = nlci-nreci
141         DO jf = 1, ipf
142            DO jl = 1, ipl
143               DO jk = 1, ipk
144                  DO jh = 1, nn_hls
145                     zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf)
146                     zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf)
147                  END DO
148               END DO
149            END DO
150         END DO
151      END SELECT
152      !
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,2), 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,2), 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      !
179      !                           ! Write Dirichlet lateral conditions
180      iihom = nlci-nn_hls
181      !
182      SELECT CASE ( nbondi )
183      CASE ( -1 )
184         DO jf = 1, ipf
185            DO jl = 1, ipl
186               DO jk = 1, ipk
187                  DO jh = 1, nn_hls
188                     ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)
189                  END DO
190               END DO
191            END DO
192         END DO
193      CASE ( 0 )
194         DO jf = 1, ipf
195            DO jl = 1, ipl
196               DO jk = 1, ipk
197                  DO jh = 1, nn_hls
198                     ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)
199                     ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)
200                  END DO
201               END DO
202            END DO
203         END DO
204      CASE ( 1 )
205         DO jf = 1, ipf
206            DO jl = 1, ipl
207               DO jk = 1, ipk
208                  DO jh = 1, nn_hls
209                     ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)
210                  END DO
211               END DO
212            END DO
213         END DO
214      END SELECT
215
216      ! 3. North and south directions
217      ! -----------------------------
218      ! always closed : we play only with the neigbours
219      !
220      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
221         ijhom = nlcj-nrecj
222         DO jf = 1, ipf
223            DO jl = 1, ipl
224               DO jk = 1, ipk
225                  DO jh = 1, nn_hls
226                     zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf)
227                     zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf)
228                  END DO
229               END DO
230            END DO
231         END DO
232      ENDIF
233      !
234      !                           ! Migrations
235      imigr = nn_hls * jpi * ipk * ipl * ipf
236      !
237      IF( ln_timing ) CALL tic_tac(.TRUE.)
238      !
239      SELECT CASE ( nbondj )
240      CASE ( -1 )
241         CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req1 )
242         CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono )
243         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
244      CASE ( 0 )
245         CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
246         CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req2 )
247         CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono )
248         CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso )
249         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err )
250         IF(l_isend)   CALL mpi_wait(ml_req2, ml_stat, ml_err )
251      CASE ( 1 )
252         CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
253         CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso )
254         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err )
255      END SELECT
256      !
257      IF( ln_timing ) CALL tic_tac(.FALSE.)
258      !                           ! Write Dirichlet lateral conditions
259      ijhom = nlcj-nn_hls
260      !
261      SELECT CASE ( nbondj )
262      CASE ( -1 )
263         DO jf = 1, ipf
264            DO jl = 1, ipl
265               DO jk = 1, ipk
266                  DO jh = 1, nn_hls
267                     ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2)
268                  END DO
269               END DO
270            END DO
271         END DO
272      CASE ( 0 )
273         DO jf = 1, ipf
274            DO jl = 1, ipl
275               DO jk = 1, ipk
276                  DO jh = 1, nn_hls
277                     ARRAY_IN(:,      jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2)
278                     ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2)
279                  END DO
280               END DO
281            END DO
282         END DO
283      CASE ( 1 )
284         DO jf = 1, ipf
285            DO jl = 1, ipl
286               DO jk = 1, ipk
287                  DO jh = 1, nn_hls
288                     ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2)
289                  END DO
290               END DO
291            END DO
292         END DO
293      END SELECT
294
295      ! 4. north fold treatment
296      ! -----------------------
297      !
298      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
299         !
300         SELECT CASE ( jpni )
301         CASE ( 1 )     ;   CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! only 1 northern proc, no mpp
302         CASE DEFAULT   ;   CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! for all northern procs.
303         END SELECT
304         !
305      ENDIF
306      !
307      DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we )
308      !
309   END SUBROUTINE ROUTINE_LNK
310
311#undef ARRAY_TYPE
312#undef NAT_IN
313#undef SGN_IN
314#undef ARRAY_IN
315#undef K_SIZE
316#undef L_SIZE
317#undef F_SIZE
318#undef OPT_K
Note: See TracBrowser for help on using the repository browser.