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

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

dev_r10164_HPC09_ESIWACE_PREP_MERGE: action 2b: improve of timing, add computing and waiting time, see #2133
  • Property svn:keywords set to Id
  • Property svn:mime-type set to text/x-fortran
File size: 15.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( 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      ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2),   &
76         &      zt3ew(jpj,nn_hls,ipk,ipl,ipf,2), zt3we(jpj,nn_hls,ipk,ipl,ipf,2)  )
77      !
78      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
79      ELSE                         ;   zland = 0._wp     ! zero by default
80      ENDIF
81
82      ! ------------------------------- !
83      !   standard boundary treatment   !    ! CAUTION: semi-column notation is often impossible
84      ! ------------------------------- !
85      !
86      IF( PRESENT( cd_mpp ) ) THEN     !==  halos filled with inner values  ==!
87         !
88         DO jf = 1, ipf                      ! number of arrays to be treated
89            !
90            DO jl = 1, ipl                   ! CAUTION: ptab is defined only between nld and nle
91               DO jk = 1, ipk
92                  DO jj = nlcj+1, jpj                 ! added line(s)   (inner only)
93                     ARRAY_IN(nldi  :nlei  ,jj,jk,jl,jf) = ARRAY_IN(nldi:nlei,nlej,jk,jl,jf)
94                     ARRAY_IN(1     :nldi-1,jj,jk,jl,jf) = ARRAY_IN(nldi     ,nlej,jk,jl,jf)
95                     ARRAY_IN(nlei+1:nlci  ,jj,jk,jl,jf) = ARRAY_IN(     nlei,nlej,jk,jl,jf)
96                  END DO
97                  DO ji = nlci+1, jpi                 ! added column(s) (full)
98                     ARRAY_IN(ji,nldj  :nlej  ,jk,jl,jf) = ARRAY_IN(nlei,nldj:nlej,jk,jl,jf)
99                     ARRAY_IN(ji,1     :nldj-1,jk,jl,jf) = ARRAY_IN(nlei,nldj     ,jk,jl,jf)
100                     ARRAY_IN(ji,nlej+1:jpj   ,jk,jl,jf) = ARRAY_IN(nlei,     nlej,jk,jl,jf)
101                  END DO
102               END DO
103            END DO
104            !
105         END DO
106         !
107      ELSE                              !==  standard close or cyclic treatment  ==!
108         !
109         DO jf = 1, ipf                      ! number of arrays to be treated
110            !
111            !                                ! East-West boundaries
112            IF( l_Iperio ) THEN                    !* cyclic
113               ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf)
114               ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN(  2  ,:,:,:,jf)
115            ELSE                                   !* closed
116               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(     1       :nn_hls,:,:,:,jf) = zland    ! east except F-point
117                                               ARRAY_IN(nlci-nn_hls+1:jpi   ,:,:,:,jf) = zland    ! west
118            ENDIF
119            !                                ! North-South boundaries
120            IF( l_Jperio ) THEN                    !* cyclic (only with no mpp j-split)
121               ARRAY_IN(:, 1 ,:,:,jf) = ARRAY_IN(:, jpjm1,:,:,jf)
122               ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:,   2  ,:,:,jf)
123            ELSE                                   !* closed
124               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:,     1       :nn_hls,:,:,jf) = zland    ! south except F-point
125                                               ARRAY_IN(:,nlcj-nn_hls+1:jpj   ,:,:,jf) = zland    ! north
126            ENDIF
127         END DO
128         !
129      ENDIF
130
131      ! ------------------------------- !
132      !      East and west exchange     !
133      ! ------------------------------- !
134      ! we play with the neigbours AND the row number because of the periodicity
135      !
136      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
137      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
138         iihom = nlci-nreci
139         DO jf = 1, ipf
140            DO jl = 1, ipl
141               DO jk = 1, ipk
142                  DO jh = 1, nn_hls
143                     zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf)
144                     zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf)
145                  END DO
146               END DO
147            END DO
148         END DO
149      END SELECT
150      !
151      !                           ! Migrations
152      imigr = nn_hls * jpj * ipk * ipl * ipf
153      !
154      IF( narea == 1 ) THEN
155         IF ( ncom_stp == nit000 ) THEN
156            IF( .NOT. ALLOCATED( ncomm_sequence) ) THEN
157               ALLOCATE( ncomm_sequence(1000,2), STAT=ierr )
158               IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'lnk_generic, cannot allocate ncomm_sequence' )
159               ALLOCATE( crname(1000), STAT=ierr )
160               IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'lnk_generic, cannot allocate crname' )
161            ENDIF
162            n_sequence = n_sequence + 1
163            IF( n_sequence > 1000 ) CALL ctl_stop( 'STOP', 'lnk_generic, increase ncomm_sequence first dimension' )
164            ncomm_sequence(n_sequence,1) = ipk*ipl   ! size of 3rd and 4th dimensions
165            ncomm_sequence(n_sequence,2) = ipf       ! number of arrays to be treated (multi)
166            crname(n_sequence) = cdname              ! keep the name of the calling routine
167         ELSE IF ( ncom_stp == (nit000+1) ) THEN
168            IF ( .NOT. l_comm_report_done ) THEN
169               WRITE(numout,*) ' '
170               WRITE(numout,*) ' -----------------------------------------------'
171               WRITE(numout,*) ' Communication pattern report (first time step):'
172               WRITE(numout,*) ' -----------------------------------------------'
173               WRITE(numout,*) ' '
174               WRITE(numout,'(A,I3)') ' Exchanged halos : ', n_sequence
175               jj = 0; jk = 0; jf = 0; jh = 0
176               DO ji = 1, n_sequence
177                  IF ( ncomm_sequence(ji,1) .GT. 1 ) jk = jk + 1
178                  IF ( ncomm_sequence(ji,2) .GT. 1 ) jf = jf + 1
179                  IF ( ncomm_sequence(ji,1) .GT. 1 .AND. ncomm_sequence(ji,2) .GT. 1 ) jj = jj + 1
180                  jh = MAX (jh, ncomm_sequence(ji,1)*ncomm_sequence(ji,2))
181               END DO
182               WRITE(numout,'(A,I3)') ' 3D Exchanged halos : ', jk
183               WRITE(numout,'(A,I3)') ' Multi arrays exchanged halos : ', jf
184               WRITE(numout,'(A,I3)') '   from which 3D : ', jj
185               WRITE(numout,'(A,I10)') ' Array max size : ', jh*jpi*jpj
186               WRITE(numout,*) ' '
187               WRITE(numout,*) ' lbc_lnk called'
188               jj = 1
189               DO ji = 2, n_sequence
190                  IF( crname(ji-1) /= crname(ji) ) THEN
191                    WRITE(numout,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname(ji-1))
192                    jj = 0
193                  END IF
194                  jj = jj + 1 
195               END DO
196               WRITE(numout,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname(n_sequence))
197               WRITE(numout,*) ' '
198               WRITE(numout,*) ' -----------------------------------------------'
199               WRITE(numout,*) ' '
200               DEALLOCATE(ncomm_sequence)
201               DEALLOCATE(crname)
202               l_comm_report_done = .TRUE.
203            ENDIF
204         ENDIF
205      ENDIF
206      !
207      IF( ln_timing ) CALL tic_tac(.TRUE.)
208      !
209      SELECT CASE ( nbondi )
210      CASE ( -1 )
211         CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req1 )
212         CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea )
213         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err)
214      CASE ( 0 )
215         CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 )
216         CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req2 )
217         CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea )
218         CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe )
219         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err)
220         IF(l_isend)   CALL mpi_wait(ml_req2, ml_stat, ml_err)
221      CASE ( 1 )
222         CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 )
223         CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe )
224         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err )
225      END SELECT
226      !
227      IF( ln_timing ) CALL tic_tac(.FALSE.)
228      !
229      !
230      !                           ! Write Dirichlet lateral conditions
231      iihom = nlci-nn_hls
232      !
233      SELECT CASE ( nbondi )
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(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)
240                  END DO
241               END DO
242            END DO
243         END DO
244      CASE ( 0 )
245         DO jf = 1, ipf
246            DO jl = 1, ipl
247               DO jk = 1, ipk
248                  DO jh = 1, nn_hls
249                     ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)
250                     ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)
251                  END DO
252               END DO
253            END DO
254         END DO
255      CASE ( 1 )
256         DO jf = 1, ipf
257            DO jl = 1, ipl
258               DO jk = 1, ipk
259                  DO jh = 1, nn_hls
260                     ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)
261                  END DO
262               END DO
263            END DO
264         END DO
265      END SELECT
266
267      ! 3. North and south directions
268      ! -----------------------------
269      ! always closed : we play only with the neigbours
270      !
271      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
272         ijhom = nlcj-nrecj
273         DO jf = 1, ipf
274            DO jl = 1, ipl
275               DO jk = 1, ipk
276                  DO jh = 1, nn_hls
277                     zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf)
278                     zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf)
279                  END DO
280               END DO
281            END DO
282         END DO
283      ENDIF
284      !
285      !                           ! Migrations
286      imigr = nn_hls * jpi * ipk * ipl * ipf
287      !
288      IF( ln_timing ) CALL tic_tac(.TRUE.)
289      !
290      SELECT CASE ( nbondj )
291      CASE ( -1 )
292         CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req1 )
293         CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono )
294         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
295      CASE ( 0 )
296         CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
297         CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req2 )
298         CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono )
299         CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso )
300         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err )
301         IF(l_isend)   CALL mpi_wait(ml_req2, ml_stat, ml_err )
302      CASE ( 1 )
303         CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
304         CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso )
305         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err )
306      END SELECT
307      !
308      IF( ln_timing ) CALL tic_tac(.FALSE.)
309      !                           ! Write Dirichlet lateral conditions
310      ijhom = nlcj-nn_hls
311      !
312      SELECT CASE ( nbondj )
313      CASE ( -1 )
314         DO jf = 1, ipf
315            DO jl = 1, ipl
316               DO jk = 1, ipk
317                  DO jh = 1, nn_hls
318                     ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2)
319                  END DO
320               END DO
321            END DO
322         END DO
323      CASE ( 0 )
324         DO jf = 1, ipf
325            DO jl = 1, ipl
326               DO jk = 1, ipk
327                  DO jh = 1, nn_hls
328                     ARRAY_IN(:,      jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2)
329                     ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2)
330                  END DO
331               END DO
332            END DO
333         END DO
334      CASE ( 1 )
335         DO jf = 1, ipf
336            DO jl = 1, ipl
337               DO jk = 1, ipk
338                  DO jh = 1, nn_hls
339                     ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2)
340                  END DO
341               END DO
342            END DO
343         END DO
344      END SELECT
345
346      ! 4. north fold treatment
347      ! -----------------------
348      !
349      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
350         !
351         SELECT CASE ( jpni )
352         CASE ( 1 )     ;   CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! only 1 northern proc, no mpp
353         CASE DEFAULT   ;   CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! for all northern procs.
354         END SELECT
355         !
356      ENDIF
357      !
358      DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we )
359      !
360   END SUBROUTINE ROUTINE_LNK
361
362#undef ARRAY_TYPE
363#undef NAT_IN
364#undef SGN_IN
365#undef ARRAY_IN
366#undef K_SIZE
367#undef L_SIZE
368#undef F_SIZE
369#undef OPT_K
Note: See TracBrowser for help on using the repository browser.