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/UKMO/NEMO_4.0.1_NGMS_couple_stage3_spmd/src/OCE/LBC – NEMO

source: NEMO/branches/UKMO/NEMO_4.0.1_NGMS_couple_stage3_spmd/src/OCE/LBC/lib_mpp.F90 @ 15276

Last change on this file since 15276 was 15276, checked in by vsmart, 17 months ago

Merge in changes from couple_stage2_spmd branch to allow for running from the Fortran cap

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