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.
lib_mpp.F90 in NEMO/branches/2019/dev_r11470_HPC_12_mpi3/src/OCE/LBC – NEMO

source: NEMO/branches/2019/dev_r11470_HPC_12_mpi3/src/OCE/LBC/lib_mpp.F90 @ 11940

Last change on this file since 11940 was 11940, checked in by mocavero, 4 years ago

Add MPI3 neighbourhood collectives halo exchange in LBC and call it in tracer advection FCT scheme #2011

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