source: NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/LBC/lib_mpp.F90 @ 11317

Last change on this file since 11317 was 11317, checked in by smasson, 2 years ago

dev_r10984_HPC-13 : improve error handling, see #2307 and #2285

  • Property svn:keywords set to Id
File size: 56.3 KB
Line 
1MODULE lib_mpp
2   !!======================================================================
3   !!                       ***  MODULE  lib_mpp  ***
4   !! Ocean numerics:  massively parallel processing library
5   !!=====================================================================
6   !! History :  OPA  !  1994  (M. Guyon, J. Escobar, M. Imbard)  Original code
7   !!            7.0  !  1997  (A.M. Treguier)  SHMEM additions
8   !!            8.0  !  1998  (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
9   !!                 !  1998  (J.M. Molines) Open boundary conditions
10   !!   NEMO     1.0  !  2003  (J.M. Molines, G. Madec)  F90, free form
11   !!                 !  2003  (J.M. Molines) add mpp_ini_north(_3d,_2d)
12   !!             -   !  2004  (R. Bourdalle Badie)  isend option in mpi
13   !!                 !  2004  (J.M. Molines) minloc, maxloc
14   !!             -   !  2005  (G. Madec, S. Masson)  npolj=5,6 F-point & ice cases
15   !!             -   !  2005  (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort
16   !!             -   !  2005  (R. Benshila, G. Madec)  add extra halo case
17   !!             -   !  2008  (R. Benshila) add mpp_ini_ice
18   !!            3.2  !  2009  (R. Benshila) SHMEM suppression, north fold in lbc_nfd
19   !!            3.2  !  2009  (O. Marti)    add mpp_ini_znl
20   !!            4.0  !  2011  (G. Madec)  move ctl_ routines from in_out_manager
21   !!            3.5  !  2012  (S.Mocavero, I. Epicoco) Add mpp_lnk_bdy_3d/2d routines to optimize the BDY comm.
22   !!            3.5  !  2013  (C. Ethe, G. Madec)  message passing arrays as local variables
23   !!            3.5  !  2013  (S.Mocavero, I.Epicoco - CMCC) north fold optimizations
24   !!            3.6  !  2015  (O. Tintó and M. Castrillo - BSC) Added '_multiple' case for 2D lbc and max
25   !!            4.0  !  2017  (G. Madec) automatique allocation of array argument (use any 3rd dimension)
26   !!             -   !  2017  (G. Madec) create generic.h90 files to generate all lbc and north fold routines
27   !!----------------------------------------------------------------------
28
29   !!----------------------------------------------------------------------
30   !!   ctl_stop      : update momentum and tracer Kz from a tke scheme
31   !!   ctl_warn      : initialization, namelist read, and parameters control
32   !!   ctl_opn       : Open file and check if required file is available.
33   !!   ctl_nam       : Prints informations when an error occurs while reading a namelist
34   !!----------------------------------------------------------------------
35   !!----------------------------------------------------------------------
36   !!   mpp_start     : get local communicator its size and rank
37   !!   mpp_lnk       : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d)
38   !!   mpp_lnk_icb   : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb)
39   !!   mpprecv       :
40   !!   mppsend       :
41   !!   mppscatter    :
42   !!   mppgather     :
43   !!   mpp_min       : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
44   !!   mpp_max       : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
45   !!   mpp_sum       : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
46   !!   mpp_minloc    :
47   !!   mpp_maxloc    :
48   !!   mppsync       :
49   !!   mppstop       :
50   !!   mpp_ini_north : initialisation of north fold
51   !!   mpp_lbc_north_icb : alternative to mpp_nfd for extra outer halo with icebergs
52   !!----------------------------------------------------------------------
53   USE dom_oce        ! ocean space and time domain
54   USE in_out_manager ! I/O manager
55
56   IMPLICIT NONE
57   PRIVATE
58   !
59   PUBLIC   ctl_stop, ctl_warn, ctl_opn, ctl_nam
60   PUBLIC   mpp_start, mppstop, mppsync, mpp_comm_free
61   PUBLIC   mpp_ini_north
62   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc
63   PUBLIC   mpp_delay_max, mpp_delay_sum, mpp_delay_rcv
64   PUBLIC   mppscatter, mppgather
65   PUBLIC   mpp_ini_znl
66   PUBLIC   mppsend, mpprecv                          ! needed by TAM and ICB routines
67   PUBLIC   mpp_report
68   PUBLIC   tic_tac
69   
70   !! * Interfaces
71   !! define generic interface for these routine as they are called sometimes
72   !! with scalar arguments instead of array arguments, which causes problems
73   !! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
74   INTERFACE mpp_min
75      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
76   END INTERFACE
77   INTERFACE mpp_max
78      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
79   END INTERFACE
80   INTERFACE mpp_sum
81      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real,   &
82         &             mppsum_realdd, mppsum_a_realdd
83   END INTERFACE
84   INTERFACE mpp_minloc
85      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
86   END INTERFACE
87   INTERFACE mpp_maxloc
88      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
89   END INTERFACE
90
91   !! ========================= !!
92   !!  MPI  variable definition !!
93   !! ========================= !!
94#if   defined key_mpp_mpi
95!$AGRIF_DO_NOT_TREAT
96   INCLUDE 'mpif.h'
97!$AGRIF_END_DO_NOT_TREAT
98   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .TRUE.    !: mpp flag
99#else   
100   INTEGER, PUBLIC, PARAMETER ::   MPI_STATUS_SIZE = 1
101   INTEGER, PUBLIC, PARAMETER ::   MPI_DOUBLE_PRECISION = 8
102   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.    !: mpp flag
103#endif
104
105   INTEGER, PARAMETER         ::   nprocmax = 2**10   ! maximun dimension (required to be a power of 2)
106
107   INTEGER, PUBLIC ::   mppsize        ! number of process
108   INTEGER, PUBLIC ::   mpprank        ! process number  [ 0 - size-1 ]
109!$AGRIF_DO_NOT_TREAT
110   INTEGER, PUBLIC ::   mpi_comm_oce   ! opa local communicator
111!$AGRIF_END_DO_NOT_TREAT
112
113   INTEGER :: MPI_SUMDD
114
115   ! variables used for zonal integration
116   INTEGER, PUBLIC ::   ncomm_znl       !: communicator made by the processors on the same zonal average
117   LOGICAL, PUBLIC ::   l_znl_root      !: True on the 'left'most processor on the same row
118   INTEGER         ::   ngrp_znl        !  group ID for the znl processors
119   INTEGER         ::   ndim_rank_znl   !  number of processors on the same zonal average
120   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_znl  ! dimension ndim_rank_znl, number of the procs into the same znl domain
121
122   ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM)
123   INTEGER, PUBLIC ::   ngrp_world        !: group ID for the world processors
124   INTEGER, PUBLIC ::   ngrp_opa          !: group ID for the opa processors
125   INTEGER, PUBLIC ::   ngrp_north        !: group ID for the northern processors (to be fold)
126   INTEGER, PUBLIC ::   ncomm_north       !: communicator made by the processors belonging to ngrp_north
127   INTEGER, PUBLIC ::   ndim_rank_north   !: number of 'sea' processor in the northern line (can be /= jpni !)
128   INTEGER, PUBLIC ::   njmppmax          !: value of njmpp for the processors of the northern line
129   INTEGER, PUBLIC ::   north_root        !: number (in the comm_opa) of proc 0 in the northern comm
130   INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_north   !: dimension ndim_rank_north
131
132   ! Communications summary report
133   CHARACTER(len=128), DIMENSION(:), ALLOCATABLE ::   crname_lbc                   !: names of lbc_lnk calling routines
134   CHARACTER(len=128), DIMENSION(:), ALLOCATABLE ::   crname_glb                   !: names of global comm calling routines
135   CHARACTER(len=128), DIMENSION(:), ALLOCATABLE ::   crname_dlg                   !: names of delayed global comm calling routines
136   INTEGER, PUBLIC                               ::   ncom_stp = 0                 !: copy of time step # istp
137   INTEGER, PUBLIC                               ::   ncom_fsbc = 1                !: copy of sbc time step # nn_fsbc
138   INTEGER, PUBLIC                               ::   ncom_dttrc = 1               !: copy of top time step # nn_dttrc
139   INTEGER, PUBLIC                               ::   ncom_freq                    !: frequency of comm diagnostic
140   INTEGER, PUBLIC , DIMENSION(:,:), ALLOCATABLE ::   ncomm_sequence               !: size of communicated arrays (halos)
141   INTEGER, PARAMETER, PUBLIC                    ::   ncom_rec_max = 5000          !: max number of communication record
142   INTEGER, PUBLIC                               ::   n_sequence_lbc = 0           !: # of communicated arraysvia lbc
143   INTEGER, PUBLIC                               ::   n_sequence_glb = 0           !: # of global communications
144   INTEGER, PUBLIC                               ::   n_sequence_dlg = 0           !: # of delayed global communications
145   INTEGER, PUBLIC                               ::   numcom = -1                  !: logical unit for communicaton report
146   LOGICAL, PUBLIC                               ::   l_full_nf_update = .TRUE.    !: logical for a full (2lines) update of bc at North fold report
147   INTEGER,                    PARAMETER, PUBLIC ::   nbdelay = 2       !: number of delayed operations
148   !: name (used as id) of allreduce-delayed operations
149   ! Warning: we must use the same character length in an array constructor (at least for gcc compiler)
150   CHARACTER(len=32), DIMENSION(nbdelay), PUBLIC ::   c_delaylist = (/ 'cflice', 'fwb   ' /)
151   !: component name where the allreduce-delayed operation is performed
152   CHARACTER(len=3),  DIMENSION(nbdelay), PUBLIC ::   c_delaycpnt = (/ 'ICE'   , 'OCE' /)
153   TYPE, PUBLIC ::   DELAYARR
154      REAL(   wp), POINTER, DIMENSION(:) ::  z1d => NULL()
155      COMPLEX(wp), POINTER, DIMENSION(:) ::  y1d => NULL()
156   END TYPE DELAYARR
157   TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC, SAVE  ::   todelay         !: must have SAVE for default initialization of DELAYARR
158   INTEGER,          DIMENSION(nbdelay), PUBLIC        ::   ndelayid = -1   !: mpi request id of the delayed operations
159
160   ! timing summary report
161   REAL(wp), DIMENSION(2), PUBLIC ::  waiting_time = 0._wp
162   REAL(wp)              , PUBLIC ::  compute_time = 0._wp, elapsed_time = 0._wp
163   
164   REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::   tampon   ! buffer in case of bsend
165
166   LOGICAL, PUBLIC ::   ln_nnogather                !: namelist control of northfold comms
167   LOGICAL, PUBLIC ::   l_north_nogather = .FALSE.  !: internal control of northfold comms
168   
169   !!----------------------------------------------------------------------
170   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
171   !! $Id$
172   !! Software governed by the CeCILL license (see ./LICENSE)
173   !!----------------------------------------------------------------------
174CONTAINS
175
176   SUBROUTINE mpp_start( localComm )
177      !!----------------------------------------------------------------------
178      !!                  ***  routine mpp_start  ***
179      !!
180      !! ** Purpose :   get mpi_comm_oce, mpprank and mppsize
181      !!----------------------------------------------------------------------
182      INTEGER         , OPTIONAL   , INTENT(in   ) ::   localComm    !
183      !
184      INTEGER ::   ierr
185      LOGICAL ::   llmpi_init
186      !!----------------------------------------------------------------------
187#if defined key_mpp_mpi
188      !
189      CALL mpi_initialized ( llmpi_init, ierr )
190      IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_initialized' )
191
192      IF( .NOT. llmpi_init ) THEN
193         IF( PRESENT(localComm) ) THEN
194            WRITE(ctmp1,*) ' lib_mpp: You cannot provide a local communicator '
195            WRITE(ctmp2,*) '          without calling MPI_Init before ! '
196            CALL ctl_stop( 'STOP', ctmp1, ctmp2 )
197         ENDIF
198         CALL mpi_init( ierr )
199         IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_init' )
200      ENDIF
201       
202      IF( PRESENT(localComm) ) THEN
203         IF( Agrif_Root() ) THEN
204            mpi_comm_oce = localComm
205         ENDIF
206      ELSE
207         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, ierr)
208         IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_comm_dup' )
209      ENDIF
210
211# if defined key_agrif
212      IF( Agrif_Root() ) THEN
213         CALL Agrif_MPI_Init(mpi_comm_oce)
214      ELSE
215         CALL Agrif_MPI_set_grid_comm(mpi_comm_oce)
216      ENDIF
217# endif
218
219      CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr )
220      CALL mpi_comm_size( mpi_comm_oce, mppsize, ierr )
221      !
222      CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr)
223      !
224#else
225      IF( PRESENT( localComm ) ) mpi_comm_oce = localComm
226      mppsize = 1
227      mpprank = 0
228#endif
229   END SUBROUTINE mpp_start
230
231
232   SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
233      !!----------------------------------------------------------------------
234      !!                  ***  routine mppsend  ***
235      !!
236      !! ** Purpose :   Send messag passing array
237      !!
238      !!----------------------------------------------------------------------
239      REAL(wp), INTENT(inout) ::   pmess(*)   ! array of real
240      INTEGER , INTENT(in   ) ::   kbytes     ! size of the array pmess
241      INTEGER , INTENT(in   ) ::   kdest      ! receive process number
242      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message
243      INTEGER , INTENT(in   ) ::   md_req     ! argument for isend
244      !!
245      INTEGER ::   iflag
246      !!----------------------------------------------------------------------
247      !
248#if defined key_mpp_mpi
249      CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag )
250#endif
251      !
252   END SUBROUTINE mppsend
253
254
255   SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource )
256      !!----------------------------------------------------------------------
257      !!                  ***  routine mpprecv  ***
258      !!
259      !! ** Purpose :   Receive messag passing array
260      !!
261      !!----------------------------------------------------------------------
262      REAL(wp), INTENT(inout) ::   pmess(*)   ! array of real
263      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess
264      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message
265      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number
266      !!
267      INTEGER :: istatus(mpi_status_size)
268      INTEGER :: iflag
269      INTEGER :: use_source
270      !!----------------------------------------------------------------------
271      !
272#if defined key_mpp_mpi
273      ! If a specific process number has been passed to the receive call,
274      ! use that one. Default is to use mpi_any_source
275      use_source = mpi_any_source
276      IF( PRESENT(ksource) )   use_source = ksource
277      !
278      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag )
279#endif
280      !
281   END SUBROUTINE mpprecv
282
283
284   SUBROUTINE mppgather( ptab, kp, pio )
285      !!----------------------------------------------------------------------
286      !!                   ***  routine mppgather  ***
287      !!
288      !! ** Purpose :   Transfert between a local subdomain array and a work
289      !!     array which is distributed following the vertical level.
290      !!
291      !!----------------------------------------------------------------------
292      REAL(wp), DIMENSION(jpi,jpj)      , INTENT(in   ) ::   ptab   ! subdomain input array
293      INTEGER                           , INTENT(in   ) ::   kp     ! record length
294      REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT(  out) ::   pio    ! subdomain input array
295      !!
296      INTEGER :: itaille, ierror   ! temporary integer
297      !!---------------------------------------------------------------------
298      !
299      itaille = jpi * jpj
300#if defined key_mpp_mpi
301      CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille     ,   &
302         &                            mpi_double_precision, kp , mpi_comm_oce, ierror )
303#else
304      pio(:,:,1) = ptab(:,:)
305#endif
306      !
307   END SUBROUTINE mppgather
308
309
310   SUBROUTINE mppscatter( pio, kp, ptab )
311      !!----------------------------------------------------------------------
312      !!                  ***  routine mppscatter  ***
313      !!
314      !! ** Purpose :   Transfert between awork array which is distributed
315      !!      following the vertical level and the local subdomain array.
316      !!
317      !!----------------------------------------------------------------------
318      REAL(wp), DIMENSION(jpi,jpj,jpnij)  ::   pio    ! output array
319      INTEGER                             ::   kp     ! Tag (not used with MPI
320      REAL(wp), DIMENSION(jpi,jpj)        ::   ptab   ! subdomain array input
321      !!
322      INTEGER :: itaille, ierror   ! temporary integer
323      !!---------------------------------------------------------------------
324      !
325      itaille = jpi * jpj
326      !
327#if defined key_mpp_mpi
328      CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille     ,   &
329         &                            mpi_double_precision, kp  , mpi_comm_oce, ierror )
330#else
331      ptab(:,:) = pio(:,:,1)
332#endif
333      !
334   END SUBROUTINE mppscatter
335
336   
337   SUBROUTINE mpp_delay_sum( cdname, cdelay, y_in, pout, ldlast, kcom )
338     !!----------------------------------------------------------------------
339      !!                   ***  routine mpp_delay_sum  ***
340      !!
341      !! ** Purpose :   performed delayed mpp_sum, the result is received on next call
342      !!
343      !!----------------------------------------------------------------------
344      CHARACTER(len=*), INTENT(in   )               ::   cdname  ! name of the calling subroutine
345      CHARACTER(len=*), INTENT(in   )               ::   cdelay  ! name (used as id) of the delayed operation
346      COMPLEX(wp),      INTENT(in   ), DIMENSION(:) ::   y_in
347      REAL(wp),         INTENT(  out), DIMENSION(:) ::   pout
348      LOGICAL,          INTENT(in   )               ::   ldlast  ! true if this is the last time we call this routine
349      INTEGER,          INTENT(in   ), OPTIONAL     ::   kcom
350      !!
351      INTEGER ::   ji, isz
352      INTEGER ::   idvar
353      INTEGER ::   ierr, ilocalcomm
354      COMPLEX(wp), ALLOCATABLE, DIMENSION(:) ::   ytmp
355      !!----------------------------------------------------------------------
356#if defined key_mpp_mpi
357      ilocalcomm = mpi_comm_oce
358      IF( PRESENT(kcom) )   ilocalcomm = kcom
359
360      isz = SIZE(y_in)
361     
362      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_dlg = .TRUE. )
363
364      idvar = -1
365      DO ji = 1, nbdelay
366         IF( TRIM(cdelay) == TRIM(c_delaylist(ji)) ) idvar = ji
367      END DO
368      IF ( idvar == -1 )   CALL ctl_stop( 'STOP',' mpp_delay_sum : please add a new delayed exchange for '//TRIM(cdname) )
369
370      IF ( ndelayid(idvar) == 0 ) THEN         ! first call    with restart: %z1d defined in iom_delay_rst
371         !                                       --------------------------
372         IF ( SIZE(todelay(idvar)%z1d) /= isz ) THEN                  ! Check dimension coherence
373            IF(lwp) WRITE(numout,*) ' WARNING: the nb of delayed variables in restart file is not the model one'
374            DEALLOCATE(todelay(idvar)%z1d)
375            ndelayid(idvar) = -1                                      ! do as if we had no restart
376         ELSE
377            ALLOCATE(todelay(idvar)%y1d(isz))
378            todelay(idvar)%y1d(:) = CMPLX(todelay(idvar)%z1d(:), 0., wp)   ! create %y1d, complex variable needed by mpi_sumdd
379         END IF
380      ENDIF
381     
382      IF( ndelayid(idvar) == -1 ) THEN         ! first call without restart: define %y1d and %z1d from y_in with blocking allreduce
383         !                                       --------------------------
384         ALLOCATE(todelay(idvar)%z1d(isz), todelay(idvar)%y1d(isz))   ! allocate also %z1d as used for the restart
385         CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr )   ! get %y1d
386         todelay(idvar)%z1d(:) = REAL(todelay(idvar)%y1d(:), wp)      ! define %z1d from %y1d
387      ENDIF
388
389      IF( ndelayid(idvar) > 0 )   CALL mpp_delay_rcv( idvar )         ! make sure %z1d is received
390
391      ! send back pout from todelay(idvar)%z1d defined at previous call
392      pout(:) = todelay(idvar)%z1d(:)
393
394      ! send y_in into todelay(idvar)%y1d with a non-blocking communication
395# if defined key_mpi2
396      IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.)
397      CALL  mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr )
398      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
399# else
400      CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr )
401# endif
402#else
403      pout(:) = REAL(y_in(:), wp)
404#endif
405
406   END SUBROUTINE mpp_delay_sum
407
408   
409   SUBROUTINE mpp_delay_max( cdname, cdelay, p_in, pout, ldlast, kcom )
410      !!----------------------------------------------------------------------
411      !!                   ***  routine mpp_delay_max  ***
412      !!
413      !! ** Purpose :   performed delayed mpp_max, the result is received on next call
414      !!
415      !!----------------------------------------------------------------------
416      CHARACTER(len=*), INTENT(in   )                 ::   cdname  ! name of the calling subroutine
417      CHARACTER(len=*), INTENT(in   )                 ::   cdelay  ! name (used as id) of the delayed operation
418      REAL(wp),         INTENT(in   ), DIMENSION(:)   ::   p_in    !
419      REAL(wp),         INTENT(  out), DIMENSION(:)   ::   pout    !
420      LOGICAL,          INTENT(in   )                 ::   ldlast  ! true if this is the last time we call this routine
421      INTEGER,          INTENT(in   ), OPTIONAL       ::   kcom
422      !!
423      INTEGER ::   ji, isz
424      INTEGER ::   idvar
425      INTEGER ::   ierr, ilocalcomm
426      !!----------------------------------------------------------------------
427#if defined key_mpp_mpi
428      ilocalcomm = mpi_comm_oce
429      IF( PRESENT(kcom) )   ilocalcomm = kcom
430
431      isz = SIZE(p_in)
432
433      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_dlg = .TRUE. )
434
435      idvar = -1
436      DO ji = 1, nbdelay
437         IF( TRIM(cdelay) == TRIM(c_delaylist(ji)) ) idvar = ji
438      END DO
439      IF ( idvar == -1 )   CALL ctl_stop( 'STOP',' mpp_delay_max : please add a new delayed exchange for '//TRIM(cdname) )
440
441      IF ( ndelayid(idvar) == 0 ) THEN         ! first call    with restart: %z1d defined in iom_delay_rst
442         !                                       --------------------------
443         IF ( SIZE(todelay(idvar)%z1d) /= isz ) THEN                  ! Check dimension coherence
444            IF(lwp) WRITE(numout,*) ' WARNING: the nb of delayed variables in restart file is not the model one'
445            DEALLOCATE(todelay(idvar)%z1d)
446            ndelayid(idvar) = -1                                      ! do as if we had no restart
447         END IF
448      ENDIF
449
450      IF( ndelayid(idvar) == -1 ) THEN         ! first call without restart: define %z1d from p_in with a blocking allreduce
451         !                                       --------------------------
452         ALLOCATE(todelay(idvar)%z1d(isz))
453         CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ierr )   ! get %z1d
454      ENDIF
455
456      IF( ndelayid(idvar) > 0 )   CALL mpp_delay_rcv( idvar )         ! make sure %z1d is received
457
458      ! send back pout from todelay(idvar)%z1d defined at previous call
459      pout(:) = todelay(idvar)%z1d(:)
460
461      ! send p_in into todelay(idvar)%z1d with a non-blocking communication
462# if defined key_mpi2
463      IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.)
464      CALL  mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr )
465      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
466# else
467      CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr )
468# endif
469#else
470      pout(:) = p_in(:)
471#endif
472
473   END SUBROUTINE mpp_delay_max
474
475   
476   SUBROUTINE mpp_delay_rcv( kid )
477      !!----------------------------------------------------------------------
478      !!                   ***  routine mpp_delay_rcv  ***
479      !!
480      !! ** Purpose :  force barrier for delayed mpp (needed for restart)
481      !!
482      !!----------------------------------------------------------------------
483      INTEGER,INTENT(in   )      ::  kid 
484      INTEGER ::   ierr
485      !!----------------------------------------------------------------------
486#if defined key_mpp_mpi
487      IF( ndelayid(kid) /= -2 ) THEN 
488#if ! defined key_mpi2
489         IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.)
490         CALL mpi_wait( ndelayid(kid), MPI_STATUS_IGNORE, ierr )                        ! make sure todelay(kid) is received
491         IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
492#endif
493         IF( ASSOCIATED(todelay(kid)%y1d) )   todelay(kid)%z1d(:) = REAL(todelay(kid)%y1d(:), wp)  ! define %z1d from %y1d
494         ndelayid(kid) = -2   ! add flag to know that mpi_wait was already called on kid
495      ENDIF
496#endif
497   END SUBROUTINE mpp_delay_rcv
498
499   
500   !!----------------------------------------------------------------------
501   !!    ***  mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real  ***
502   !!   
503   !!----------------------------------------------------------------------
504   !!
505#  define OPERATION_MAX
506#  define INTEGER_TYPE
507#  define DIM_0d
508#     define ROUTINE_ALLREDUCE           mppmax_int
509#     include "mpp_allreduce_generic.h90"
510#     undef ROUTINE_ALLREDUCE
511#  undef DIM_0d
512#  define DIM_1d
513#     define ROUTINE_ALLREDUCE           mppmax_a_int
514#     include "mpp_allreduce_generic.h90"
515#     undef ROUTINE_ALLREDUCE
516#  undef DIM_1d
517#  undef INTEGER_TYPE
518!
519#  define REAL_TYPE
520#  define DIM_0d
521#     define ROUTINE_ALLREDUCE           mppmax_real
522#     include "mpp_allreduce_generic.h90"
523#     undef ROUTINE_ALLREDUCE
524#  undef DIM_0d
525#  define DIM_1d
526#     define ROUTINE_ALLREDUCE           mppmax_a_real
527#     include "mpp_allreduce_generic.h90"
528#     undef ROUTINE_ALLREDUCE
529#  undef DIM_1d
530#  undef REAL_TYPE
531#  undef OPERATION_MAX
532   !!----------------------------------------------------------------------
533   !!    ***  mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real  ***
534   !!   
535   !!----------------------------------------------------------------------
536   !!
537#  define OPERATION_MIN
538#  define INTEGER_TYPE
539#  define DIM_0d
540#     define ROUTINE_ALLREDUCE           mppmin_int
541#     include "mpp_allreduce_generic.h90"
542#     undef ROUTINE_ALLREDUCE
543#  undef DIM_0d
544#  define DIM_1d
545#     define ROUTINE_ALLREDUCE           mppmin_a_int
546#     include "mpp_allreduce_generic.h90"
547#     undef ROUTINE_ALLREDUCE
548#  undef DIM_1d
549#  undef INTEGER_TYPE
550!
551#  define REAL_TYPE
552#  define DIM_0d
553#     define ROUTINE_ALLREDUCE           mppmin_real
554#     include "mpp_allreduce_generic.h90"
555#     undef ROUTINE_ALLREDUCE
556#  undef DIM_0d
557#  define DIM_1d
558#     define ROUTINE_ALLREDUCE           mppmin_a_real
559#     include "mpp_allreduce_generic.h90"
560#     undef ROUTINE_ALLREDUCE
561#  undef DIM_1d
562#  undef REAL_TYPE
563#  undef OPERATION_MIN
564
565   !!----------------------------------------------------------------------
566   !!    ***  mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real  ***
567   !!   
568   !!   Global sum of 1D array or a variable (integer, real or complex)
569   !!----------------------------------------------------------------------
570   !!
571#  define OPERATION_SUM
572#  define INTEGER_TYPE
573#  define DIM_0d
574#     define ROUTINE_ALLREDUCE           mppsum_int
575#     include "mpp_allreduce_generic.h90"
576#     undef ROUTINE_ALLREDUCE
577#  undef DIM_0d
578#  define DIM_1d
579#     define ROUTINE_ALLREDUCE           mppsum_a_int
580#     include "mpp_allreduce_generic.h90"
581#     undef ROUTINE_ALLREDUCE
582#  undef DIM_1d
583#  undef INTEGER_TYPE
584!
585#  define REAL_TYPE
586#  define DIM_0d
587#     define ROUTINE_ALLREDUCE           mppsum_real
588#     include "mpp_allreduce_generic.h90"
589#     undef ROUTINE_ALLREDUCE
590#  undef DIM_0d
591#  define DIM_1d
592#     define ROUTINE_ALLREDUCE           mppsum_a_real
593#     include "mpp_allreduce_generic.h90"
594#     undef ROUTINE_ALLREDUCE
595#  undef DIM_1d
596#  undef REAL_TYPE
597#  undef OPERATION_SUM
598
599#  define OPERATION_SUM_DD
600#  define COMPLEX_TYPE
601#  define DIM_0d
602#     define ROUTINE_ALLREDUCE           mppsum_realdd
603#     include "mpp_allreduce_generic.h90"
604#     undef ROUTINE_ALLREDUCE
605#  undef DIM_0d
606#  define DIM_1d
607#     define ROUTINE_ALLREDUCE           mppsum_a_realdd
608#     include "mpp_allreduce_generic.h90"
609#     undef ROUTINE_ALLREDUCE
610#  undef DIM_1d
611#  undef COMPLEX_TYPE
612#  undef OPERATION_SUM_DD
613
614   !!----------------------------------------------------------------------
615   !!    ***  mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d
616   !!   
617   !!----------------------------------------------------------------------
618   !!
619#  define OPERATION_MINLOC
620#  define DIM_2d
621#     define ROUTINE_LOC           mpp_minloc2d
622#     include "mpp_loc_generic.h90"
623#     undef ROUTINE_LOC
624#  undef DIM_2d
625#  define DIM_3d
626#     define ROUTINE_LOC           mpp_minloc3d
627#     include "mpp_loc_generic.h90"
628#     undef ROUTINE_LOC
629#  undef DIM_3d
630#  undef OPERATION_MINLOC
631
632#  define OPERATION_MAXLOC
633#  define DIM_2d
634#     define ROUTINE_LOC           mpp_maxloc2d
635#     include "mpp_loc_generic.h90"
636#     undef ROUTINE_LOC
637#  undef DIM_2d
638#  define DIM_3d
639#     define ROUTINE_LOC           mpp_maxloc3d
640#     include "mpp_loc_generic.h90"
641#     undef ROUTINE_LOC
642#  undef DIM_3d
643#  undef OPERATION_MAXLOC
644
645   SUBROUTINE mppsync()
646      !!----------------------------------------------------------------------
647      !!                  ***  routine mppsync  ***
648      !!
649      !! ** Purpose :   Massively parallel processors, synchroneous
650      !!
651      !!-----------------------------------------------------------------------
652      INTEGER :: ierror
653      !!-----------------------------------------------------------------------
654      !
655#if defined key_mpp_mpi
656      CALL mpi_barrier( mpi_comm_oce, ierror )
657#endif
658      !
659   END SUBROUTINE mppsync
660
661
662   SUBROUTINE mppstop( ldfinal, ld_force_abort ) 
663      !!----------------------------------------------------------------------
664      !!                  ***  routine mppstop  ***
665      !!
666      !! ** purpose :   Stop massively parallel processors method
667      !!
668      !!----------------------------------------------------------------------
669      LOGICAL, OPTIONAL, INTENT(in) :: ldfinal    ! source process number
670      LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort    ! source process number
671      LOGICAL ::   llfinal, ll_force_abort
672      INTEGER ::   info
673      !!----------------------------------------------------------------------
674      llfinal = .FALSE.
675      IF( PRESENT(ldfinal) ) llfinal = ldfinal
676      ll_force_abort = .FALSE.
677      IF( PRESENT(ld_force_abort) ) ll_force_abort = ld_force_abort
678      !
679#if defined key_mpp_mpi
680      IF(ll_force_abort) THEN
681         CALL mpi_abort( MPI_COMM_WORLD )
682      ELSE
683         CALL mppsync
684         CALL mpi_finalize( info )
685      ENDIF
686#endif
687      IF( .NOT. llfinal ) STOP 123
688      !
689   END SUBROUTINE mppstop
690
691
692   SUBROUTINE mpp_comm_free( kcom )
693      !!----------------------------------------------------------------------
694      INTEGER, INTENT(in) ::   kcom
695      !!
696      INTEGER :: ierr
697      !!----------------------------------------------------------------------
698      !
699#if defined key_mpp_mpi
700      CALL MPI_COMM_FREE(kcom, ierr)
701#endif
702      !
703   END SUBROUTINE mpp_comm_free
704
705
706   SUBROUTINE mpp_ini_znl( kumout )
707      !!----------------------------------------------------------------------
708      !!               ***  routine mpp_ini_znl  ***
709      !!
710      !! ** Purpose :   Initialize special communicator for computing zonal sum
711      !!
712      !! ** Method  : - Look for processors in the same row
713      !!              - Put their number in nrank_znl
714      !!              - Create group for the znl processors
715      !!              - Create a communicator for znl processors
716      !!              - Determine if processor should write znl files
717      !!
718      !! ** output
719      !!      ndim_rank_znl = number of processors on the same row
720      !!      ngrp_znl = group ID for the znl processors
721      !!      ncomm_znl = communicator for the ice procs.
722      !!      n_znl_root = number (in the world) of proc 0 in the ice comm.
723      !!
724      !!----------------------------------------------------------------------
725      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical units
726      !
727      INTEGER :: jproc      ! dummy loop integer
728      INTEGER :: ierr, ii   ! local integer
729      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kwork
730      !!----------------------------------------------------------------------
731#if defined key_mpp_mpi
732      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world     : ', ngrp_world
733      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
734      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_oce   : ', mpi_comm_oce
735      !
736      ALLOCATE( kwork(jpnij), STAT=ierr )
737      IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_ini_znl : failed to allocate 1D array of length jpnij')
738
739      IF( jpnj == 1 ) THEN
740         ngrp_znl  = ngrp_world
741         ncomm_znl = mpi_comm_oce
742      ELSE
743         !
744         CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_oce, ierr )
745         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
746         !-$$        CALL flush(numout)
747         !
748         ! Count number of processors on the same row
749         ndim_rank_znl = 0
750         DO jproc=1,jpnij
751            IF ( kwork(jproc) == njmpp ) THEN
752               ndim_rank_znl = ndim_rank_znl + 1
753            ENDIF
754         END DO
755         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
756         !-$$        CALL flush(numout)
757         ! Allocate the right size to nrank_znl
758         IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
759         ALLOCATE(nrank_znl(ndim_rank_znl))
760         ii = 0
761         nrank_znl (:) = 0
762         DO jproc=1,jpnij
763            IF ( kwork(jproc) == njmpp) THEN
764               ii = ii + 1
765               nrank_znl(ii) = jproc -1
766            ENDIF
767         END DO
768         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
769         !-$$        CALL flush(numout)
770
771         ! Create the opa group
772         CALL MPI_COMM_GROUP(mpi_comm_oce,ngrp_opa,ierr)
773         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
774         !-$$        CALL flush(numout)
775
776         ! Create the znl group from the opa group
777         CALL MPI_GROUP_INCL  ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
778         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
779         !-$$        CALL flush(numout)
780
781         ! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
782         CALL MPI_COMM_CREATE ( mpi_comm_oce, ngrp_znl, ncomm_znl, ierr )
783         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
784         !-$$        CALL flush(numout)
785         !
786      END IF
787
788      ! Determines if processor if the first (starting from i=1) on the row
789      IF ( jpni == 1 ) THEN
790         l_znl_root = .TRUE.
791      ELSE
792         l_znl_root = .FALSE.
793         kwork (1) = nimpp
794         CALL mpp_min ( 'lib_mpp', kwork(1), kcom = ncomm_znl)
795         IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
796      END IF
797
798      DEALLOCATE(kwork)
799#endif
800
801   END SUBROUTINE mpp_ini_znl
802
803
804   SUBROUTINE mpp_ini_north
805      !!----------------------------------------------------------------------
806      !!               ***  routine mpp_ini_north  ***
807      !!
808      !! ** Purpose :   Initialize special communicator for north folding
809      !!      condition together with global variables needed in the mpp folding
810      !!
811      !! ** Method  : - Look for northern processors
812      !!              - Put their number in nrank_north
813      !!              - Create groups for the world processors and the north processors
814      !!              - Create a communicator for northern processors
815      !!
816      !! ** output
817      !!      njmppmax = njmpp for northern procs
818      !!      ndim_rank_north = number of processors in the northern line
819      !!      nrank_north (ndim_rank_north) = number  of the northern procs.
820      !!      ngrp_world = group ID for the world processors
821      !!      ngrp_north = group ID for the northern processors
822      !!      ncomm_north = communicator for the northern procs.
823      !!      north_root = number (in the world) of proc 0 in the northern comm.
824      !!
825      !!----------------------------------------------------------------------
826      INTEGER ::   ierr
827      INTEGER ::   jjproc
828      INTEGER ::   ii, ji
829      !!----------------------------------------------------------------------
830      !
831#if defined key_mpp_mpi
832      njmppmax = MAXVAL( njmppt )
833      !
834      ! Look for how many procs on the northern boundary
835      ndim_rank_north = 0
836      DO jjproc = 1, jpnij
837         IF( njmppt(jjproc) == njmppmax )   ndim_rank_north = ndim_rank_north + 1
838      END DO
839      !
840      ! Allocate the right size to nrank_north
841      IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
842      ALLOCATE( nrank_north(ndim_rank_north) )
843
844      ! Fill the nrank_north array with proc. number of northern procs.
845      ! Note : the rank start at 0 in MPI
846      ii = 0
847      DO ji = 1, jpnij
848         IF ( njmppt(ji) == njmppmax   ) THEN
849            ii=ii+1
850            nrank_north(ii)=ji-1
851         END IF
852      END DO
853      !
854      ! create the world group
855      CALL MPI_COMM_GROUP( mpi_comm_oce, ngrp_world, ierr )
856      !
857      ! Create the North group from the world group
858      CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
859      !
860      ! Create the North communicator , ie the pool of procs in the north group
861      CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr )
862      !
863#endif
864   END SUBROUTINE mpp_ini_north
865
866
867   SUBROUTINE DDPDD_MPI( ydda, yddb, ilen, itype )
868      !!---------------------------------------------------------------------
869      !!   Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
870      !!
871      !!   Modification of original codes written by David H. Bailey
872      !!   This subroutine computes yddb(i) = ydda(i)+yddb(i)
873      !!---------------------------------------------------------------------
874      INTEGER                     , INTENT(in)    ::   ilen, itype
875      COMPLEX(wp), DIMENSION(ilen), INTENT(in)    ::   ydda
876      COMPLEX(wp), DIMENSION(ilen), INTENT(inout) ::   yddb
877      !
878      REAL(wp) :: zerr, zt1, zt2    ! local work variables
879      INTEGER  :: ji, ztmp           ! local scalar
880      !!---------------------------------------------------------------------
881      !
882      ztmp = itype   ! avoid compilation warning
883      !
884      DO ji=1,ilen
885      ! Compute ydda + yddb using Knuth's trick.
886         zt1  = real(ydda(ji)) + real(yddb(ji))
887         zerr = zt1 - real(ydda(ji))
888         zt2  = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
889                + aimag(ydda(ji)) + aimag(yddb(ji))
890
891         ! The result is zt1 + zt2, after normalization.
892         yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
893      END DO
894      !
895   END SUBROUTINE DDPDD_MPI
896
897
898   SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb, ld_dlg )
899      !!----------------------------------------------------------------------
900      !!                  ***  routine mpp_report  ***
901      !!
902      !! ** Purpose :   report use of mpp routines per time-setp
903      !!
904      !!----------------------------------------------------------------------
905      CHARACTER(len=*),           INTENT(in   ) ::   cdname      ! name of the calling subroutine
906      INTEGER         , OPTIONAL, INTENT(in   ) ::   kpk, kpl, kpf
907      LOGICAL         , OPTIONAL, INTENT(in   ) ::   ld_lbc, ld_glb, ld_dlg
908      !!
909      CHARACTER(len=128)                        ::   ccountname  ! name of a subroutine to count communications
910      LOGICAL ::   ll_lbc, ll_glb, ll_dlg
911      INTEGER ::    ji,  jj,  jk,  jh, jf, jcount   ! dummy loop indices
912      !!----------------------------------------------------------------------
913#if defined key_mpp_mpi
914      !
915      ll_lbc = .FALSE.
916      IF( PRESENT(ld_lbc) ) ll_lbc = ld_lbc
917      ll_glb = .FALSE.
918      IF( PRESENT(ld_glb) ) ll_glb = ld_glb
919      ll_dlg = .FALSE.
920      IF( PRESENT(ld_dlg) ) ll_dlg = ld_dlg
921      !
922      ! find the smallest common frequency: default = frequency product, if multiple, choose the larger of the 2 frequency
923      IF( ncom_dttrc /= 1 )   CALL ctl_stop( 'STOP', 'mpp_report, ncom_dttrc /= 1 not coded...' ) 
924      ncom_freq = ncom_fsbc
925      !
926      IF ( ncom_stp == nit000+ncom_freq ) THEN   ! avoid to count extra communications in potential initializations at nit000
927         IF( ll_lbc ) THEN
928            IF( .NOT. ALLOCATED(ncomm_sequence) ) ALLOCATE( ncomm_sequence(ncom_rec_max,2) )
929            IF( .NOT. ALLOCATED(    crname_lbc) ) ALLOCATE(     crname_lbc(ncom_rec_max  ) )
930            n_sequence_lbc = n_sequence_lbc + 1
931            IF( n_sequence_lbc > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' )   ! deadlock
932            crname_lbc(n_sequence_lbc) = cdname     ! keep the name of the calling routine
933            ncomm_sequence(n_sequence_lbc,1) = kpk*kpl   ! size of 3rd and 4th dimensions
934            ncomm_sequence(n_sequence_lbc,2) = kpf       ! number of arrays to be treated (multi)
935         ENDIF
936         IF( ll_glb ) THEN
937            IF( .NOT. ALLOCATED(crname_glb) ) ALLOCATE( crname_glb(ncom_rec_max) )
938            n_sequence_glb = n_sequence_glb + 1
939            IF( n_sequence_glb > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' )   ! deadlock
940            crname_glb(n_sequence_glb) = cdname     ! keep the name of the calling routine
941         ENDIF
942         IF( ll_dlg ) THEN
943            IF( .NOT. ALLOCATED(crname_dlg) ) ALLOCATE( crname_dlg(ncom_rec_max) )
944            n_sequence_dlg = n_sequence_dlg + 1
945            IF( n_sequence_dlg > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' )   ! deadlock
946            crname_dlg(n_sequence_dlg) = cdname     ! keep the name of the calling routine
947         ENDIF
948      ELSE IF ( ncom_stp == nit000+2*ncom_freq ) THEN
949         CALL ctl_opn( numcom, 'communication_report.txt', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea )
950         WRITE(numcom,*) ' '
951         WRITE(numcom,*) ' ------------------------------------------------------------'
952         WRITE(numcom,*) ' Communication pattern report (second oce+sbc+top time step):'
953         WRITE(numcom,*) ' ------------------------------------------------------------'
954         WRITE(numcom,*) ' '
955         WRITE(numcom,'(A,I4)') ' Exchanged halos : ', n_sequence_lbc
956         jj = 0; jk = 0; jf = 0; jh = 0
957         DO ji = 1, n_sequence_lbc
958            IF ( ncomm_sequence(ji,1) .GT. 1 ) jk = jk + 1
959            IF ( ncomm_sequence(ji,2) .GT. 1 ) jf = jf + 1
960            IF ( ncomm_sequence(ji,1) .GT. 1 .AND. ncomm_sequence(ji,2) .GT. 1 ) jj = jj + 1
961            jh = MAX (jh, ncomm_sequence(ji,1)*ncomm_sequence(ji,2))
962         END DO
963         WRITE(numcom,'(A,I3)') ' 3D Exchanged halos : ', jk
964         WRITE(numcom,'(A,I3)') ' Multi arrays exchanged halos : ', jf
965         WRITE(numcom,'(A,I3)') '   from which 3D : ', jj
966         WRITE(numcom,'(A,I10)') ' Array max size : ', jh*jpi*jpj
967         WRITE(numcom,*) ' '
968         WRITE(numcom,*) ' lbc_lnk called'
969         DO ji = 1, n_sequence_lbc - 1
970            IF ( crname_lbc(ji) /= 'already counted' ) THEN
971               ccountname = crname_lbc(ji)
972               crname_lbc(ji) = 'already counted'
973               jcount = 1
974               DO jj = ji + 1, n_sequence_lbc
975                  IF ( ccountname ==  crname_lbc(jj) ) THEN
976                     jcount = jcount + 1
977                     crname_lbc(jj) = 'already counted'
978                  END IF
979               END DO
980               WRITE(numcom,'(A, I4, A, A)') ' - ', jcount,' times by subroutine ', TRIM(ccountname)
981            END IF
982         END DO
983         IF ( crname_lbc(n_sequence_lbc) /= 'already counted' ) THEN
984            WRITE(numcom,'(A, I4, A, A)') ' - ', 1,' times by subroutine ', TRIM(crname_lbc(ncom_rec_max))
985         END IF
986         WRITE(numcom,*) ' '
987         IF ( n_sequence_glb > 0 ) THEN
988            WRITE(numcom,'(A,I4)') ' Global communications : ', n_sequence_glb
989            jj = 1
990            DO ji = 2, n_sequence_glb
991               IF( crname_glb(ji-1) /= crname_glb(ji) ) THEN
992                  WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(ji-1))
993                  jj = 0
994               END IF
995               jj = jj + 1 
996            END DO
997            WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(n_sequence_glb))
998            DEALLOCATE(crname_glb)
999         ELSE
1000            WRITE(numcom,*) ' No MPI global communication '
1001         ENDIF
1002         WRITE(numcom,*) ' '
1003         IF ( n_sequence_dlg > 0 ) THEN
1004            WRITE(numcom,'(A,I4)') ' Delayed global communications : ', n_sequence_dlg
1005            jj = 1
1006            DO ji = 2, n_sequence_dlg
1007               IF( crname_dlg(ji-1) /= crname_dlg(ji) ) THEN
1008                  WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_dlg(ji-1))
1009                  jj = 0
1010               END IF
1011               jj = jj + 1 
1012            END DO
1013            WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_dlg(n_sequence_dlg))
1014            DEALLOCATE(crname_dlg)
1015         ELSE
1016            WRITE(numcom,*) ' No MPI delayed global communication '
1017         ENDIF
1018         WRITE(numcom,*) ' '
1019         WRITE(numcom,*) ' -----------------------------------------------'
1020         WRITE(numcom,*) ' '
1021         DEALLOCATE(ncomm_sequence)
1022         DEALLOCATE(crname_lbc)
1023      ENDIF
1024#endif
1025   END SUBROUTINE mpp_report
1026
1027   
1028   SUBROUTINE tic_tac (ld_tic, ld_global)
1029
1030    LOGICAL,           INTENT(IN) :: ld_tic
1031    LOGICAL, OPTIONAL, INTENT(IN) :: ld_global
1032    REAL(wp), DIMENSION(2), SAVE :: tic_wt
1033    REAL(wp),               SAVE :: tic_ct = 0._wp
1034    INTEGER :: ii
1035#if defined key_mpp_mpi
1036
1037    IF( ncom_stp <= nit000 ) RETURN
1038    IF( ncom_stp == nitend ) RETURN
1039    ii = 1
1040    IF( PRESENT( ld_global ) ) THEN
1041       IF( ld_global ) ii = 2
1042    END IF
1043   
1044    IF ( ld_tic ) THEN
1045       tic_wt(ii) = MPI_Wtime()                                                    ! start count tic->tac (waiting time)
1046       IF ( tic_ct > 0.0_wp ) compute_time = compute_time + MPI_Wtime() - tic_ct   ! cumulate count tac->tic
1047    ELSE
1048       waiting_time(ii) = waiting_time(ii) + MPI_Wtime() - tic_wt(ii)              ! cumulate count tic->tac
1049       tic_ct = MPI_Wtime()                                                        ! start count tac->tic (waiting time)
1050    ENDIF
1051#endif
1052   
1053   END SUBROUTINE tic_tac
1054
1055#if ! defined key_mpp_mpi
1056   SUBROUTINE mpi_wait(request, status, ierror)
1057      INTEGER                            , INTENT(in   ) ::   request
1058      INTEGER, DIMENSION(MPI_STATUS_SIZE), INTENT(  out) ::   status
1059      INTEGER                            , INTENT(  out) ::   ierror
1060   END SUBROUTINE mpi_wait
1061#endif
1062
1063   !!----------------------------------------------------------------------
1064   !!   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam   routines
1065   !!----------------------------------------------------------------------
1066
1067   SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 ,   &
1068      &                 cd6, cd7, cd8, cd9, cd10 )
1069      !!----------------------------------------------------------------------
1070      !!                  ***  ROUTINE  stop_opa  ***
1071      !!
1072      !! ** Purpose :   print in ocean.outpput file a error message and
1073      !!                increment the error number (nstop) by one.
1074      !!----------------------------------------------------------------------
1075      CHARACTER(len=*), INTENT(in   )           ::   cd1
1076      CHARACTER(len=*), INTENT(in   ), OPTIONAL ::        cd2, cd3, cd4, cd5
1077      CHARACTER(len=*), INTENT(in   ), OPTIONAL ::   cd6, cd7, cd8, cd9, cd10
1078      !!----------------------------------------------------------------------
1079      !
1080      nstop = nstop + 1
1081      !
1082      ! force to open ocean.output file if not already opened
1083      IF( numout == 6 ) CALL ctl_opn( numout, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
1084      !
1085                            WRITE(numout,*)
1086                            WRITE(numout,*) ' ===>>> : E R R O R'
1087                            WRITE(numout,*)
1088                            WRITE(numout,*) '         ==========='
1089                            WRITE(numout,*)
1090                            WRITE(numout,*) TRIM(cd1)
1091      IF( PRESENT(cd2 ) )   WRITE(numout,*) TRIM(cd2)
1092      IF( PRESENT(cd3 ) )   WRITE(numout,*) TRIM(cd3)
1093      IF( PRESENT(cd4 ) )   WRITE(numout,*) TRIM(cd4)
1094      IF( PRESENT(cd5 ) )   WRITE(numout,*) TRIM(cd5)
1095      IF( PRESENT(cd6 ) )   WRITE(numout,*) TRIM(cd6)
1096      IF( PRESENT(cd7 ) )   WRITE(numout,*) TRIM(cd7)
1097      IF( PRESENT(cd8 ) )   WRITE(numout,*) TRIM(cd8)
1098      IF( PRESENT(cd9 ) )   WRITE(numout,*) TRIM(cd9)
1099      IF( PRESENT(cd10) )   WRITE(numout,*) TRIM(cd10)
1100                            WRITE(numout,*)
1101      !
1102                               CALL FLUSH(numout    )
1103      IF( numstp     /= -1 )   CALL FLUSH(numstp    )
1104      IF( numrun     /= -1 )   CALL FLUSH(numrun    )
1105      IF( numevo_ice /= -1 )   CALL FLUSH(numevo_ice)
1106      !
1107      IF( cd1 == 'STOP' ) THEN
1108         WRITE(numout,*) 
1109         WRITE(numout,*)  'huge E-R-R-O-R : immediate stop'
1110         WRITE(numout,*) 
1111         CALL mppstop( ld_force_abort = .true. )
1112      ENDIF
1113      !
1114   END SUBROUTINE ctl_stop
1115
1116
1117   SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5,   &
1118      &                 cd6, cd7, cd8, cd9, cd10 )
1119      !!----------------------------------------------------------------------
1120      !!                  ***  ROUTINE  stop_warn  ***
1121      !!
1122      !! ** Purpose :   print in ocean.outpput file a error message and
1123      !!                increment the warning number (nwarn) by one.
1124      !!----------------------------------------------------------------------
1125      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5
1126      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10
1127      !!----------------------------------------------------------------------
1128      !
1129      nwarn = nwarn + 1
1130      !
1131      IF(lwp) THEN
1132                               WRITE(numout,*)
1133                               WRITE(numout,*) ' ===>>> : W A R N I N G'
1134                               WRITE(numout,*)
1135                               WRITE(numout,*) '         ==============='
1136                               WRITE(numout,*)
1137         IF( PRESENT(cd1 ) )   WRITE(numout,*) TRIM(cd1)
1138         IF( PRESENT(cd2 ) )   WRITE(numout,*) TRIM(cd2)
1139         IF( PRESENT(cd3 ) )   WRITE(numout,*) TRIM(cd3)
1140         IF( PRESENT(cd4 ) )   WRITE(numout,*) TRIM(cd4)
1141         IF( PRESENT(cd5 ) )   WRITE(numout,*) TRIM(cd5)
1142         IF( PRESENT(cd6 ) )   WRITE(numout,*) TRIM(cd6)
1143         IF( PRESENT(cd7 ) )   WRITE(numout,*) TRIM(cd7)
1144         IF( PRESENT(cd8 ) )   WRITE(numout,*) TRIM(cd8)
1145         IF( PRESENT(cd9 ) )   WRITE(numout,*) TRIM(cd9)
1146         IF( PRESENT(cd10) )   WRITE(numout,*) TRIM(cd10)
1147                               WRITE(numout,*)
1148      ENDIF
1149      CALL FLUSH(numout)
1150      !
1151   END SUBROUTINE ctl_warn
1152
1153
1154   SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea )
1155      !!----------------------------------------------------------------------
1156      !!                  ***  ROUTINE ctl_opn  ***
1157      !!
1158      !! ** Purpose :   Open file and check if required file is available.
1159      !!
1160      !! ** Method  :   Fortan open
1161      !!----------------------------------------------------------------------
1162      INTEGER          , INTENT(  out) ::   knum      ! logical unit to open
1163      CHARACTER(len=*) , INTENT(in   ) ::   cdfile    ! file name to open
1164      CHARACTER(len=*) , INTENT(in   ) ::   cdstat    ! disposition specifier
1165      CHARACTER(len=*) , INTENT(in   ) ::   cdform    ! formatting specifier
1166      CHARACTER(len=*) , INTENT(in   ) ::   cdacce    ! access specifier
1167      INTEGER          , INTENT(in   ) ::   klengh    ! record length
1168      INTEGER          , INTENT(in   ) ::   kout      ! number of logical units for write
1169      LOGICAL          , INTENT(in   ) ::   ldwp      ! boolean term for print
1170      INTEGER, OPTIONAL, INTENT(in   ) ::   karea     ! proc number
1171      !
1172      CHARACTER(len=80) ::   clfile
1173      INTEGER           ::   iost
1174      !!----------------------------------------------------------------------
1175      !
1176      ! adapt filename
1177      ! ----------------
1178      clfile = TRIM(cdfile)
1179      IF( PRESENT( karea ) ) THEN
1180         IF( karea > 1 )   WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1
1181      ENDIF
1182#if defined key_agrif
1183      IF( .NOT. Agrif_Root() )   clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile)
1184      knum=Agrif_Get_Unit()
1185#else
1186      knum=get_unit()
1187#endif
1188      IF( TRIM(cdfile) == '/dev/null' )   clfile = TRIM(cdfile)   ! force the use of /dev/null
1189      !
1190      IF(       cdacce(1:6) == 'DIRECT' )  THEN   ! cdacce has always more than 6 characters
1191         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh         , ERR=100, IOSTAT=iost )
1192      ELSE IF( TRIM(cdstat) == 'APPEND' )  THEN   ! cdstat can have less than 6 characters
1193         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS='UNKNOWN', POSITION='APPEND', ERR=100, IOSTAT=iost )
1194      ELSE
1195         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat                      , ERR=100, IOSTAT=iost )
1196      ENDIF
1197      IF( iost /= 0 .AND. TRIM(clfile) == '/dev/null' ) &   ! for windows
1198         &  OPEN(UNIT=knum,FILE='NUL', FORM=cdform, ACCESS=cdacce, STATUS=cdstat                      , ERR=100, IOSTAT=iost )   
1199      IF( iost == 0 ) THEN
1200         IF(ldwp) THEN
1201            WRITE(kout,*) '     file   : ', TRIM(clfile),' open ok'
1202            WRITE(kout,*) '     unit   = ', knum
1203            WRITE(kout,*) '     status = ', cdstat
1204            WRITE(kout,*) '     form   = ', cdform
1205            WRITE(kout,*) '     access = ', cdacce
1206            WRITE(kout,*)
1207         ENDIF
1208      ENDIF
1209100   CONTINUE
1210      IF( iost /= 0 ) THEN
1211         WRITE(ctmp1,*) ' ===>>>> : bad opening file: ', TRIM(clfile)
1212         WRITE(ctmp2,*) ' =======   ===  '
1213         WRITE(ctmp3,*) '           unit   = ', knum
1214         WRITE(ctmp4,*) '           status = ', cdstat
1215         WRITE(ctmp5,*) '           form   = ', cdform
1216         WRITE(ctmp6,*) '           access = ', cdacce
1217         WRITE(ctmp7,*) '           iostat = ', iost
1218         WRITE(ctmp8,*) '           we stop. verify the file '
1219         CALL ctl_stop( 'STOP', ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 )
1220      ENDIF
1221      !
1222   END SUBROUTINE ctl_opn
1223
1224
1225   SUBROUTINE ctl_nam ( kios, cdnam )
1226      !!----------------------------------------------------------------------
1227      !!                  ***  ROUTINE ctl_nam  ***
1228      !!
1229      !! ** Purpose :   Informations when error while reading a namelist
1230      !!
1231      !! ** Method  :   Fortan open
1232      !!----------------------------------------------------------------------
1233      INTEGER                                , INTENT(inout) ::   kios    ! IO status after reading the namelist
1234      CHARACTER(len=*)                       , INTENT(in   ) ::   cdnam   ! group name of namelist for which error occurs
1235      !
1236      CHARACTER(len=5) ::   clios   ! string to convert iostat in character for print
1237      !!----------------------------------------------------------------------
1238      !
1239      WRITE (clios, '(I5.0)')   kios
1240      IF( kios < 0 ) THEN         
1241         CALL ctl_warn( 'end of record or file while reading namelist '   &
1242            &           // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
1243      ENDIF
1244      !
1245      IF( kios > 0 ) THEN
1246         CALL ctl_stop( 'misspelled variable in namelist '   &
1247            &           // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
1248      ENDIF
1249      kios = 0
1250      !
1251   END SUBROUTINE ctl_nam
1252
1253
1254   INTEGER FUNCTION get_unit()
1255      !!----------------------------------------------------------------------
1256      !!                  ***  FUNCTION  get_unit  ***
1257      !!
1258      !! ** Purpose :   return the index of an unused logical unit
1259      !!----------------------------------------------------------------------
1260      LOGICAL :: llopn
1261      !!----------------------------------------------------------------------
1262      !
1263      get_unit = 15   ! choose a unit that is big enough then it is not already used in NEMO
1264      llopn = .TRUE.
1265      DO WHILE( (get_unit < 998) .AND. llopn )
1266         get_unit = get_unit + 1
1267         INQUIRE( unit = get_unit, opened = llopn )
1268      END DO
1269      IF( (get_unit == 999) .AND. llopn ) THEN
1270         CALL ctl_stop( 'STOP', 'get_unit: All logical units until 999 are used...' )
1271      ENDIF
1272      !
1273   END FUNCTION get_unit
1274
1275   !!----------------------------------------------------------------------
1276END MODULE lib_mpp
Note: See TracBrowser for help on using the repository browser.