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_stage2_spmd/src/OCE/LBC – NEMO

source: NEMO/branches/UKMO/NEMO_4.0.1_NGMS_couple_stage2_spmd/src/OCE/LBC/lib_mpp.F90 @ 14661

Last change on this file since 14661 was 14661, checked in by vsmart, 3 years ago

Changes made to run from cap code. Restructure of nemogcm into init, run, finalise subroutines and do not use mpi initialisation/finalisation or STOP if key_spmd set

File size: 56.8 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, ndelayid(idvar), ierr )
401      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
402# else
403      CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr )
404# endif
405#else
406      pout(:) = REAL(y_in(:), wp)
407#endif
408
409   END SUBROUTINE mpp_delay_sum
410
411   
412   SUBROUTINE mpp_delay_max( cdname, cdelay, p_in, pout, ldlast, kcom )
413      !!----------------------------------------------------------------------
414      !!                   ***  routine mpp_delay_max  ***
415      !!
416      !! ** Purpose :   performed delayed mpp_max, the result is received on next call
417      !!
418      !!----------------------------------------------------------------------
419      CHARACTER(len=*), INTENT(in   )                 ::   cdname  ! name of the calling subroutine
420      CHARACTER(len=*), INTENT(in   )                 ::   cdelay  ! name (used as id) of the delayed operation
421      REAL(wp),         INTENT(in   ), DIMENSION(:)   ::   p_in    !
422      REAL(wp),         INTENT(  out), DIMENSION(:)   ::   pout    !
423      LOGICAL,          INTENT(in   )                 ::   ldlast  ! true if this is the last time we call this routine
424      INTEGER,          INTENT(in   ), OPTIONAL       ::   kcom
425      !!
426      INTEGER ::   ji, isz
427      INTEGER ::   idvar
428      INTEGER ::   ierr, ilocalcomm
429      !!----------------------------------------------------------------------
430#if defined key_mpp_mpi
431      ilocalcomm = mpi_comm_oce
432      IF( PRESENT(kcom) )   ilocalcomm = kcom
433
434      isz = SIZE(p_in)
435
436      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_dlg = .TRUE. )
437
438      idvar = -1
439      DO ji = 1, nbdelay
440         IF( TRIM(cdelay) == TRIM(c_delaylist(ji)) ) idvar = ji
441      END DO
442      IF ( idvar == -1 )   CALL ctl_stop( 'STOP',' mpp_delay_max : please add a new delayed exchange for '//TRIM(cdname) )
443
444      IF ( ndelayid(idvar) == 0 ) THEN         ! first call    with restart: %z1d defined in iom_delay_rst
445         !                                       --------------------------
446         IF ( SIZE(todelay(idvar)%z1d) /= isz ) THEN                  ! Check dimension coherence
447            IF(lwp) WRITE(numout,*) ' WARNING: the nb of delayed variables in restart file is not the model one'
448            DEALLOCATE(todelay(idvar)%z1d)
449            ndelayid(idvar) = -1                                      ! do as if we had no restart
450         END IF
451      ENDIF
452
453      IF( ndelayid(idvar) == -1 ) THEN         ! first call without restart: define %z1d from p_in with a blocking allreduce
454         !                                       --------------------------
455         ALLOCATE(todelay(idvar)%z1d(isz))
456         CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ierr )   ! get %z1d
457      ENDIF
458
459      IF( ndelayid(idvar) > 0 )   CALL mpp_delay_rcv( idvar )         ! make sure %z1d is received
460
461      ! send back pout from todelay(idvar)%z1d defined at previous call
462      pout(:) = todelay(idvar)%z1d(:)
463
464      ! send p_in into todelay(idvar)%z1d with a non-blocking communication
465# if defined key_mpi2
466      IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.)
467      CALL  mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr )
468      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
469# else
470      CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr )
471# endif
472#else
473      pout(:) = p_in(:)
474#endif
475
476   END SUBROUTINE mpp_delay_max
477
478   
479   SUBROUTINE mpp_delay_rcv( kid )
480      !!----------------------------------------------------------------------
481      !!                   ***  routine mpp_delay_rcv  ***
482      !!
483      !! ** Purpose :  force barrier for delayed mpp (needed for restart)
484      !!
485      !!----------------------------------------------------------------------
486      INTEGER,INTENT(in   )      ::  kid 
487      INTEGER ::   ierr
488      !!----------------------------------------------------------------------
489#if defined key_mpp_mpi
490      IF( ndelayid(kid) /= -2 ) THEN 
491#if ! defined key_mpi2
492         IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.)
493         CALL mpi_wait( ndelayid(kid), MPI_STATUS_IGNORE, ierr )                        ! make sure todelay(kid) is received
494         IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
495#endif
496         IF( ASSOCIATED(todelay(kid)%y1d) )   todelay(kid)%z1d(:) = REAL(todelay(kid)%y1d(:), wp)  ! define %z1d from %y1d
497         ndelayid(kid) = -2   ! add flag to know that mpi_wait was already called on kid
498      ENDIF
499#endif
500   END SUBROUTINE mpp_delay_rcv
501
502   
503   !!----------------------------------------------------------------------
504   !!    ***  mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real  ***
505   !!   
506   !!----------------------------------------------------------------------
507   !!
508#  define OPERATION_MAX
509#  define INTEGER_TYPE
510#  define DIM_0d
511#     define ROUTINE_ALLREDUCE           mppmax_int
512#     include "mpp_allreduce_generic.h90"
513#     undef ROUTINE_ALLREDUCE
514#  undef DIM_0d
515#  define DIM_1d
516#     define ROUTINE_ALLREDUCE           mppmax_a_int
517#     include "mpp_allreduce_generic.h90"
518#     undef ROUTINE_ALLREDUCE
519#  undef DIM_1d
520#  undef INTEGER_TYPE
521!
522#  define REAL_TYPE
523#  define DIM_0d
524#     define ROUTINE_ALLREDUCE           mppmax_real
525#     include "mpp_allreduce_generic.h90"
526#     undef ROUTINE_ALLREDUCE
527#  undef DIM_0d
528#  define DIM_1d
529#     define ROUTINE_ALLREDUCE           mppmax_a_real
530#     include "mpp_allreduce_generic.h90"
531#     undef ROUTINE_ALLREDUCE
532#  undef DIM_1d
533#  undef REAL_TYPE
534#  undef OPERATION_MAX
535   !!----------------------------------------------------------------------
536   !!    ***  mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real  ***
537   !!   
538   !!----------------------------------------------------------------------
539   !!
540#  define OPERATION_MIN
541#  define INTEGER_TYPE
542#  define DIM_0d
543#     define ROUTINE_ALLREDUCE           mppmin_int
544#     include "mpp_allreduce_generic.h90"
545#     undef ROUTINE_ALLREDUCE
546#  undef DIM_0d
547#  define DIM_1d
548#     define ROUTINE_ALLREDUCE           mppmin_a_int
549#     include "mpp_allreduce_generic.h90"
550#     undef ROUTINE_ALLREDUCE
551#  undef DIM_1d
552#  undef INTEGER_TYPE
553!
554#  define REAL_TYPE
555#  define DIM_0d
556#     define ROUTINE_ALLREDUCE           mppmin_real
557#     include "mpp_allreduce_generic.h90"
558#     undef ROUTINE_ALLREDUCE
559#  undef DIM_0d
560#  define DIM_1d
561#     define ROUTINE_ALLREDUCE           mppmin_a_real
562#     include "mpp_allreduce_generic.h90"
563#     undef ROUTINE_ALLREDUCE
564#  undef DIM_1d
565#  undef REAL_TYPE
566#  undef OPERATION_MIN
567
568   !!----------------------------------------------------------------------
569   !!    ***  mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real  ***
570   !!   
571   !!   Global sum of 1D array or a variable (integer, real or complex)
572   !!----------------------------------------------------------------------
573   !!
574#  define OPERATION_SUM
575#  define INTEGER_TYPE
576#  define DIM_0d
577#     define ROUTINE_ALLREDUCE           mppsum_int
578#     include "mpp_allreduce_generic.h90"
579#     undef ROUTINE_ALLREDUCE
580#  undef DIM_0d
581#  define DIM_1d
582#     define ROUTINE_ALLREDUCE           mppsum_a_int
583#     include "mpp_allreduce_generic.h90"
584#     undef ROUTINE_ALLREDUCE
585#  undef DIM_1d
586#  undef INTEGER_TYPE
587!
588#  define REAL_TYPE
589#  define DIM_0d
590#     define ROUTINE_ALLREDUCE           mppsum_real
591#     include "mpp_allreduce_generic.h90"
592#     undef ROUTINE_ALLREDUCE
593#  undef DIM_0d
594#  define DIM_1d
595#     define ROUTINE_ALLREDUCE           mppsum_a_real
596#     include "mpp_allreduce_generic.h90"
597#     undef ROUTINE_ALLREDUCE
598#  undef DIM_1d
599#  undef REAL_TYPE
600#  undef OPERATION_SUM
601
602#  define OPERATION_SUM_DD
603#  define COMPLEX_TYPE
604#  define DIM_0d
605#     define ROUTINE_ALLREDUCE           mppsum_realdd
606#     include "mpp_allreduce_generic.h90"
607#     undef ROUTINE_ALLREDUCE
608#  undef DIM_0d
609#  define DIM_1d
610#     define ROUTINE_ALLREDUCE           mppsum_a_realdd
611#     include "mpp_allreduce_generic.h90"
612#     undef ROUTINE_ALLREDUCE
613#  undef DIM_1d
614#  undef COMPLEX_TYPE
615#  undef OPERATION_SUM_DD
616
617   !!----------------------------------------------------------------------
618   !!    ***  mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d
619   !!   
620   !!----------------------------------------------------------------------
621   !!
622#  define OPERATION_MINLOC
623#  define DIM_2d
624#     define ROUTINE_LOC           mpp_minloc2d
625#     include "mpp_loc_generic.h90"
626#     undef ROUTINE_LOC
627#  undef DIM_2d
628#  define DIM_3d
629#     define ROUTINE_LOC           mpp_minloc3d
630#     include "mpp_loc_generic.h90"
631#     undef ROUTINE_LOC
632#  undef DIM_3d
633#  undef OPERATION_MINLOC
634
635#  define OPERATION_MAXLOC
636#  define DIM_2d
637#     define ROUTINE_LOC           mpp_maxloc2d
638#     include "mpp_loc_generic.h90"
639#     undef ROUTINE_LOC
640#  undef DIM_2d
641#  define DIM_3d
642#     define ROUTINE_LOC           mpp_maxloc3d
643#     include "mpp_loc_generic.h90"
644#     undef ROUTINE_LOC
645#  undef DIM_3d
646#  undef OPERATION_MAXLOC
647
648   SUBROUTINE mppsync()
649      !!----------------------------------------------------------------------
650      !!                  ***  routine mppsync  ***
651      !!
652      !! ** Purpose :   Massively parallel processors, synchroneous
653      !!
654      !!-----------------------------------------------------------------------
655      INTEGER :: ierror
656      !!-----------------------------------------------------------------------
657      !
658#if defined key_mpp_mpi
659      CALL mpi_barrier( mpi_comm_oce, ierror )
660#endif
661      !
662   END SUBROUTINE mppsync
663
664
665   SUBROUTINE mppstop( ld_abort ) 
666
667      USE mod_oasis      ! coupling routines
668
669      !!----------------------------------------------------------------------
670      !!                  ***  routine mppstop  ***
671      !!
672      !! ** purpose :   Stop massively parallel processors method
673      !!
674      !!----------------------------------------------------------------------
675      LOGICAL, OPTIONAL, INTENT(in) :: ld_abort    ! source process number
676      LOGICAL ::   ll_abort
677      INTEGER ::   info
678      !!----------------------------------------------------------------------
679      ll_abort = .FALSE.
680      IF( PRESENT(ld_abort) ) ll_abort = ld_abort
681      !
682
683#if defined key_oasis3
684      ! If we're trying to shut down cleanly then we need to consider the fact
685      ! that this could be part of an MPMD configuration - we don't want to
686      ! leave other components deadlocked.
687
688! RSRH No!
689      IF(ll_abort) THEN
690         !CALL mpi_abort( MPI_COMM_WORLD )
691         CALL oasis_abort(nproc,"mppstop","NEMO initiated abort")
692      ELSE
693         CALL mppsync
694#if !defined key_spmd
695         CALL mpi_finalize( info )
696#endif
697      ENDIF
698      IF( ll_abort ) STOP 123
699
700
701#else
702#if defined key_mpp_mpi
703      IF(ll_abort) THEN
704         CALL mpi_abort( MPI_COMM_WORLD )
705      ELSE
706         CALL mppsync
707         CALL mpi_finalize( info )
708      ENDIF
709#endif
710      IF( ll_abort ) STOP 123
711      !
712#endif
713   END SUBROUTINE mppstop
714
715
716   SUBROUTINE mpp_comm_free( kcom )
717      !!----------------------------------------------------------------------
718      INTEGER, INTENT(in) ::   kcom
719      !!
720      INTEGER :: ierr
721      !!----------------------------------------------------------------------
722      !
723#if defined key_mpp_mpi
724      CALL MPI_COMM_FREE(kcom, ierr)
725#endif
726      !
727   END SUBROUTINE mpp_comm_free
728
729
730   SUBROUTINE mpp_ini_znl( kumout )
731      !!----------------------------------------------------------------------
732      !!               ***  routine mpp_ini_znl  ***
733      !!
734      !! ** Purpose :   Initialize special communicator for computing zonal sum
735      !!
736      !! ** Method  : - Look for processors in the same row
737      !!              - Put their number in nrank_znl
738      !!              - Create group for the znl processors
739      !!              - Create a communicator for znl processors
740      !!              - Determine if processor should write znl files
741      !!
742      !! ** output
743      !!      ndim_rank_znl = number of processors on the same row
744      !!      ngrp_znl = group ID for the znl processors
745      !!      ncomm_znl = communicator for the ice procs.
746      !!      n_znl_root = number (in the world) of proc 0 in the ice comm.
747      !!
748      !!----------------------------------------------------------------------
749      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical units
750      !
751      INTEGER :: jproc      ! dummy loop integer
752      INTEGER :: ierr, ii   ! local integer
753      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kwork
754      !!----------------------------------------------------------------------
755#if defined key_mpp_mpi
756      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world     : ', ngrp_world
757      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
758      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_oce   : ', mpi_comm_oce
759      !
760      ALLOCATE( kwork(jpnij), STAT=ierr )
761      IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_ini_znl : failed to allocate 1D array of length jpnij')
762
763      IF( jpnj == 1 ) THEN
764         ngrp_znl  = ngrp_world
765         ncomm_znl = mpi_comm_oce
766      ELSE
767         !
768         CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_oce, ierr )
769         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
770         !-$$        CALL flush(numout)
771         !
772         ! Count number of processors on the same row
773         ndim_rank_znl = 0
774         DO jproc=1,jpnij
775            IF ( kwork(jproc) == njmpp ) THEN
776               ndim_rank_znl = ndim_rank_znl + 1
777            ENDIF
778         END DO
779         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
780         !-$$        CALL flush(numout)
781         ! Allocate the right size to nrank_znl
782         IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
783         ALLOCATE(nrank_znl(ndim_rank_znl))
784         ii = 0
785         nrank_znl (:) = 0
786         DO jproc=1,jpnij
787            IF ( kwork(jproc) == njmpp) THEN
788               ii = ii + 1
789               nrank_znl(ii) = jproc -1
790            ENDIF
791         END DO
792         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
793         !-$$        CALL flush(numout)
794
795         ! Create the opa group
796         CALL MPI_COMM_GROUP(mpi_comm_oce,ngrp_opa,ierr)
797         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
798         !-$$        CALL flush(numout)
799
800         ! Create the znl group from the opa group
801         CALL MPI_GROUP_INCL  ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
802         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
803         !-$$        CALL flush(numout)
804
805         ! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
806         CALL MPI_COMM_CREATE ( mpi_comm_oce, ngrp_znl, ncomm_znl, ierr )
807         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
808         !-$$        CALL flush(numout)
809         !
810      END IF
811
812      ! Determines if processor if the first (starting from i=1) on the row
813      IF ( jpni == 1 ) THEN
814         l_znl_root = .TRUE.
815      ELSE
816         l_znl_root = .FALSE.
817         kwork (1) = nimpp
818         CALL mpp_min ( 'lib_mpp', kwork(1), kcom = ncomm_znl)
819         IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
820      END IF
821
822      DEALLOCATE(kwork)
823#endif
824
825   END SUBROUTINE mpp_ini_znl
826
827
828   SUBROUTINE mpp_ini_north
829      !!----------------------------------------------------------------------
830      !!               ***  routine mpp_ini_north  ***
831      !!
832      !! ** Purpose :   Initialize special communicator for north folding
833      !!      condition together with global variables needed in the mpp folding
834      !!
835      !! ** Method  : - Look for northern processors
836      !!              - Put their number in nrank_north
837      !!              - Create groups for the world processors and the north processors
838      !!              - Create a communicator for northern processors
839      !!
840      !! ** output
841      !!      njmppmax = njmpp for northern procs
842      !!      ndim_rank_north = number of processors in the northern line
843      !!      nrank_north (ndim_rank_north) = number  of the northern procs.
844      !!      ngrp_world = group ID for the world processors
845      !!      ngrp_north = group ID for the northern processors
846      !!      ncomm_north = communicator for the northern procs.
847      !!      north_root = number (in the world) of proc 0 in the northern comm.
848      !!
849      !!----------------------------------------------------------------------
850      INTEGER ::   ierr
851      INTEGER ::   jjproc
852      INTEGER ::   ii, ji
853      !!----------------------------------------------------------------------
854      !
855#if defined key_mpp_mpi
856      njmppmax = MAXVAL( njmppt )
857      !
858      ! Look for how many procs on the northern boundary
859      ndim_rank_north = 0
860      DO jjproc = 1, jpnij
861         IF( njmppt(jjproc) == njmppmax )   ndim_rank_north = ndim_rank_north + 1
862      END DO
863      !
864      ! Allocate the right size to nrank_north
865      IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
866      ALLOCATE( nrank_north(ndim_rank_north) )
867
868      ! Fill the nrank_north array with proc. number of northern procs.
869      ! Note : the rank start at 0 in MPI
870      ii = 0
871      DO ji = 1, jpnij
872         IF ( njmppt(ji) == njmppmax   ) THEN
873            ii=ii+1
874            nrank_north(ii)=ji-1
875         END IF
876      END DO
877      !
878      ! create the world group
879      CALL MPI_COMM_GROUP( mpi_comm_oce, ngrp_world, ierr )
880      !
881      ! Create the North group from the world group
882      CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
883      !
884      ! Create the North communicator , ie the pool of procs in the north group
885      CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr )
886      !
887#endif
888   END SUBROUTINE mpp_ini_north
889
890
891   SUBROUTINE DDPDD_MPI( ydda, yddb, ilen, itype )
892      !!---------------------------------------------------------------------
893      !!   Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
894      !!
895      !!   Modification of original codes written by David H. Bailey
896      !!   This subroutine computes yddb(i) = ydda(i)+yddb(i)
897      !!---------------------------------------------------------------------
898      INTEGER                     , INTENT(in)    ::   ilen, itype
899      COMPLEX(wp), DIMENSION(ilen), INTENT(in)    ::   ydda
900      COMPLEX(wp), DIMENSION(ilen), INTENT(inout) ::   yddb
901      !
902      REAL(wp) :: zerr, zt1, zt2    ! local work variables
903      INTEGER  :: ji, ztmp           ! local scalar
904      !!---------------------------------------------------------------------
905      !
906      ztmp = itype   ! avoid compilation warning
907      !
908      DO ji=1,ilen
909      ! Compute ydda + yddb using Knuth's trick.
910         zt1  = real(ydda(ji)) + real(yddb(ji))
911         zerr = zt1 - real(ydda(ji))
912         zt2  = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
913                + aimag(ydda(ji)) + aimag(yddb(ji))
914
915         ! The result is zt1 + zt2, after normalization.
916         yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
917      END DO
918      !
919   END SUBROUTINE DDPDD_MPI
920
921
922   SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb, ld_dlg )
923      !!----------------------------------------------------------------------
924      !!                  ***  routine mpp_report  ***
925      !!
926      !! ** Purpose :   report use of mpp routines per time-setp
927      !!
928      !!----------------------------------------------------------------------
929      CHARACTER(len=*),           INTENT(in   ) ::   cdname      ! name of the calling subroutine
930      INTEGER         , OPTIONAL, INTENT(in   ) ::   kpk, kpl, kpf
931      LOGICAL         , OPTIONAL, INTENT(in   ) ::   ld_lbc, ld_glb, ld_dlg
932      !!
933      CHARACTER(len=128)                        ::   ccountname  ! name of a subroutine to count communications
934      LOGICAL ::   ll_lbc, ll_glb, ll_dlg
935      INTEGER ::    ji,  jj,  jk,  jh, jf, jcount   ! dummy loop indices
936      !!----------------------------------------------------------------------
937#if defined key_mpp_mpi
938      !
939      ll_lbc = .FALSE.
940      IF( PRESENT(ld_lbc) ) ll_lbc = ld_lbc
941      ll_glb = .FALSE.
942      IF( PRESENT(ld_glb) ) ll_glb = ld_glb
943      ll_dlg = .FALSE.
944      IF( PRESENT(ld_dlg) ) ll_dlg = ld_dlg
945      !
946      ! find the smallest common frequency: default = frequency product, if multiple, choose the larger of the 2 frequency
947      IF( ncom_dttrc /= 1 )   CALL ctl_stop( 'STOP', 'mpp_report, ncom_dttrc /= 1 not coded...' ) 
948      ncom_freq = ncom_fsbc
949      !
950      IF ( ncom_stp == nit000+ncom_freq ) THEN   ! avoid to count extra communications in potential initializations at nit000
951         IF( ll_lbc ) THEN
952            IF( .NOT. ALLOCATED(ncomm_sequence) ) ALLOCATE( ncomm_sequence(ncom_rec_max,2) )
953            IF( .NOT. ALLOCATED(    crname_lbc) ) ALLOCATE(     crname_lbc(ncom_rec_max  ) )
954            n_sequence_lbc = n_sequence_lbc + 1
955            IF( n_sequence_lbc > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' )   ! deadlock
956            crname_lbc(n_sequence_lbc) = cdname     ! keep the name of the calling routine
957            ncomm_sequence(n_sequence_lbc,1) = kpk*kpl   ! size of 3rd and 4th dimensions
958            ncomm_sequence(n_sequence_lbc,2) = kpf       ! number of arrays to be treated (multi)
959         ENDIF
960         IF( ll_glb ) THEN
961            IF( .NOT. ALLOCATED(crname_glb) ) ALLOCATE( crname_glb(ncom_rec_max) )
962            n_sequence_glb = n_sequence_glb + 1
963            IF( n_sequence_glb > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' )   ! deadlock
964            crname_glb(n_sequence_glb) = cdname     ! keep the name of the calling routine
965         ENDIF
966         IF( ll_dlg ) THEN
967            IF( .NOT. ALLOCATED(crname_dlg) ) ALLOCATE( crname_dlg(ncom_rec_max) )
968            n_sequence_dlg = n_sequence_dlg + 1
969            IF( n_sequence_dlg > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' )   ! deadlock
970            crname_dlg(n_sequence_dlg) = cdname     ! keep the name of the calling routine
971         ENDIF
972      ELSE IF ( ncom_stp == nit000+2*ncom_freq ) THEN
973         CALL ctl_opn( numcom, 'communication_report.txt', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea )
974         WRITE(numcom,*) ' '
975         WRITE(numcom,*) ' ------------------------------------------------------------'
976         WRITE(numcom,*) ' Communication pattern report (second oce+sbc+top time step):'
977         WRITE(numcom,*) ' ------------------------------------------------------------'
978         WRITE(numcom,*) ' '
979         WRITE(numcom,'(A,I4)') ' Exchanged halos : ', n_sequence_lbc
980         jj = 0; jk = 0; jf = 0; jh = 0
981         DO ji = 1, n_sequence_lbc
982            IF ( ncomm_sequence(ji,1) .GT. 1 ) jk = jk + 1
983            IF ( ncomm_sequence(ji,2) .GT. 1 ) jf = jf + 1
984            IF ( ncomm_sequence(ji,1) .GT. 1 .AND. ncomm_sequence(ji,2) .GT. 1 ) jj = jj + 1
985            jh = MAX (jh, ncomm_sequence(ji,1)*ncomm_sequence(ji,2))
986         END DO
987         WRITE(numcom,'(A,I3)') ' 3D Exchanged halos : ', jk
988         WRITE(numcom,'(A,I3)') ' Multi arrays exchanged halos : ', jf
989         WRITE(numcom,'(A,I3)') '   from which 3D : ', jj
990         WRITE(numcom,'(A,I10)') ' Array max size : ', jh*jpi*jpj
991         WRITE(numcom,*) ' '
992         WRITE(numcom,*) ' lbc_lnk called'
993         DO ji = 1, n_sequence_lbc - 1
994            IF ( crname_lbc(ji) /= 'already counted' ) THEN
995               ccountname = crname_lbc(ji)
996               crname_lbc(ji) = 'already counted'
997               jcount = 1
998               DO jj = ji + 1, n_sequence_lbc
999                  IF ( ccountname ==  crname_lbc(jj) ) THEN
1000                     jcount = jcount + 1
1001                     crname_lbc(jj) = 'already counted'
1002                  END IF
1003               END DO
1004               WRITE(numcom,'(A, I4, A, A)') ' - ', jcount,' times by subroutine ', TRIM(ccountname)
1005            END IF
1006         END DO
1007         IF ( crname_lbc(n_sequence_lbc) /= 'already counted' ) THEN
1008            WRITE(numcom,'(A, I4, A, A)') ' - ', 1,' times by subroutine ', TRIM(crname_lbc(ncom_rec_max))
1009         END IF
1010         WRITE(numcom,*) ' '
1011         IF ( n_sequence_glb > 0 ) THEN
1012            WRITE(numcom,'(A,I4)') ' Global communications : ', n_sequence_glb
1013            jj = 1
1014            DO ji = 2, n_sequence_glb
1015               IF( crname_glb(ji-1) /= crname_glb(ji) ) THEN
1016                  WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(ji-1))
1017                  jj = 0
1018               END IF
1019               jj = jj + 1 
1020            END DO
1021            WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(n_sequence_glb))
1022            DEALLOCATE(crname_glb)
1023         ELSE
1024            WRITE(numcom,*) ' No MPI global communication '
1025         ENDIF
1026         WRITE(numcom,*) ' '
1027         IF ( n_sequence_dlg > 0 ) THEN
1028            WRITE(numcom,'(A,I4)') ' Delayed global communications : ', n_sequence_dlg
1029            jj = 1
1030            DO ji = 2, n_sequence_dlg
1031               IF( crname_dlg(ji-1) /= crname_dlg(ji) ) THEN
1032                  WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_dlg(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_dlg(n_sequence_dlg))
1038            DEALLOCATE(crname_dlg)
1039         ELSE
1040            WRITE(numcom,*) ' No MPI delayed global communication '
1041         ENDIF
1042         WRITE(numcom,*) ' '
1043         WRITE(numcom,*) ' -----------------------------------------------'
1044         WRITE(numcom,*) ' '
1045         DEALLOCATE(ncomm_sequence)
1046         DEALLOCATE(crname_lbc)
1047      ENDIF
1048#endif
1049   END SUBROUTINE mpp_report
1050
1051   
1052   SUBROUTINE tic_tac (ld_tic, ld_global)
1053
1054    LOGICAL,           INTENT(IN) :: ld_tic
1055    LOGICAL, OPTIONAL, INTENT(IN) :: ld_global
1056    REAL(wp), DIMENSION(2), SAVE :: tic_wt
1057    REAL(wp),               SAVE :: tic_ct = 0._wp
1058    INTEGER :: ii
1059#if defined key_mpp_mpi
1060
1061    IF( ncom_stp <= nit000 ) RETURN
1062    IF( ncom_stp == nitend ) RETURN
1063    ii = 1
1064    IF( PRESENT( ld_global ) ) THEN
1065       IF( ld_global ) ii = 2
1066    END IF
1067   
1068    IF ( ld_tic ) THEN
1069       tic_wt(ii) = MPI_Wtime()                                                    ! start count tic->tac (waiting time)
1070       IF ( tic_ct > 0.0_wp ) compute_time = compute_time + MPI_Wtime() - tic_ct   ! cumulate count tac->tic
1071    ELSE
1072       waiting_time(ii) = waiting_time(ii) + MPI_Wtime() - tic_wt(ii)              ! cumulate count tic->tac
1073       tic_ct = MPI_Wtime()                                                        ! start count tac->tic (waiting time)
1074    ENDIF
1075#endif
1076   
1077   END SUBROUTINE tic_tac
1078
1079#if ! defined key_mpp_mpi
1080   SUBROUTINE mpi_wait(request, status, ierror)
1081      INTEGER                            , INTENT(in   ) ::   request
1082      INTEGER, DIMENSION(MPI_STATUS_SIZE), INTENT(  out) ::   status
1083      INTEGER                            , INTENT(  out) ::   ierror
1084   END SUBROUTINE mpi_wait
1085
1086   
1087   FUNCTION MPI_Wtime()
1088      REAL(wp) ::  MPI_Wtime
1089      MPI_Wtime = -1.
1090   END FUNCTION MPI_Wtime
1091#endif
1092
1093   !!----------------------------------------------------------------------
1094   !!   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam   routines
1095   !!----------------------------------------------------------------------
1096
1097   SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 ,   &
1098      &                 cd6, cd7, cd8, cd9, cd10 )
1099      !!----------------------------------------------------------------------
1100      !!                  ***  ROUTINE  stop_opa  ***
1101      !!
1102      !! ** Purpose :   print in ocean.outpput file a error message and
1103      !!                increment the error number (nstop) by one.
1104      !!----------------------------------------------------------------------
1105      CHARACTER(len=*), INTENT(in   )           ::   cd1
1106      CHARACTER(len=*), INTENT(in   ), OPTIONAL ::        cd2, cd3, cd4, cd5
1107      CHARACTER(len=*), INTENT(in   ), OPTIONAL ::   cd6, cd7, cd8, cd9, cd10
1108      !!----------------------------------------------------------------------
1109      !
1110      nstop = nstop + 1
1111      !
1112      ! force to open ocean.output file if not already opened
1113      IF( numout == 6 ) CALL ctl_opn( numout, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
1114      !
1115                            WRITE(numout,*)
1116                            WRITE(numout,*) ' ===>>> : E R R O R'
1117                            WRITE(numout,*)
1118                            WRITE(numout,*) '         ==========='
1119                            WRITE(numout,*)
1120                            WRITE(numout,*) TRIM(cd1)
1121      IF( PRESENT(cd2 ) )   WRITE(numout,*) TRIM(cd2)
1122      IF( PRESENT(cd3 ) )   WRITE(numout,*) TRIM(cd3)
1123      IF( PRESENT(cd4 ) )   WRITE(numout,*) TRIM(cd4)
1124      IF( PRESENT(cd5 ) )   WRITE(numout,*) TRIM(cd5)
1125      IF( PRESENT(cd6 ) )   WRITE(numout,*) TRIM(cd6)
1126      IF( PRESENT(cd7 ) )   WRITE(numout,*) TRIM(cd7)
1127      IF( PRESENT(cd8 ) )   WRITE(numout,*) TRIM(cd8)
1128      IF( PRESENT(cd9 ) )   WRITE(numout,*) TRIM(cd9)
1129      IF( PRESENT(cd10) )   WRITE(numout,*) TRIM(cd10)
1130                            WRITE(numout,*)
1131      !
1132                               CALL FLUSH(numout    )
1133      IF( numstp     /= -1 )   CALL FLUSH(numstp    )
1134      IF( numrun     /= -1 )   CALL FLUSH(numrun    )
1135      IF( numevo_ice /= -1 )   CALL FLUSH(numevo_ice)
1136      !
1137      IF( cd1 == 'STOP' ) THEN
1138         WRITE(numout,*) 
1139         WRITE(numout,*)  'huge E-R-R-O-R : immediate stop'
1140         WRITE(numout,*) 
1141         CALL mppstop( ld_abort = .true. )
1142      ENDIF
1143      !
1144   END SUBROUTINE ctl_stop
1145
1146
1147   SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5,   &
1148      &                 cd6, cd7, cd8, cd9, cd10 )
1149      !!----------------------------------------------------------------------
1150      !!                  ***  ROUTINE  stop_warn  ***
1151      !!
1152      !! ** Purpose :   print in ocean.outpput file a error message and
1153      !!                increment the warning number (nwarn) by one.
1154      !!----------------------------------------------------------------------
1155      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5
1156      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10
1157      !!----------------------------------------------------------------------
1158      !
1159      nwarn = nwarn + 1
1160      !
1161      IF(lwp) THEN
1162                               WRITE(numout,*)
1163                               WRITE(numout,*) ' ===>>> : W A R N I N G'
1164                               WRITE(numout,*)
1165                               WRITE(numout,*) '         ==============='
1166                               WRITE(numout,*)
1167         IF( PRESENT(cd1 ) )   WRITE(numout,*) TRIM(cd1)
1168         IF( PRESENT(cd2 ) )   WRITE(numout,*) TRIM(cd2)
1169         IF( PRESENT(cd3 ) )   WRITE(numout,*) TRIM(cd3)
1170         IF( PRESENT(cd4 ) )   WRITE(numout,*) TRIM(cd4)
1171         IF( PRESENT(cd5 ) )   WRITE(numout,*) TRIM(cd5)
1172         IF( PRESENT(cd6 ) )   WRITE(numout,*) TRIM(cd6)
1173         IF( PRESENT(cd7 ) )   WRITE(numout,*) TRIM(cd7)
1174         IF( PRESENT(cd8 ) )   WRITE(numout,*) TRIM(cd8)
1175         IF( PRESENT(cd9 ) )   WRITE(numout,*) TRIM(cd9)
1176         IF( PRESENT(cd10) )   WRITE(numout,*) TRIM(cd10)
1177                               WRITE(numout,*)
1178      ENDIF
1179      CALL FLUSH(numout)
1180      !
1181   END SUBROUTINE ctl_warn
1182
1183
1184   SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea )
1185      !!----------------------------------------------------------------------
1186      !!                  ***  ROUTINE ctl_opn  ***
1187      !!
1188      !! ** Purpose :   Open file and check if required file is available.
1189      !!
1190      !! ** Method  :   Fortan open
1191      !!----------------------------------------------------------------------
1192      INTEGER          , INTENT(  out) ::   knum      ! logical unit to open
1193      CHARACTER(len=*) , INTENT(in   ) ::   cdfile    ! file name to open
1194      CHARACTER(len=*) , INTENT(in   ) ::   cdstat    ! disposition specifier
1195      CHARACTER(len=*) , INTENT(in   ) ::   cdform    ! formatting specifier
1196      CHARACTER(len=*) , INTENT(in   ) ::   cdacce    ! access specifier
1197      INTEGER          , INTENT(in   ) ::   klengh    ! record length
1198      INTEGER          , INTENT(in   ) ::   kout      ! number of logical units for write
1199      LOGICAL          , INTENT(in   ) ::   ldwp      ! boolean term for print
1200      INTEGER, OPTIONAL, INTENT(in   ) ::   karea     ! proc number
1201      !
1202      CHARACTER(len=80) ::   clfile
1203      INTEGER           ::   iost
1204      !!----------------------------------------------------------------------
1205      !
1206      ! adapt filename
1207      ! ----------------
1208      clfile = TRIM(cdfile)
1209      IF( PRESENT( karea ) ) THEN
1210         IF( karea > 1 )   WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1
1211      ENDIF
1212#if defined key_agrif
1213      IF( .NOT. Agrif_Root() )   clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile)
1214      knum=Agrif_Get_Unit()
1215#else
1216      knum=get_unit()
1217#endif
1218      IF( TRIM(cdfile) == '/dev/null' )   clfile = TRIM(cdfile)   ! force the use of /dev/null
1219      !
1220      IF(       cdacce(1:6) == 'DIRECT' )  THEN   ! cdacce has always more than 6 characters
1221         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh         , ERR=100, IOSTAT=iost )
1222      ELSE IF( TRIM(cdstat) == 'APPEND' )  THEN   ! cdstat can have less than 6 characters
1223         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS='UNKNOWN', POSITION='APPEND', ERR=100, IOSTAT=iost )
1224      ELSE
1225         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat                      , ERR=100, IOSTAT=iost )
1226      ENDIF
1227      IF( iost /= 0 .AND. TRIM(clfile) == '/dev/null' ) &   ! for windows
1228         &  OPEN(UNIT=knum,FILE='NUL', FORM=cdform, ACCESS=cdacce, STATUS=cdstat                      , ERR=100, IOSTAT=iost )   
1229      IF( iost == 0 ) THEN
1230         IF(ldwp) THEN
1231            WRITE(kout,*) '     file   : ', TRIM(clfile),' open ok'
1232            WRITE(kout,*) '     unit   = ', knum
1233            WRITE(kout,*) '     status = ', cdstat
1234            WRITE(kout,*) '     form   = ', cdform
1235            WRITE(kout,*) '     access = ', cdacce
1236            WRITE(kout,*)
1237         ENDIF
1238      ENDIF
1239100   CONTINUE
1240      IF( iost /= 0 ) THEN
1241         WRITE(ctmp1,*) ' ===>>>> : bad opening file: ', TRIM(clfile)
1242         WRITE(ctmp2,*) ' =======   ===  '
1243         WRITE(ctmp3,*) '           unit   = ', knum
1244         WRITE(ctmp4,*) '           status = ', cdstat
1245         WRITE(ctmp5,*) '           form   = ', cdform
1246         WRITE(ctmp6,*) '           access = ', cdacce
1247         WRITE(ctmp7,*) '           iostat = ', iost
1248         WRITE(ctmp8,*) '           we stop. verify the file '
1249         CALL ctl_stop( 'STOP', ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 )
1250      ENDIF
1251      !
1252   END SUBROUTINE ctl_opn
1253
1254
1255   SUBROUTINE ctl_nam ( kios, cdnam )
1256      !!----------------------------------------------------------------------
1257      !!                  ***  ROUTINE ctl_nam  ***
1258      !!
1259      !! ** Purpose :   Informations when error while reading a namelist
1260      !!
1261      !! ** Method  :   Fortan open
1262      !!----------------------------------------------------------------------
1263      INTEGER                                , INTENT(inout) ::   kios    ! IO status after reading the namelist
1264      CHARACTER(len=*)                       , INTENT(in   ) ::   cdnam   ! group name of namelist for which error occurs
1265      !
1266      CHARACTER(len=5) ::   clios   ! string to convert iostat in character for print
1267      !!----------------------------------------------------------------------
1268      !
1269      WRITE (clios, '(I5.0)')   kios
1270      IF( kios < 0 ) THEN         
1271         CALL ctl_warn( 'end of record or file while reading namelist '   &
1272            &           // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
1273      ENDIF
1274      !
1275      IF( kios > 0 ) THEN
1276         CALL ctl_stop( 'misspelled variable in namelist '   &
1277            &           // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
1278      ENDIF
1279      kios = 0
1280      !
1281   END SUBROUTINE ctl_nam
1282
1283
1284   INTEGER FUNCTION get_unit()
1285      !!----------------------------------------------------------------------
1286      !!                  ***  FUNCTION  get_unit  ***
1287      !!
1288      !! ** Purpose :   return the index of an unused logical unit
1289      !!----------------------------------------------------------------------
1290      LOGICAL :: llopn
1291      !!----------------------------------------------------------------------
1292      !
1293      get_unit = 15   ! choose a unit that is big enough then it is not already used in NEMO
1294      llopn = .TRUE.
1295      DO WHILE( (get_unit < 998) .AND. llopn )
1296         get_unit = get_unit + 1
1297         INQUIRE( unit = get_unit, opened = llopn )
1298      END DO
1299      IF( (get_unit == 999) .AND. llopn ) THEN
1300         CALL ctl_stop( 'STOP', 'get_unit: All logical units until 999 are used...' )
1301      ENDIF
1302      !
1303   END FUNCTION get_unit
1304
1305   !!----------------------------------------------------------------------
1306END MODULE lib_mpp
Note: See TracBrowser for help on using the repository browser.