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/r4.0-HEAD_r12713_dan_test_clems_branch/src/OCE/LBC – NEMO

source: NEMO/branches/UKMO/r4.0-HEAD_r12713_dan_test_clems_branch/src/OCE/LBC/lib_mpp.F90 @ 12803

Last change on this file since 12803 was 12803, checked in by dancopsey, 2 years ago

Merge in NEMO_4.0.1_GC_couple_pkg

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