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_r9759_HPC09_ESIWACE/src/OCE/LBC – NEMO

source: NEMO/branches/2018/dev_r9759_HPC09_ESIWACE/src/OCE/LBC/mpp_lnk_generic.h90 @ 9844

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

dev_r9759_HPC09_ESIWACE: better tic_tac
  • Property svn:mime-type set to text/x-fortran
File size: 14.6 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( rname, ptab, cd_nat, psgn, kfld, cd_mpp, pval )
49      INTEGER                     , INTENT(in   ) ::   kfld        ! number of pt3d arrays
50#else
51   SUBROUTINE ROUTINE_LNK( rname, 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=1)            , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points
55      REAL(wp)                    , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary
56      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp      ! fill the overlap area only
57      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval        ! background value (used at closed boundaries)
58      CHARACTER(len=*),             INTENT(in   ) ::   rname       ! name of the calling subroutine
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      REAL(wp) ::   zland
65      INTEGER , DIMENSION(MPI_STATUS_SIZE)      ::   ml_stat        ! for key_mpi_isend
66      REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! north-south & south-north  halos
67      REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! east -west  & west - east  halos
68      !!----------------------------------------------------------------------
69      !
70      ipk = K_SIZE(ptab)   ! 3rd dimension
71      ipl = L_SIZE(ptab)   ! 4th    -
72      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers)
73      !
74      ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2),   &
75         &      zt3ew(jpj,nn_hls,ipk,ipl,ipf,2), zt3we(jpj,nn_hls,ipk,ipl,ipf,2)  )
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( PRESENT( cd_mpp ) ) THEN     !==  halos filled with inner values  ==!
86         !
87         DO jf = 1, ipf                      ! number of arrays to be treated
88            !
89            DO jl = 1, ipl                   ! CAUTION: ptab is defined only between nld and nle
90               DO jk = 1, ipk
91                  DO jj = nlcj+1, jpj                 ! added line(s)   (inner only)
92                     ARRAY_IN(nldi  :nlei  ,jj,jk,jl,jf) = ARRAY_IN(nldi:nlei,nlej,jk,jl,jf)
93                     ARRAY_IN(1     :nldi-1,jj,jk,jl,jf) = ARRAY_IN(nldi     ,nlej,jk,jl,jf)
94                     ARRAY_IN(nlei+1:nlci  ,jj,jk,jl,jf) = ARRAY_IN(     nlei,nlej,jk,jl,jf)
95                  END DO
96                  DO ji = nlci+1, jpi                 ! added column(s) (full)
97                     ARRAY_IN(ji,nldj  :nlej  ,jk,jl,jf) = ARRAY_IN(nlei,nldj:nlej,jk,jl,jf)
98                     ARRAY_IN(ji,1     :nldj-1,jk,jl,jf) = ARRAY_IN(nlei,nldj     ,jk,jl,jf)
99                     ARRAY_IN(ji,nlej+1:jpj   ,jk,jl,jf) = ARRAY_IN(nlei,     nlej,jk,jl,jf)
100                  END DO
101               END DO
102            END DO
103            !
104         END DO
105         !
106      ELSE                              !==  standard close or cyclic treatment  ==!
107         !
108         DO jf = 1, ipf                      ! number of arrays to be treated
109            !
110            !                                ! East-West boundaries
111            IF( l_Iperio ) THEN                    !* cyclic
112               ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf)
113               ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN(  2  ,:,:,:,jf)
114            ELSE                                   !* closed
115               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(     1       :nn_hls,:,:,:,jf) = zland    ! east except F-point
116                                               ARRAY_IN(nlci-nn_hls+1:jpi   ,:,:,:,jf) = zland    ! west
117            ENDIF
118            !                                ! North-South boundaries
119            IF( l_Jperio ) THEN                    !* cyclic (only with no mpp j-split)
120               ARRAY_IN(:, 1 ,:,:,jf) = ARRAY_IN(:, jpjm1,:,:,jf)
121               ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:,   2  ,:,:,jf)
122            ELSE                                   !* closed
123               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:,     1       :nn_hls,:,:,jf) = zland    ! south except F-point
124                                               ARRAY_IN(:,nlcj-nn_hls+1:jpj   ,:,:,jf) = zland    ! north
125            ENDIF
126         END DO
127         !
128      ENDIF
129
130      ! ------------------------------- !
131      !      East and west exchange     !
132      ! ------------------------------- !
133      ! we play with the neigbours AND the row number because of the periodicity
134      !
135      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
136      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
137         iihom = nlci-nreci
138         DO jf = 1, ipf
139            DO jl = 1, ipl
140               DO jk = 1, ipk
141                  DO jh = 1, nn_hls
142                     zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf)
143                     zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf)
144                  END DO
145               END DO
146            END DO
147         END DO
148      END SELECT
149      !
150      !                           ! Migrations
151      imigr = nn_hls * jpj * ipk * ipl * ipf
152      !
153      IF ( ncom_stp == nit000 ) then
154         n_sequence = n_sequence + 1
155         icomm_sequence(n_sequence,1) = ipk
156         icomm_sequence(n_sequence,2) = ipf
157         ! write(6,'(A,6I4)') 'size comm ', nn_hls, jpi, jpj, ipk, ipl, ipf
158      ELSE IF ( mpprank == 0 .AND. ncom_stp == (nit000+1) ) THEN
159         IF ( l_print_comm_report ) THEN
160            write(6,*) 'Communication pattern report : '
161            write(6,*) ' '
162            write(6,'(A,I3)') ' Exchanged halos : ', n_sequence
163            jj = 0; jk = 0; jf = 0; jh = 0
164            DO ji = 1, n_sequence
165              IF ( icomm_sequence(ji,1) .gt. 1 ) jk = jk + 1
166              IF ( icomm_sequence(ji,2) .gt. 1 ) jf = jf + 1
167              IF ( icomm_sequence(ji,1) .gt. 1 .AND. icomm_sequence(ji,2) .gt. 1 ) jj = jj + 1
168              jh = MAX (jh, icomm_sequence(ji,1)*icomm_sequence(ji,2))
169            END DO
170            write(6,'(A,I3)') ' 3D Exchanged halos : ', jk
171            write(6,'(A,I3)') ' Multi arrays exchanged halos : ', jf
172            write(6,'(A,I3)') '   from which 3D : ', jj
173            write(6,'(A,I10)') ' array max size : ', jh*jpi*jpj
174            write(6,*) ' '
175            l_print_comm_report = .FALSE.
176         END IF
177         write(6,'(A19,A)') 'calling subroutine ', TRIM(rname)
178      END IF
179      !
180      IF (ncom_stp <= ( nit000 + 1 ) .or. mod(ncom_stp,nn_comm_mod) == 0 ) THEN
181         IF ( TRIM(rname) == "simulated_lbc_lnk" ) THEN
182            zt3we = zt3we + 1. ; zt3ew = zt3ew + 1.
183         ENDIF
184         !
185         CALL tic_tac(.TRUE.)
186         !
187         SELECT CASE ( nbondi )
188         CASE ( -1 )
189            CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req1 )
190            CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea )
191            IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err)
192         CASE ( 0 )
193            CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 )
194            CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req2 )
195            CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea )
196            CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe )
197            IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err)
198            IF(l_isend)   CALL mpi_wait(ml_req2, ml_stat, ml_err)
199         CASE ( 1 )
200            CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 )
201            CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe )
202            IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err )
203         END SELECT
204         !
205         CALL tic_tac(.FALSE.)
206         !
207      END IF
208      !
209      !                           ! Write Dirichlet lateral conditions
210      iihom = nlci-nn_hls
211      !
212      SELECT CASE ( nbondi )
213      CASE ( -1 )
214         DO jf = 1, ipf
215            DO jl = 1, ipl
216               DO jk = 1, ipk
217                  DO jh = 1, nn_hls
218                     ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)
219                  END DO
220               END DO
221            END DO
222         END DO
223      CASE ( 0 )
224         DO jf = 1, ipf
225            DO jl = 1, ipl
226               DO jk = 1, ipk
227                  DO jh = 1, nn_hls
228                     ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)
229                     ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)
230                  END DO
231               END DO
232            END DO
233         END DO
234      CASE ( 1 )
235         DO jf = 1, ipf
236            DO jl = 1, ipl
237               DO jk = 1, ipk
238                  DO jh = 1, nn_hls
239                     ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)
240                  END DO
241               END DO
242            END DO
243         END DO
244      END SELECT
245
246      ! 3. North and south directions
247      ! -----------------------------
248      ! always closed : we play only with the neigbours
249      !
250      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
251         ijhom = nlcj-nrecj
252         DO jf = 1, ipf
253            DO jl = 1, ipl
254               DO jk = 1, ipk
255                  DO jh = 1, nn_hls
256                     zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf)
257                     zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf)
258                  END DO
259               END DO
260            END DO
261         END DO
262      ENDIF
263      !
264      !                           ! Migrations
265      imigr = nn_hls * jpi * ipk * ipl * ipf
266      !
267      IF (ncom_stp <= ( nit000 + 1 ) .or. mod(ncom_stp,nn_comm_mod) == 0 ) THEN
268         IF ( TRIM(rname) == "simulated_lbc_lnk" ) THEN
269            zt3sn = zt3sn + 1. ; zt3ns = zt3ns + 1.
270         ENDIF
271         !
272         CALL tic_tac(.TRUE.)
273         !
274         SELECT CASE ( nbondj )
275         CASE ( -1 )
276            CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req1 )
277            CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono )
278            IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
279         CASE ( 0 )
280            CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
281            CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req2 )
282            CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono )
283            CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso )
284            IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err )
285            IF(l_isend)   CALL mpi_wait(ml_req2, ml_stat, ml_err )
286         CASE ( 1 )
287            CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
288            CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso )
289            IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err )
290         END SELECT
291         ! imbalance measurement
292         CALL tic_tac(.FALSE.)
293         !
294      END IF
295      !
296      !                           ! Write Dirichlet lateral conditions
297      ijhom = nlcj-nn_hls
298      !
299      SELECT CASE ( nbondj )
300      CASE ( -1 )
301         DO jf = 1, ipf
302            DO jl = 1, ipl
303               DO jk = 1, ipk
304                  DO jh = 1, nn_hls
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 ( 0 )
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,2)
316                     ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2)
317                  END DO
318               END DO
319            END DO
320         END DO
321      CASE ( 1 )
322         DO jf = 1, ipf
323            DO jl = 1, ipl
324               DO jk = 1, ipk
325                  DO jh = 1, nn_hls
326                     ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2)
327                  END DO
328               END DO
329            END DO
330         END DO
331      END SELECT
332
333      ! 4. north fold treatment
334      ! -----------------------
335      !
336      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
337         !
338         SELECT CASE ( jpni )
339         CASE ( 1 )     ;   CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! only 1 northern proc, no mpp
340         CASE DEFAULT   ;   CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! for all northern procs.
341         END SELECT
342         !
343      ENDIF
344      !
345      DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we )
346      !
347   END SUBROUTINE ROUTINE_LNK
348
349#undef ARRAY_TYPE
350#undef NAT_IN
351#undef SGN_IN
352#undef ARRAY_IN
353#undef K_SIZE
354#undef L_SIZE
355#undef F_SIZE
356#undef OPT_K
Note: See TracBrowser for help on using the repository browser.