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

Last change on this file since 10297 was 10297, checked in by smasson, 23 months ago

dev_r10164_HPC09_ESIWACE_PREP_MERGE: action 2a: add report calls of mppmin/max/sum, see #2133

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