source: NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/lib_mpp.F90 @ 10314

Last change on this file since 10314 was 10314, checked in by smasson, 23 months ago

dev_r10164_HPC09_ESIWACE_PREP_MERGE: action 2: add generic glob_min/max/sum and locmin/max, complete timing and report (including bdy and icb), see #2133

  • Property svn:keywords set to Id
File size: 78.5 KB
Line 
1MODULE lib_mpp
2   !!======================================================================
3   !!                       ***  MODULE  lib_mpp  ***
4   !! Ocean numerics:  massively parallel processing library
5   !!=====================================================================
6   !! History :  OPA  !  1994  (M. Guyon, J. Escobar, M. Imbard)  Original code
7   !!            7.0  !  1997  (A.M. Treguier)  SHMEM additions
8   !!            8.0  !  1998  (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
9   !!                 !  1998  (J.M. Molines) Open boundary conditions
10   !!   NEMO     1.0  !  2003  (J.M. Molines, G. Madec)  F90, free form
11   !!                 !  2003  (J.M. Molines) add mpp_ini_north(_3d,_2d)
12   !!             -   !  2004  (R. Bourdalle Badie)  isend option in mpi
13   !!                 !  2004  (J.M. Molines) minloc, maxloc
14   !!             -   !  2005  (G. Madec, S. Masson)  npolj=5,6 F-point & ice cases
15   !!             -   !  2005  (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort
16   !!             -   !  2005  (R. Benshila, G. Madec)  add extra halo case
17   !!             -   !  2008  (R. Benshila) add mpp_ini_ice
18   !!            3.2  !  2009  (R. Benshila) SHMEM suppression, north fold in lbc_nfd
19   !!            3.2  !  2009  (O. Marti)    add mpp_ini_znl
20   !!            4.0  !  2011  (G. Madec)  move ctl_ routines from in_out_manager
21   !!            3.5  !  2012  (S.Mocavero, I. Epicoco) Add mpp_lnk_bdy_3d/2d routines to optimize the BDY comm.
22   !!            3.5  !  2013  (C. Ethe, G. Madec)  message passing arrays as local variables
23   !!            3.5  !  2013  (S.Mocavero, I.Epicoco - CMCC) north fold optimizations
24   !!            3.6  !  2015  (O. Tintó and M. Castrillo - BSC) Added '_multiple' case for 2D lbc and max
25   !!            4.0  !  2017  (G. Madec) automatique allocation of array argument (use any 3rd dimension)
26   !!             -   !  2017  (G. Madec) create generic.h90 files to generate all lbc and north fold routines
27   !!----------------------------------------------------------------------
28
29   !!----------------------------------------------------------------------
30   !!   ctl_stop      : update momentum and tracer Kz from a tke scheme
31   !!   ctl_warn      : initialization, namelist read, and parameters control
32   !!   ctl_opn       : Open file and check if required file is available.
33   !!   ctl_nam       : Prints informations when an error occurs while reading a namelist
34   !!   get_unit      : give the index of an unused logical unit
35   !!----------------------------------------------------------------------
36#if   defined key_mpp_mpi
37   !!----------------------------------------------------------------------
38   !!   'key_mpp_mpi'             MPI massively parallel processing library
39   !!----------------------------------------------------------------------
40   !!   lib_mpp_alloc : allocate mpp arrays
41   !!   mynode        : indentify the processor unit
42   !!   mpp_lnk       : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d)
43   !!   mpp_lnk_icb   : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb)
44   !!   mpprecv       :
45   !!   mppsend       :
46   !!   mppscatter    :
47   !!   mppgather     :
48   !!   mpp_min       : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
49   !!   mpp_max       : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
50   !!   mpp_sum       : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
51   !!   mpp_minloc    :
52   !!   mpp_maxloc    :
53   !!   mppsync       :
54   !!   mppstop       :
55   !!   mpp_ini_north : initialisation of north fold
56   !!   mpp_lbc_north_icb : alternative to mpp_nfd for extra outer halo with icebergs
57   !!----------------------------------------------------------------------
58   USE dom_oce        ! ocean space and time domain
59   USE lbcnfd         ! north fold treatment
60   USE in_out_manager ! I/O manager
61
62   IMPLICIT NONE
63   PRIVATE
64
65   INTERFACE mpp_nfd
66      MODULE PROCEDURE   mpp_nfd_2d      , mpp_nfd_3d      , mpp_nfd_4d
67      MODULE PROCEDURE   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr
68   END INTERFACE
69
70   ! Interface associated to the mpp_lnk_... routines is defined in lbclnk
71   PUBLIC   mpp_lnk_2d      , mpp_lnk_3d      , mpp_lnk_4d
72   PUBLIC   mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr
73   !
74!!gm  this should be useless
75   PUBLIC   mpp_nfd_2d    , mpp_nfd_3d    , mpp_nfd_4d
76   PUBLIC   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr
77!!gm end
78   !
79   PUBLIC   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam
80   PUBLIC   mynode, mppstop, mppsync, mpp_comm_free
81   PUBLIC   mpp_ini_north
82   PUBLIC   mpp_lnk_2d_icb
83   PUBLIC   mpp_lbc_north_icb
84   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc
85   PUBLIC   mpp_ilor
86   PUBLIC   mppscatter, mppgather
87   PUBLIC   mpp_ini_znl
88   PUBLIC   mppsize
89   PUBLIC   mppsend, mpprecv                          ! needed by TAM and ICB routines
90   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d, mpp_lnk_bdy_4d
91   PUBLIC   mpprank
92   
93   !! * Interfaces
94   !! define generic interface for these routine as they are called sometimes
95   !! with scalar arguments instead of array arguments, which causes problems
96   !! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
97   INTERFACE mpp_min
98      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
99   END INTERFACE
100   INTERFACE mpp_max
101      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
102   END INTERFACE
103   INTERFACE mpp_sum
104      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real,   &
105         &             mppsum_realdd, mppsum_a_realdd
106   END INTERFACE
107   INTERFACE mpp_minloc
108      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
109   END INTERFACE
110   INTERFACE mpp_maxloc
111      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
112   END INTERFACE
113
114   !! ========================= !!
115   !!  MPI  variable definition !!
116   !! ========================= !!
117!$AGRIF_DO_NOT_TREAT
118   INCLUDE 'mpif.h'
119!$AGRIF_END_DO_NOT_TREAT
120
121   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .TRUE.    !: mpp flag
122
123   INTEGER, PARAMETER         ::   nprocmax = 2**10   ! maximun dimension (required to be a power of 2)
124
125   INTEGER ::   mppsize        ! number of process
126   INTEGER ::   mpprank        ! process number  [ 0 - size-1 ]
127!$AGRIF_DO_NOT_TREAT
128   INTEGER, PUBLIC ::   mpi_comm_oce   ! opa local communicator
129!$AGRIF_END_DO_NOT_TREAT
130
131   INTEGER :: MPI_SUMDD
132
133   ! variables used for zonal integration
134   INTEGER, PUBLIC ::   ncomm_znl       !: communicator made by the processors on the same zonal average
135   LOGICAL, PUBLIC ::   l_znl_root      !: True on the 'left'most processor on the same row
136   INTEGER         ::   ngrp_znl        !  group ID for the znl processors
137   INTEGER         ::   ndim_rank_znl   !  number of processors on the same zonal average
138   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_znl  ! dimension ndim_rank_znl, number of the procs into the same znl domain
139
140   ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM)
141   INTEGER, PUBLIC ::   ngrp_world        !: group ID for the world processors
142   INTEGER, PUBLIC ::   ngrp_opa          !: group ID for the opa processors
143   INTEGER, PUBLIC ::   ngrp_north        !: group ID for the northern processors (to be fold)
144   INTEGER, PUBLIC ::   ncomm_north       !: communicator made by the processors belonging to ngrp_north
145   INTEGER, PUBLIC ::   ndim_rank_north   !: number of 'sea' processor in the northern line (can be /= jpni !)
146   INTEGER, PUBLIC ::   njmppmax          !: value of njmpp for the processors of the northern line
147   INTEGER, PUBLIC ::   north_root        !: number (in the comm_opa) of proc 0 in the northern comm
148   INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_north   !: dimension ndim_rank_north
149
150   ! Type of send : standard, buffered, immediate
151   CHARACTER(len=1), PUBLIC ::   cn_mpi_send        !: type od mpi send/recieve (S=standard, B=bsend, I=isend)
152   LOGICAL         , PUBLIC ::   l_isend = .FALSE.  !: isend use indicator (T if cn_mpi_send='I')
153   INTEGER         , PUBLIC ::   nn_buffer          !: size of the buffer in case of mpi_bsend
154
155   ! Communications summary report
156   CHARACTER(len=128), DIMENSION(:), ALLOCATABLE ::   crname_lbc                   !: names of lbc_lnk calling routines
157   CHARACTER(len=128), DIMENSION(:), ALLOCATABLE ::   crname_glb                   !: names of global comm  calling routines
158   INTEGER, PUBLIC                               ::   ncom_stp = 0                 !: copy of time step # istp
159   INTEGER, PUBLIC                               ::   ncom_fsbc = 1                !: copy of sbc time step # nn_fsbc
160   INTEGER, PUBLIC                               ::   ncom_dttrc = 1               !: copy of top time step # nn_dttrc
161   INTEGER, PUBLIC                               ::   ncom_freq                    !: frequency of comm diagnostic
162   INTEGER, PUBLIC , DIMENSION(:,:), ALLOCATABLE ::   ncomm_sequence               !: size of communicated arrays (halos)
163   INTEGER, PARAMETER, PUBLIC                    ::   ncom_rec_max = 2000          !: max number of communication record
164   INTEGER, PUBLIC                               ::   n_sequence_lbc = 0           !: # of communicated arraysvia lbc
165   INTEGER, PUBLIC                               ::   n_sequence_glb = 0           !: # of global communications
166   INTEGER, PUBLIC                               ::   numcom = -1                  !: logical unit for communicaton report
167
168   ! timing summary report
169   REAL(wp), DIMENSION(2), PUBLIC ::  waiting_time = 0._wp
170   REAL(wp)              , PUBLIC ::  compute_time = 0._wp, elapsed_time = 0._wp
171   
172   REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::   tampon   ! buffer in case of bsend
173
174   LOGICAL, PUBLIC ::   ln_nnogather                !: namelist control of northfold comms
175   LOGICAL, PUBLIC ::   l_north_nogather = .FALSE.  !: internal control of northfold comms
176
177   !!----------------------------------------------------------------------
178   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
179   !! $Id$
180   !! Software governed by the CeCILL license (see ./LICENSE)
181   !!----------------------------------------------------------------------
182CONTAINS
183
184   FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm )
185      !!----------------------------------------------------------------------
186      !!                  ***  routine mynode  ***
187      !!
188      !! ** Purpose :   Find processor unit
189      !!----------------------------------------------------------------------
190      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt        !
191      CHARACTER(len=*)             , INTENT(in   ) ::   ldname       !
192      INTEGER                      , INTENT(in   ) ::   kumnam_ref   ! logical unit for reference namelist
193      INTEGER                      , INTENT(in   ) ::   kumnam_cfg   ! logical unit for configuration namelist
194      INTEGER                      , INTENT(inout) ::   kumond       ! logical unit for namelist output
195      INTEGER                      , INTENT(inout) ::   kstop        ! stop indicator
196      INTEGER         , OPTIONAL   , INTENT(in   ) ::   localComm    !
197      !
198      INTEGER ::   mynode, ierr, code, ji, ii, ios
199      LOGICAL ::   mpi_was_called
200      !
201      NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij, ln_nnogather
202      !!----------------------------------------------------------------------
203      !
204      ii = 1
205      WRITE(ldtxt(ii),*)                                                                  ;   ii = ii + 1
206      WRITE(ldtxt(ii),*) 'mynode : mpi initialisation'                                    ;   ii = ii + 1
207      WRITE(ldtxt(ii),*) '~~~~~~ '                                                        ;   ii = ii + 1
208      !
209      REWIND( kumnam_ref )              ! Namelist nammpp in reference namelist: mpi variables
210      READ  ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901)
211901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp )
212      !
213      REWIND( kumnam_cfg )              ! Namelist nammpp in configuration namelist: mpi variables
214      READ  ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 )
215902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp )
216      !
217      !                              ! control print
218      WRITE(ldtxt(ii),*) '   Namelist nammpp'                                             ;   ii = ii + 1
219      WRITE(ldtxt(ii),*) '      mpi send type          cn_mpi_send = ', cn_mpi_send       ;   ii = ii + 1
220      WRITE(ldtxt(ii),*) '      size exported buffer   nn_buffer   = ', nn_buffer,' bytes';   ii = ii + 1
221      !
222#if defined key_agrif
223      IF( .NOT. Agrif_Root() ) THEN
224         jpni  = Agrif_Parent(jpni )
225         jpnj  = Agrif_Parent(jpnj )
226         jpnij = Agrif_Parent(jpnij)
227      ENDIF
228#endif
229      !
230      IF( jpnij < 1 ) THEN         ! If jpnij is not specified in namelist then we calculate it
231         jpnij = jpni * jpnj       ! this means there will be no land cutting out.
232      ENDIF
233
234      IF( jpni < 1 .OR. jpnj < 1  ) THEN
235         WRITE(ldtxt(ii),*) '      jpni, jpnj and jpnij will be calculated automatically' ;   ii = ii + 1
236      ELSE
237         WRITE(ldtxt(ii),*) '      processor grid extent in i         jpni = ',jpni       ;   ii = ii + 1
238         WRITE(ldtxt(ii),*) '      processor grid extent in j         jpnj = ',jpnj       ;   ii = ii + 1
239         WRITE(ldtxt(ii),*) '      number of local domains           jpnij = ',jpnij      ;   ii = ii + 1
240      ENDIF
241
242      WRITE(ldtxt(ii),*) '      avoid use of mpi_allgather at the north fold  ln_nnogather = ', ln_nnogather  ; ii = ii + 1
243
244      CALL mpi_initialized ( mpi_was_called, code )
245      IF( code /= MPI_SUCCESS ) THEN
246         DO ji = 1, SIZE(ldtxt)
247            IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
248         END DO
249         WRITE(*, cform_err)
250         WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized'
251         CALL mpi_abort( mpi_comm_world, code, ierr )
252      ENDIF
253
254      IF( mpi_was_called ) THEN
255         !
256         SELECT CASE ( cn_mpi_send )
257         CASE ( 'S' )                ! Standard mpi send (blocking)
258            WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'             ;   ii = ii + 1
259         CASE ( 'B' )                ! Buffer mpi send (blocking)
260            WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'              ;   ii = ii + 1
261            IF( Agrif_Root() )   CALL mpi_init_oce( ldtxt, ii, ierr )
262         CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
263            WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'           ;   ii = ii + 1
264            l_isend = .TRUE.
265         CASE DEFAULT
266            WRITE(ldtxt(ii),cform_err)                                                    ;   ii = ii + 1
267            WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send     ;   ii = ii + 1
268            kstop = kstop + 1
269         END SELECT
270         !
271      ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN
272         WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator '          ;   ii = ii + 1
273         WRITE(ldtxt(ii),*) '          without calling MPI_Init before ! '                ;   ii = ii + 1
274         kstop = kstop + 1
275      ELSE
276         SELECT CASE ( cn_mpi_send )
277         CASE ( 'S' )                ! Standard mpi send (blocking)
278            WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'             ;   ii = ii + 1
279            CALL mpi_init( ierr )
280         CASE ( 'B' )                ! Buffer mpi send (blocking)
281            WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'              ;   ii = ii + 1
282            IF( Agrif_Root() )   CALL mpi_init_oce( ldtxt, ii, ierr )
283         CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
284            WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'           ;   ii = ii + 1
285            l_isend = .TRUE.
286            CALL mpi_init( ierr )
287         CASE DEFAULT
288            WRITE(ldtxt(ii),cform_err)                                                    ;   ii = ii + 1
289            WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send     ;   ii = ii + 1
290            kstop = kstop + 1
291         END SELECT
292         !
293      ENDIF
294
295      IF( PRESENT(localComm) ) THEN
296         IF( Agrif_Root() ) THEN
297            mpi_comm_oce = localComm
298         ENDIF
299      ELSE
300         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code)
301         IF( code /= MPI_SUCCESS ) THEN
302            DO ji = 1, SIZE(ldtxt)
303               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
304            END DO
305            WRITE(*, cform_err)
306            WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
307            CALL mpi_abort( mpi_comm_world, code, ierr )
308         ENDIF
309      ENDIF
310
311#if defined key_agrif
312      IF( Agrif_Root() ) THEN
313         CALL Agrif_MPI_Init(mpi_comm_oce)
314      ELSE
315         CALL Agrif_MPI_set_grid_comm(mpi_comm_oce)
316      ENDIF
317#endif
318
319      CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr )
320      CALL mpi_comm_size( mpi_comm_oce, mppsize, ierr )
321      mynode = mpprank
322
323      IF( mynode == 0 ) THEN
324         CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )
325         WRITE(kumond, nammpp)     
326      ENDIF
327      !
328      CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr)
329      !
330   END FUNCTION mynode
331
332   !!----------------------------------------------------------------------
333   !!                   ***  routine mpp_lnk_(2,3,4)d  ***
334   !!
335   !!   * Argument : dummy argument use in mpp_lnk_... routines
336   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied
337   !!                cd_nat :   nature of array grid-points
338   !!                psgn   :   sign used across the north fold boundary
339   !!                kfld   :   optional, number of pt3d arrays
340   !!                cd_mpp :   optional, fill the overlap area only
341   !!                pval   :   optional, background value (used at closed boundaries)
342   !!----------------------------------------------------------------------
343   !
344   !                       !==  2D array and array of 2D pointer  ==!
345   !
346#  define DIM_2d
347#     define ROUTINE_LNK           mpp_lnk_2d
348#     include "mpp_lnk_generic.h90"
349#     undef ROUTINE_LNK
350#     define MULTI
351#     define ROUTINE_LNK           mpp_lnk_2d_ptr
352#     include "mpp_lnk_generic.h90"
353#     undef ROUTINE_LNK
354#     undef MULTI
355#  undef DIM_2d
356   !
357   !                       !==  3D array and array of 3D pointer  ==!
358   !
359#  define DIM_3d
360#     define ROUTINE_LNK           mpp_lnk_3d
361#     include "mpp_lnk_generic.h90"
362#     undef ROUTINE_LNK
363#     define MULTI
364#     define ROUTINE_LNK           mpp_lnk_3d_ptr
365#     include "mpp_lnk_generic.h90"
366#     undef ROUTINE_LNK
367#     undef MULTI
368#  undef DIM_3d
369   !
370   !                       !==  4D array and array of 4D pointer  ==!
371   !
372#  define DIM_4d
373#     define ROUTINE_LNK           mpp_lnk_4d
374#     include "mpp_lnk_generic.h90"
375#     undef ROUTINE_LNK
376#     define MULTI
377#     define ROUTINE_LNK           mpp_lnk_4d_ptr
378#     include "mpp_lnk_generic.h90"
379#     undef ROUTINE_LNK
380#     undef MULTI
381#  undef DIM_4d
382
383   !!----------------------------------------------------------------------
384   !!                   ***  routine mpp_nfd_(2,3,4)d  ***
385   !!
386   !!   * Argument : dummy argument use in mpp_nfd_... routines
387   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied
388   !!                cd_nat :   nature of array grid-points
389   !!                psgn   :   sign used across the north fold boundary
390   !!                kfld   :   optional, number of pt3d arrays
391   !!                cd_mpp :   optional, fill the overlap area only
392   !!                pval   :   optional, background value (used at closed boundaries)
393   !!----------------------------------------------------------------------
394   !
395   !                       !==  2D array and array of 2D pointer  ==!
396   !
397#  define DIM_2d
398#     define ROUTINE_NFD           mpp_nfd_2d
399#     include "mpp_nfd_generic.h90"
400#     undef ROUTINE_NFD
401#     define MULTI
402#     define ROUTINE_NFD           mpp_nfd_2d_ptr
403#     include "mpp_nfd_generic.h90"
404#     undef ROUTINE_NFD
405#     undef MULTI
406#  undef DIM_2d
407   !
408   !                       !==  3D array and array of 3D pointer  ==!
409   !
410#  define DIM_3d
411#     define ROUTINE_NFD           mpp_nfd_3d
412#     include "mpp_nfd_generic.h90"
413#     undef ROUTINE_NFD
414#     define MULTI
415#     define ROUTINE_NFD           mpp_nfd_3d_ptr
416#     include "mpp_nfd_generic.h90"
417#     undef ROUTINE_NFD
418#     undef MULTI
419#  undef DIM_3d
420   !
421   !                       !==  4D array and array of 4D pointer  ==!
422   !
423#  define DIM_4d
424#     define ROUTINE_NFD           mpp_nfd_4d
425#     include "mpp_nfd_generic.h90"
426#     undef ROUTINE_NFD
427#     define MULTI
428#     define ROUTINE_NFD           mpp_nfd_4d_ptr
429#     include "mpp_nfd_generic.h90"
430#     undef ROUTINE_NFD
431#     undef MULTI
432#  undef DIM_4d
433
434
435   !!----------------------------------------------------------------------
436   !!                   ***  routine mpp_lnk_bdy_(2,3,4)d  ***
437   !!
438   !!   * Argument : dummy argument use in mpp_lnk_... routines
439   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied
440   !!                cd_nat :   nature of array grid-points
441   !!                psgn   :   sign used across the north fold boundary
442   !!                kb_bdy :   BDY boundary set
443   !!                kfld   :   optional, number of pt3d arrays
444   !!----------------------------------------------------------------------
445   !
446   !                       !==  2D array and array of 2D pointer  ==!
447   !
448#  define DIM_2d
449#     define ROUTINE_BDY           mpp_lnk_bdy_2d
450#     include "mpp_bdy_generic.h90"
451#     undef ROUTINE_BDY
452#  undef DIM_2d
453   !
454   !                       !==  3D array and array of 3D pointer  ==!
455   !
456#  define DIM_3d
457#     define ROUTINE_BDY           mpp_lnk_bdy_3d
458#     include "mpp_bdy_generic.h90"
459#     undef ROUTINE_BDY
460#  undef DIM_3d
461   !
462   !                       !==  4D array and array of 4D pointer  ==!
463   !
464#  define DIM_4d
465#     define ROUTINE_BDY           mpp_lnk_bdy_4d
466#     include "mpp_bdy_generic.h90"
467#     undef ROUTINE_BDY
468#  undef DIM_4d
469
470   !!----------------------------------------------------------------------
471   !!
472   !!   load_array  &   mpp_lnk_2d_9    à generaliser a 3D et 4D
473   
474   
475   !!    mpp_lnk_sum_2d et 3D   ====>>>>>>   à virer du code !!!!
476   
477   
478   !!----------------------------------------------------------------------
479
480
481
482   SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
483      !!----------------------------------------------------------------------
484      !!                  ***  routine mppsend  ***
485      !!
486      !! ** Purpose :   Send messag passing array
487      !!
488      !!----------------------------------------------------------------------
489      REAL(wp), INTENT(inout) ::   pmess(*)   ! array of real
490      INTEGER , INTENT(in   ) ::   kbytes     ! size of the array pmess
491      INTEGER , INTENT(in   ) ::   kdest      ! receive process number
492      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message
493      INTEGER , INTENT(in   ) ::   md_req     ! argument for isend
494      !!
495      INTEGER ::   iflag
496      !!----------------------------------------------------------------------
497      !
498      SELECT CASE ( cn_mpi_send )
499      CASE ( 'S' )                ! Standard mpi send (blocking)
500         CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce        , iflag )
501      CASE ( 'B' )                ! Buffer mpi send (blocking)
502         CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce        , iflag )
503      CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
504         ! be carefull, one more argument here : the mpi request identifier..
505         CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag )
506      END SELECT
507      !
508   END SUBROUTINE mppsend
509
510
511   SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource )
512      !!----------------------------------------------------------------------
513      !!                  ***  routine mpprecv  ***
514      !!
515      !! ** Purpose :   Receive messag passing array
516      !!
517      !!----------------------------------------------------------------------
518      REAL(wp), INTENT(inout) ::   pmess(*)   ! array of real
519      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess
520      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message
521      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number
522      !!
523      INTEGER :: istatus(mpi_status_size)
524      INTEGER :: iflag
525      INTEGER :: use_source
526      !!----------------------------------------------------------------------
527      !
528      ! If a specific process number has been passed to the receive call,
529      ! use that one. Default is to use mpi_any_source
530      use_source = mpi_any_source
531      IF( PRESENT(ksource) )   use_source = ksource
532      !
533      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag )
534      !
535   END SUBROUTINE mpprecv
536
537
538   SUBROUTINE mppgather( ptab, kp, pio )
539      !!----------------------------------------------------------------------
540      !!                   ***  routine mppgather  ***
541      !!
542      !! ** Purpose :   Transfert between a local subdomain array and a work
543      !!     array which is distributed following the vertical level.
544      !!
545      !!----------------------------------------------------------------------
546      REAL(wp), DIMENSION(jpi,jpj)      , INTENT(in   ) ::   ptab   ! subdomain input array
547      INTEGER                           , INTENT(in   ) ::   kp     ! record length
548      REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT(  out) ::   pio    ! subdomain input array
549      !!
550      INTEGER :: itaille, ierror   ! temporary integer
551      !!---------------------------------------------------------------------
552      !
553      itaille = jpi * jpj
554      CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille     ,   &
555         &                            mpi_double_precision, kp , mpi_comm_oce, ierror )
556      !
557   END SUBROUTINE mppgather
558
559
560   SUBROUTINE mppscatter( pio, kp, ptab )
561      !!----------------------------------------------------------------------
562      !!                  ***  routine mppscatter  ***
563      !!
564      !! ** Purpose :   Transfert between awork array which is distributed
565      !!      following the vertical level and the local subdomain array.
566      !!
567      !!----------------------------------------------------------------------
568      REAL(wp), DIMENSION(jpi,jpj,jpnij)  ::   pio    ! output array
569      INTEGER                             ::   kp     ! Tag (not used with MPI
570      REAL(wp), DIMENSION(jpi,jpj)        ::   ptab   ! subdomain array input
571      !!
572      INTEGER :: itaille, ierror   ! temporary integer
573      !!---------------------------------------------------------------------
574      !
575      itaille = jpi * jpj
576      !
577      CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille     ,   &
578         &                            mpi_double_precision, kp  , mpi_comm_oce, ierror )
579      !
580   END SUBROUTINE mppscatter
581
582   !!
583   SUBROUTINE mpp_ilor( ld_switch, ldlast, kcom )
584      ! WARNING: must be used only once (by ice_dyn_adv_umx) because ll_switch and ireq are SAVE
585      !!----------------------------------------------------------------------
586      LOGICAL, INTENT(inout), DIMENSION(2) ::   ld_switch
587      LOGICAL, INTENT(in   ), OPTIONAL     ::   ldlast
588      INTEGER, INTENT(in   ), OPTIONAL     ::   kcom 
589      INTEGER  ::   ierror, ilocalcomm
590      LOGICAL, SAVE ::   ll_switch 
591      INTEGER, SAVE ::   ireq = -1
592      !!----------------------------------------------------------------------
593      ilocalcomm = mpi_comm_oce
594      IF( PRESENT(kcom) )   ilocalcomm = kcom
595     
596      IF ( ireq /= -1 ) THEN   ! get ld_switch(2) from ll_switch (from previous call)
597         IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.)
598         CALL mpi_wait(ireq, MPI_STATUS_IGNORE, ierror )
599         ld_switch(2) = ll_switch
600         IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
601      ENDIF
602      IF( .NOT. ldlast ) &     ! send ll_switch to be received on next call
603         CALL mpi_iallreduce( ld_switch(1), ll_switch, 1, MPI_LOGICAL, mpi_lor, ilocalcomm, ireq, ierror )
604
605   END SUBROUTINE mpp_ilor
606   
607   !!----------------------------------------------------------------------
608   !!    ***  mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real  ***
609   !!   
610   !!----------------------------------------------------------------------
611   !!
612#  define OPERATION_MAX
613#  define INTEGER_TYPE
614#  define DIM_0d
615#     define ROUTINE_ALLREDUCE           mppmax_int
616#     include "mpp_allreduce_generic.h90"
617#     undef ROUTINE_ALLREDUCE
618#  undef DIM_0d
619#  define DIM_1d
620#     define ROUTINE_ALLREDUCE           mppmax_a_int
621#     include "mpp_allreduce_generic.h90"
622#     undef ROUTINE_ALLREDUCE
623#  undef DIM_1d
624#  undef INTEGER_TYPE
625!
626#  define REAL_TYPE
627#  define DIM_0d
628#     define ROUTINE_ALLREDUCE           mppmax_real
629#     include "mpp_allreduce_generic.h90"
630#     undef ROUTINE_ALLREDUCE
631#  undef DIM_0d
632#  define DIM_1d
633#     define ROUTINE_ALLREDUCE           mppmax_a_real
634#     include "mpp_allreduce_generic.h90"
635#     undef ROUTINE_ALLREDUCE
636#  undef DIM_1d
637#  undef REAL_TYPE
638#  undef OPERATION_MAX
639   !!----------------------------------------------------------------------
640   !!    ***  mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real  ***
641   !!   
642   !!----------------------------------------------------------------------
643   !!
644#  define OPERATION_MIN
645#  define INTEGER_TYPE
646#  define DIM_0d
647#     define ROUTINE_ALLREDUCE           mppmin_int
648#     include "mpp_allreduce_generic.h90"
649#     undef ROUTINE_ALLREDUCE
650#  undef DIM_0d
651#  define DIM_1d
652#     define ROUTINE_ALLREDUCE           mppmin_a_int
653#     include "mpp_allreduce_generic.h90"
654#     undef ROUTINE_ALLREDUCE
655#  undef DIM_1d
656#  undef INTEGER_TYPE
657!
658#  define REAL_TYPE
659#  define DIM_0d
660#     define ROUTINE_ALLREDUCE           mppmin_real
661#     include "mpp_allreduce_generic.h90"
662#     undef ROUTINE_ALLREDUCE
663#  undef DIM_0d
664#  define DIM_1d
665#     define ROUTINE_ALLREDUCE           mppmin_a_real
666#     include "mpp_allreduce_generic.h90"
667#     undef ROUTINE_ALLREDUCE
668#  undef DIM_1d
669#  undef REAL_TYPE
670#  undef OPERATION_MIN
671
672   !!----------------------------------------------------------------------
673   !!    ***  mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real  ***
674   !!   
675   !!   Global sum of 1D array or a variable (integer, real or complex)
676   !!----------------------------------------------------------------------
677   !!
678#  define OPERATION_SUM
679#  define INTEGER_TYPE
680#  define DIM_0d
681#     define ROUTINE_ALLREDUCE           mppsum_int
682#     include "mpp_allreduce_generic.h90"
683#     undef ROUTINE_ALLREDUCE
684#  undef DIM_0d
685#  define DIM_1d
686#     define ROUTINE_ALLREDUCE           mppsum_a_int
687#     include "mpp_allreduce_generic.h90"
688#     undef ROUTINE_ALLREDUCE
689#  undef DIM_1d
690#  undef INTEGER_TYPE
691!
692#  define REAL_TYPE
693#  define DIM_0d
694#     define ROUTINE_ALLREDUCE           mppsum_real
695#     include "mpp_allreduce_generic.h90"
696#     undef ROUTINE_ALLREDUCE
697#  undef DIM_0d
698#  define DIM_1d
699#     define ROUTINE_ALLREDUCE           mppsum_a_real
700#     include "mpp_allreduce_generic.h90"
701#     undef ROUTINE_ALLREDUCE
702#  undef DIM_1d
703#  undef REAL_TYPE
704#  undef OPERATION_SUM
705
706#  define OPERATION_SUM_DD
707#  define COMPLEX_TYPE
708#  define DIM_0d
709#     define ROUTINE_ALLREDUCE           mppsum_realdd
710#     include "mpp_allreduce_generic.h90"
711#     undef ROUTINE_ALLREDUCE
712#  undef DIM_0d
713#  define DIM_1d
714#     define ROUTINE_ALLREDUCE           mppsum_a_realdd
715#     include "mpp_allreduce_generic.h90"
716#     undef ROUTINE_ALLREDUCE
717#  undef DIM_1d
718#  undef COMPLEX_TYPE
719#  undef OPERATION_SUM_DD
720
721   !!----------------------------------------------------------------------
722   !!    ***  mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d
723   !!   
724   !!----------------------------------------------------------------------
725   !!
726#  define OPERATION_MINLOC
727#  define DIM_2d
728#     define ROUTINE_LOC           mpp_minloc2d
729#     include "mpp_loc_generic.h90"
730#     undef ROUTINE_LOC
731#  undef DIM_2d
732#  define DIM_3d
733#     define ROUTINE_LOC           mpp_minloc3d
734#     include "mpp_loc_generic.h90"
735#     undef ROUTINE_LOC
736#  undef DIM_3d
737#  undef OPERATION_MINLOC
738
739#  define OPERATION_MAXLOC
740#  define DIM_2d
741#     define ROUTINE_LOC           mpp_maxloc2d
742#     include "mpp_loc_generic.h90"
743#     undef ROUTINE_LOC
744#  undef DIM_2d
745#  define DIM_3d
746#     define ROUTINE_LOC           mpp_maxloc3d
747#     include "mpp_loc_generic.h90"
748#     undef ROUTINE_LOC
749#  undef DIM_3d
750#  undef OPERATION_MAXLOC
751
752   SUBROUTINE mppsync()
753      !!----------------------------------------------------------------------
754      !!                  ***  routine mppsync  ***
755      !!
756      !! ** Purpose :   Massively parallel processors, synchroneous
757      !!
758      !!-----------------------------------------------------------------------
759      INTEGER :: ierror
760      !!-----------------------------------------------------------------------
761      !
762      CALL mpi_barrier( mpi_comm_oce, ierror )
763      !
764   END SUBROUTINE mppsync
765
766
767   SUBROUTINE mppstop
768      !!----------------------------------------------------------------------
769      !!                  ***  routine mppstop  ***
770      !!
771      !! ** purpose :   Stop massively parallel processors method
772      !!
773      !!----------------------------------------------------------------------
774      INTEGER ::   info
775      !!----------------------------------------------------------------------
776      !
777      CALL mppsync
778      CALL mpi_finalize( info )
779      !
780   END SUBROUTINE mppstop
781
782
783   SUBROUTINE mpp_comm_free( kcom )
784      !!----------------------------------------------------------------------
785      INTEGER, INTENT(in) ::   kcom
786      !!
787      INTEGER :: ierr
788      !!----------------------------------------------------------------------
789      !
790      CALL MPI_COMM_FREE(kcom, ierr)
791      !
792   END SUBROUTINE mpp_comm_free
793
794
795   SUBROUTINE mpp_ini_znl( kumout )
796      !!----------------------------------------------------------------------
797      !!               ***  routine mpp_ini_znl  ***
798      !!
799      !! ** Purpose :   Initialize special communicator for computing zonal sum
800      !!
801      !! ** Method  : - Look for processors in the same row
802      !!              - Put their number in nrank_znl
803      !!              - Create group for the znl processors
804      !!              - Create a communicator for znl processors
805      !!              - Determine if processor should write znl files
806      !!
807      !! ** output
808      !!      ndim_rank_znl = number of processors on the same row
809      !!      ngrp_znl = group ID for the znl processors
810      !!      ncomm_znl = communicator for the ice procs.
811      !!      n_znl_root = number (in the world) of proc 0 in the ice comm.
812      !!
813      !!----------------------------------------------------------------------
814      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical units
815      !
816      INTEGER :: jproc      ! dummy loop integer
817      INTEGER :: ierr, ii   ! local integer
818      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kwork
819      !!----------------------------------------------------------------------
820      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world     : ', ngrp_world
821      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
822      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_oce   : ', mpi_comm_oce
823      !
824      ALLOCATE( kwork(jpnij), STAT=ierr )
825      IF( ierr /= 0 ) THEN
826         WRITE(kumout, cform_err)
827         WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij'
828         CALL mppstop
829      ENDIF
830
831      IF( jpnj == 1 ) THEN
832         ngrp_znl  = ngrp_world
833         ncomm_znl = mpi_comm_oce
834      ELSE
835         !
836         CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_oce, ierr )
837         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
838         !-$$        CALL flush(numout)
839         !
840         ! Count number of processors on the same row
841         ndim_rank_znl = 0
842         DO jproc=1,jpnij
843            IF ( kwork(jproc) == njmpp ) THEN
844               ndim_rank_znl = ndim_rank_znl + 1
845            ENDIF
846         END DO
847         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
848         !-$$        CALL flush(numout)
849         ! Allocate the right size to nrank_znl
850         IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
851         ALLOCATE(nrank_znl(ndim_rank_znl))
852         ii = 0
853         nrank_znl (:) = 0
854         DO jproc=1,jpnij
855            IF ( kwork(jproc) == njmpp) THEN
856               ii = ii + 1
857               nrank_znl(ii) = jproc -1
858            ENDIF
859         END DO
860         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
861         !-$$        CALL flush(numout)
862
863         ! Create the opa group
864         CALL MPI_COMM_GROUP(mpi_comm_oce,ngrp_opa,ierr)
865         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
866         !-$$        CALL flush(numout)
867
868         ! Create the znl group from the opa group
869         CALL MPI_GROUP_INCL  ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
870         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
871         !-$$        CALL flush(numout)
872
873         ! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
874         CALL MPI_COMM_CREATE ( mpi_comm_oce, ngrp_znl, ncomm_znl, ierr )
875         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
876         !-$$        CALL flush(numout)
877         !
878      END IF
879
880      ! Determines if processor if the first (starting from i=1) on the row
881      IF ( jpni == 1 ) THEN
882         l_znl_root = .TRUE.
883      ELSE
884         l_znl_root = .FALSE.
885         kwork (1) = nimpp
886         CALL mpp_min ( 'lib_mpp', kwork(1), kcom = ncomm_znl)
887         IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
888      END IF
889
890      DEALLOCATE(kwork)
891
892   END SUBROUTINE mpp_ini_znl
893
894
895   SUBROUTINE mpp_ini_north
896      !!----------------------------------------------------------------------
897      !!               ***  routine mpp_ini_north  ***
898      !!
899      !! ** Purpose :   Initialize special communicator for north folding
900      !!      condition together with global variables needed in the mpp folding
901      !!
902      !! ** Method  : - Look for northern processors
903      !!              - Put their number in nrank_north
904      !!              - Create groups for the world processors and the north processors
905      !!              - Create a communicator for northern processors
906      !!
907      !! ** output
908      !!      njmppmax = njmpp for northern procs
909      !!      ndim_rank_north = number of processors in the northern line
910      !!      nrank_north (ndim_rank_north) = number  of the northern procs.
911      !!      ngrp_world = group ID for the world processors
912      !!      ngrp_north = group ID for the northern processors
913      !!      ncomm_north = communicator for the northern procs.
914      !!      north_root = number (in the world) of proc 0 in the northern comm.
915      !!
916      !!----------------------------------------------------------------------
917      INTEGER ::   ierr
918      INTEGER ::   jjproc
919      INTEGER ::   ii, ji
920      !!----------------------------------------------------------------------
921      !
922      njmppmax = MAXVAL( njmppt )
923      !
924      ! Look for how many procs on the northern boundary
925      ndim_rank_north = 0
926      DO jjproc = 1, jpnij
927         IF( njmppt(jjproc) == njmppmax )   ndim_rank_north = ndim_rank_north + 1
928      END DO
929      !
930      ! Allocate the right size to nrank_north
931      IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
932      ALLOCATE( nrank_north(ndim_rank_north) )
933
934      ! Fill the nrank_north array with proc. number of northern procs.
935      ! Note : the rank start at 0 in MPI
936      ii = 0
937      DO ji = 1, jpnij
938         IF ( njmppt(ji) == njmppmax   ) THEN
939            ii=ii+1
940            nrank_north(ii)=ji-1
941         END IF
942      END DO
943      !
944      ! create the world group
945      CALL MPI_COMM_GROUP( mpi_comm_oce, ngrp_world, ierr )
946      !
947      ! Create the North group from the world group
948      CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
949      !
950      ! Create the North communicator , ie the pool of procs in the north group
951      CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr )
952      !
953   END SUBROUTINE mpp_ini_north
954
955
956   SUBROUTINE mpi_init_oce( ldtxt, ksft, code )
957      !!---------------------------------------------------------------------
958      !!                   ***  routine mpp_init.opa  ***
959      !!
960      !! ** Purpose :: export and attach a MPI buffer for bsend
961      !!
962      !! ** Method  :: define buffer size in namelist, if 0 no buffer attachment
963      !!            but classical mpi_init
964      !!
965      !! History :: 01/11 :: IDRIS initial version for IBM only
966      !!            08/04 :: R. Benshila, generalisation
967      !!---------------------------------------------------------------------
968      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt
969      INTEGER                      , INTENT(inout) ::   ksft
970      INTEGER                      , INTENT(  out) ::   code
971      INTEGER                                      ::   ierr, ji
972      LOGICAL                                      ::   mpi_was_called
973      !!---------------------------------------------------------------------
974      !
975      CALL mpi_initialized( mpi_was_called, code )      ! MPI initialization
976      IF ( code /= MPI_SUCCESS ) THEN
977         DO ji = 1, SIZE(ldtxt)
978            IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
979         END DO
980         WRITE(*, cform_err)
981         WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized'
982         CALL mpi_abort( mpi_comm_world, code, ierr )
983      ENDIF
984      !
985      IF( .NOT. mpi_was_called ) THEN
986         CALL mpi_init( code )
987         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code )
988         IF ( code /= MPI_SUCCESS ) THEN
989            DO ji = 1, SIZE(ldtxt)
990               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
991            END DO
992            WRITE(*, cform_err)
993            WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
994            CALL mpi_abort( mpi_comm_world, code, ierr )
995         ENDIF
996      ENDIF
997      !
998      IF( nn_buffer > 0 ) THEN
999         WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of  : ', nn_buffer   ;   ksft = ksft + 1
1000         ! Buffer allocation and attachment
1001         ALLOCATE( tampon(nn_buffer), stat = ierr )
1002         IF( ierr /= 0 ) THEN
1003            DO ji = 1, SIZE(ldtxt)
1004               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
1005            END DO
1006            WRITE(*, cform_err)
1007            WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr
1008            CALL mpi_abort( mpi_comm_world, code, ierr )
1009         END IF
1010         CALL mpi_buffer_attach( tampon, nn_buffer, code )
1011      ENDIF
1012      !
1013   END SUBROUTINE mpi_init_oce
1014
1015
1016   SUBROUTINE DDPDD_MPI( ydda, yddb, ilen, itype )
1017      !!---------------------------------------------------------------------
1018      !!   Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
1019      !!
1020      !!   Modification of original codes written by David H. Bailey
1021      !!   This subroutine computes yddb(i) = ydda(i)+yddb(i)
1022      !!---------------------------------------------------------------------
1023      INTEGER                     , INTENT(in)    ::   ilen, itype
1024      COMPLEX(wp), DIMENSION(ilen), INTENT(in)    ::   ydda
1025      COMPLEX(wp), DIMENSION(ilen), INTENT(inout) ::   yddb
1026      !
1027      REAL(wp) :: zerr, zt1, zt2    ! local work variables
1028      INTEGER  :: ji, ztmp           ! local scalar
1029      !!---------------------------------------------------------------------
1030      !
1031      ztmp = itype   ! avoid compilation warning
1032      !
1033      DO ji=1,ilen
1034      ! Compute ydda + yddb using Knuth's trick.
1035         zt1  = real(ydda(ji)) + real(yddb(ji))
1036         zerr = zt1 - real(ydda(ji))
1037         zt2  = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
1038                + aimag(ydda(ji)) + aimag(yddb(ji))
1039
1040         ! The result is zt1 + zt2, after normalization.
1041         yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
1042      END DO
1043      !
1044   END SUBROUTINE DDPDD_MPI
1045
1046
1047   SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj)
1048      !!---------------------------------------------------------------------
1049      !!                   ***  routine mpp_lbc_north_icb  ***
1050      !!
1051      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
1052      !!              in mpp configuration in case of jpn1 > 1 and for 2d
1053      !!              array with outer extra halo
1054      !!
1055      !! ** Method  :   North fold condition and mpp with more than one proc
1056      !!              in i-direction require a specific treatment. We gather
1057      !!              the 4+kextj northern lines of the global domain on 1
1058      !!              processor and apply lbc north-fold on this sub array.
1059      !!              Then we scatter the north fold array back to the processors.
1060      !!              This routine accounts for an extra halo with icebergs
1061      !!              and assumes ghost rows and columns have been suppressed.
1062      !!
1063      !!----------------------------------------------------------------------
1064      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo
1065      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points
1066      !                                                     !   = T ,  U , V , F or W -points
1067      REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the
1068      !!                                                    ! north fold, =  1. otherwise
1069      INTEGER                 , INTENT(in   ) ::   kextj    ! Extra halo width at north fold
1070      !
1071      INTEGER ::   ji, jj, jr
1072      INTEGER ::   ierr, itaille, ildi, ilei, iilb
1073      INTEGER ::   ipj, ij, iproc
1074      !
1075      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e
1076      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e
1077      !!----------------------------------------------------------------------
1078      !
1079      ipj=4
1080      ALLOCATE(        ztab_e(jpiglo, 1-kextj:ipj+kextj)       ,       &
1081     &            znorthloc_e(jpimax, 1-kextj:ipj+kextj)       ,       &
1082     &          znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni)    )
1083      !
1084      ztab_e(:,:)      = 0._wp
1085      znorthloc_e(:,:) = 0._wp
1086      !
1087      ij = 1 - kextj
1088      ! put the last ipj+2*kextj lines of pt2d into znorthloc_e
1089      DO jj = jpj - ipj + 1 - kextj , jpj + kextj
1090         znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj)
1091         ij = ij + 1
1092      END DO
1093      !
1094      itaille = jpimax * ( ipj + 2*kextj )
1095      !
1096      IF( ln_timing ) CALL tic_tac(.TRUE.)
1097      CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj)    , itaille, MPI_DOUBLE_PRECISION,    &
1098         &                znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION,    &
1099         &                ncomm_north, ierr )
1100      !
1101      IF( ln_timing ) CALL tic_tac(.FALSE.)
1102      !
1103      DO jr = 1, ndim_rank_north            ! recover the global north array
1104         iproc = nrank_north(jr) + 1
1105         ildi = nldit (iproc)
1106         ilei = nleit (iproc)
1107         iilb = nimppt(iproc)
1108         DO jj = 1-kextj, ipj+kextj
1109            DO ji = ildi, ilei
1110               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
1111            END DO
1112         END DO
1113      END DO
1114
1115      ! 2. North-Fold boundary conditions
1116      ! ----------------------------------
1117      CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj )
1118
1119      ij = 1 - kextj
1120      !! Scatter back to pt2d
1121      DO jj = jpj - ipj + 1 - kextj , jpj + kextj
1122         DO ji= 1, jpi
1123            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
1124         END DO
1125         ij  = ij +1
1126      END DO
1127      !
1128      DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
1129      !
1130   END SUBROUTINE mpp_lbc_north_icb
1131
1132
1133   SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj )
1134      !!----------------------------------------------------------------------
1135      !!                  ***  routine mpp_lnk_2d_icb  ***
1136      !!
1137      !! ** Purpose :   Message passing management for 2d array (with extra halo for icebergs)
1138      !!                This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj)
1139      !!                array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls.
1140      !!
1141      !! ** Method  :   Use mppsend and mpprecv function for passing mask
1142      !!      between processors following neighboring subdomains.
1143      !!            domain parameters
1144      !!                    jpi    : first dimension of the local subdomain
1145      !!                    jpj    : second dimension of the local subdomain
1146      !!                    kexti  : number of columns for extra outer halo
1147      !!                    kextj  : number of rows for extra outer halo
1148      !!                    nbondi : mark for "east-west local boundary"
1149      !!                    nbondj : mark for "north-south local boundary"
1150      !!                    noea   : number for local neighboring processors
1151      !!                    nowe   : number for local neighboring processors
1152      !!                    noso   : number for local neighboring processors
1153      !!                    nono   : number for local neighboring processors
1154      !!----------------------------------------------------------------------
1155      CHARACTER(len=*)                                        , INTENT(in   ) ::   cdname      ! name of the calling subroutine
1156      REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
1157      CHARACTER(len=1)                                        , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points
1158      REAL(wp)                                                , INTENT(in   ) ::   psgn     ! sign used across the north fold
1159      INTEGER                                                 , INTENT(in   ) ::   kexti    ! extra i-halo width
1160      INTEGER                                                 , INTENT(in   ) ::   kextj    ! extra j-halo width
1161      !
1162      INTEGER  ::   jl   ! dummy loop indices
1163      INTEGER  ::   imigr, iihom, ijhom        ! local integers
1164      INTEGER  ::   ipreci, iprecj             !   -       -
1165      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
1166      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
1167      !!
1168      REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) ::   r2dns, r2dsn
1169      REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) ::   r2dwe, r2dew
1170      !!----------------------------------------------------------------------
1171
1172      ipreci = nn_hls + kexti      ! take into account outer extra 2D overlap area
1173      iprecj = nn_hls + kextj
1174
1175      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. )
1176
1177      ! 1. standard boundary treatment
1178      ! ------------------------------
1179      ! Order matters Here !!!!
1180      !
1181      !                                      ! East-West boundaries
1182      !                                           !* Cyclic east-west
1183      IF( l_Iperio ) THEN
1184         pt2d(1-kexti:     1   ,:) = pt2d(jpim1-kexti: jpim1 ,:)       ! east
1185         pt2d(  jpi  :jpi+kexti,:) = pt2d(     2     :2+kexti,:)       ! west
1186         !
1187      ELSE                                        !* closed
1188         IF( .NOT. cd_type == 'F' )   pt2d(  1-kexti   :nn_hls   ,:) = 0._wp    ! east except at F-point
1189                                      pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp    ! west
1190      ENDIF
1191      !                                      ! North-South boundaries
1192      IF( l_Jperio ) THEN                         !* cyclic (only with no mpp j-split)
1193         pt2d(:,1-kextj:     1   ) = pt2d(:,jpjm1-kextj:  jpjm1)       ! north
1194         pt2d(:,  jpj  :jpj+kextj) = pt2d(:,     2     :2+kextj)       ! south
1195      ELSE                                        !* closed
1196         IF( .NOT. cd_type == 'F' )   pt2d(:,  1-kextj   :nn_hls   ) = 0._wp    ! north except at F-point
1197                                      pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp    ! south
1198      ENDIF
1199      !
1200
1201      ! north fold treatment
1202      ! -----------------------
1203      IF( npolj /= 0 ) THEN
1204         !
1205         SELECT CASE ( jpni )
1206                   CASE ( 1 )     ;   CALL lbc_nfd          ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )
1207                   CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )
1208         END SELECT
1209         !
1210      ENDIF
1211
1212      ! 2. East and west directions exchange
1213      ! ------------------------------------
1214      ! we play with the neigbours AND the row number because of the periodicity
1215      !
1216      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
1217      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
1218         iihom = jpi-nreci-kexti
1219         DO jl = 1, ipreci
1220            r2dew(:,jl,1) = pt2d(nn_hls+jl,:)
1221            r2dwe(:,jl,1) = pt2d(iihom +jl,:)
1222         END DO
1223      END SELECT
1224      !
1225      !                           ! Migrations
1226      imigr = ipreci * ( jpj + 2*kextj )
1227      !
1228      IF( ln_timing ) CALL tic_tac(.TRUE.)
1229      !
1230      SELECT CASE ( nbondi )
1231      CASE ( -1 )
1232         CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 )
1233         CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )
1234         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1235      CASE ( 0 )
1236         CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )
1237         CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 )
1238         CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )
1239         CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )
1240         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1241         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1242      CASE ( 1 )
1243         CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )
1244         CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )
1245         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1246      END SELECT
1247      !
1248      IF( ln_timing ) CALL tic_tac(.FALSE.)
1249      !
1250      !                           ! Write Dirichlet lateral conditions
1251      iihom = jpi - nn_hls
1252      !
1253      SELECT CASE ( nbondi )
1254      CASE ( -1 )
1255         DO jl = 1, ipreci
1256            pt2d(iihom+jl,:) = r2dew(:,jl,2)
1257         END DO
1258      CASE ( 0 )
1259         DO jl = 1, ipreci
1260            pt2d(jl-kexti,:) = r2dwe(:,jl,2)
1261            pt2d(iihom+jl,:) = r2dew(:,jl,2)
1262         END DO
1263      CASE ( 1 )
1264         DO jl = 1, ipreci
1265            pt2d(jl-kexti,:) = r2dwe(:,jl,2)
1266         END DO
1267      END SELECT
1268
1269
1270      ! 3. North and south directions
1271      ! -----------------------------
1272      ! always closed : we play only with the neigbours
1273      !
1274      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
1275         ijhom = jpj-nrecj-kextj
1276         DO jl = 1, iprecj
1277            r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
1278            r2dns(:,jl,1) = pt2d(:,nn_hls+jl)
1279         END DO
1280      ENDIF
1281      !
1282      !                           ! Migrations
1283      imigr = iprecj * ( jpi + 2*kexti )
1284      !
1285      IF( ln_timing ) CALL tic_tac(.TRUE.)
1286      !
1287      SELECT CASE ( nbondj )
1288      CASE ( -1 )
1289         CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 )
1290         CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )
1291         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1292      CASE ( 0 )
1293         CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )
1294         CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 )
1295         CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )
1296         CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )
1297         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1298         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1299      CASE ( 1 )
1300         CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )
1301         CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )
1302         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1303      END SELECT
1304      !
1305      IF( ln_timing ) CALL tic_tac(.FALSE.)
1306      !
1307      !                           ! Write Dirichlet lateral conditions
1308      ijhom = jpj - nn_hls
1309      !
1310      SELECT CASE ( nbondj )
1311      CASE ( -1 )
1312         DO jl = 1, iprecj
1313            pt2d(:,ijhom+jl) = r2dns(:,jl,2)
1314         END DO
1315      CASE ( 0 )
1316         DO jl = 1, iprecj
1317            pt2d(:,jl-kextj) = r2dsn(:,jl,2)
1318            pt2d(:,ijhom+jl) = r2dns(:,jl,2)
1319         END DO
1320      CASE ( 1 )
1321         DO jl = 1, iprecj
1322            pt2d(:,jl-kextj) = r2dsn(:,jl,2)
1323         END DO
1324      END SELECT
1325      !
1326   END SUBROUTINE mpp_lnk_2d_icb
1327
1328
1329   SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb )
1330      !!----------------------------------------------------------------------
1331      !!                  ***  routine mpp_report  ***
1332      !!
1333      !! ** Purpose :   report use of mpp routines per time-setp
1334      !!
1335      !!----------------------------------------------------------------------
1336      CHARACTER(len=*),           INTENT(in   ) ::   cdname      ! name of the calling subroutine
1337      INTEGER         , OPTIONAL, INTENT(in   ) ::   kpk, kpl, kpf
1338      LOGICAL         , OPTIONAL, INTENT(in   ) ::   ld_lbc, ld_glb
1339      !!
1340      LOGICAL ::   ll_lbc, ll_glb
1341      INTEGER ::    ji,  jj,  jk,  jh, jf   ! dummy loop indices
1342      !!----------------------------------------------------------------------
1343      !
1344      ll_lbc = .FALSE.
1345      IF( PRESENT(ld_lbc) ) ll_lbc = ld_lbc
1346      ll_glb = .FALSE.
1347      IF( PRESENT(ld_glb) ) ll_glb = ld_glb
1348      !
1349      ! find the smallest common frequency: default = frequency product, if multiple, choose the larger of the 2 frequency
1350      ncom_freq = ncom_fsbc * ncom_dttrc
1351      IF( MOD( MAX(ncom_fsbc,ncom_dttrc), MIN(ncom_fsbc,ncom_dttrc) ) == 0 ) ncom_freq = MAX(ncom_fsbc,ncom_dttrc)
1352      !
1353      IF ( ncom_stp == nit000+ncom_freq ) THEN   ! avoid to count extra communications in potential initializations at nit000
1354         IF( ll_lbc ) THEN
1355            IF( .NOT. ALLOCATED(ncomm_sequence) ) ALLOCATE( ncomm_sequence(ncom_rec_max,2) )
1356            IF( .NOT. ALLOCATED(    crname_lbc) ) ALLOCATE(     crname_lbc(ncom_rec_max  ) )
1357            n_sequence_lbc = n_sequence_lbc + 1
1358            IF( n_sequence_lbc > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lnk_generic, increase ncom_rec_max' )   ! deadlock
1359            crname_lbc(n_sequence_lbc) = cdname     ! keep the name of the calling routine
1360            ncomm_sequence(n_sequence_lbc,1) = kpk*kpl   ! size of 3rd and 4th dimensions
1361            ncomm_sequence(n_sequence_lbc,2) = kpf       ! number of arrays to be treated (multi)
1362         ENDIF
1363         IF( ll_glb ) THEN
1364            IF( .NOT. ALLOCATED(crname_glb) ) ALLOCATE( crname_glb(ncom_rec_max) )
1365            n_sequence_glb = n_sequence_glb + 1
1366            IF( n_sequence_glb > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lnk_generic, increase ncom_rec_max' )   ! deadlock
1367            crname_glb(n_sequence_glb) = cdname     ! keep the name of the calling routine
1368         ENDIF
1369      ELSE IF ( ncom_stp == nit000+2*ncom_freq ) THEN
1370         CALL ctl_opn( numcom, 'communication_report.txt', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea )
1371         WRITE(numcom,*) ' '
1372         WRITE(numcom,*) ' ------------------------------------------------------------'
1373         WRITE(numcom,*) ' Communication pattern report (second oce+sbc+top time step):'
1374         WRITE(numcom,*) ' ------------------------------------------------------------'
1375         WRITE(numcom,*) ' '
1376         WRITE(numcom,'(A,I4)') ' Exchanged halos : ', n_sequence_lbc
1377         jj = 0; jk = 0; jf = 0; jh = 0
1378         DO ji = 1, n_sequence_lbc
1379            IF ( ncomm_sequence(ji,1) .GT. 1 ) jk = jk + 1
1380            IF ( ncomm_sequence(ji,2) .GT. 1 ) jf = jf + 1
1381            IF ( ncomm_sequence(ji,1) .GT. 1 .AND. ncomm_sequence(ji,2) .GT. 1 ) jj = jj + 1
1382            jh = MAX (jh, ncomm_sequence(ji,1)*ncomm_sequence(ji,2))
1383         END DO
1384         WRITE(numcom,'(A,I3)') ' 3D Exchanged halos : ', jk
1385         WRITE(numcom,'(A,I3)') ' Multi arrays exchanged halos : ', jf
1386         WRITE(numcom,'(A,I3)') '   from which 3D : ', jj
1387         WRITE(numcom,'(A,I10)') ' Array max size : ', jh*jpi*jpj
1388         WRITE(numcom,*) ' '
1389         WRITE(numcom,*) ' lbc_lnk called'
1390         jj = 1
1391         DO ji = 2, n_sequence_lbc
1392            IF( crname_lbc(ji-1) /= crname_lbc(ji) ) THEN
1393               WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(ji-1))
1394               jj = 0
1395            END IF
1396            jj = jj + 1 
1397         END DO
1398         WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(n_sequence_lbc))
1399         WRITE(numcom,*) ' '
1400         IF ( n_sequence_glb > 0 ) THEN
1401            WRITE(numcom,'(A,I4)') ' Global communications : ', n_sequence_glb
1402            jj = 1
1403            DO ji = 2, n_sequence_glb
1404               IF( crname_glb(ji-1) /= crname_glb(ji) ) THEN
1405                  WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(ji-1))
1406                  jj = 0
1407               END IF
1408               jj = jj + 1 
1409            END DO
1410            WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(n_sequence_glb))
1411            DEALLOCATE(crname_glb)
1412         ELSE
1413            WRITE(numcom,*) ' No MPI global communication '
1414         ENDIF
1415         WRITE(numcom,*) ' '
1416         WRITE(numcom,*) ' -----------------------------------------------'
1417         WRITE(numcom,*) ' '
1418         DEALLOCATE(ncomm_sequence)
1419         DEALLOCATE(crname_lbc)
1420      ENDIF
1421   END SUBROUTINE mpp_report
1422
1423   
1424   SUBROUTINE tic_tac (ld_tic, ld_global)
1425
1426    LOGICAL,           INTENT(IN) :: ld_tic
1427    LOGICAL, OPTIONAL, INTENT(IN) :: ld_global
1428    REAL(wp), DIMENSION(2), SAVE :: tic_wt
1429    REAL(wp),               SAVE :: tic_ct = 0._wp
1430    INTEGER :: ii
1431
1432    IF( ncom_stp <= nit000 ) RETURN
1433    IF( ncom_stp == nitend ) RETURN
1434    ii = 1
1435    IF( PRESENT( ld_global ) ) THEN
1436       IF( ld_global ) ii = 2
1437    END IF
1438   
1439    IF ( ld_tic ) THEN
1440       tic_wt(ii) = MPI_Wtime()                                                    ! start count tic->tac (waiting time)
1441       IF ( tic_ct > 0.0_wp ) compute_time = compute_time + MPI_Wtime() - tic_ct   ! cumulate count tac->tic
1442    ELSE
1443       waiting_time(ii) = waiting_time(ii) + MPI_Wtime() - tic_wt(ii)              ! cumulate count tic->tac
1444       tic_ct = MPI_Wtime()                                                        ! start count tac->tic (waiting time)
1445    ENDIF
1446   
1447   END SUBROUTINE tic_tac
1448
1449   
1450#else
1451   !!----------------------------------------------------------------------
1452   !!   Default case:            Dummy module        share memory computing
1453   !!----------------------------------------------------------------------
1454   USE in_out_manager
1455
1456   INTERFACE mpp_sum
1457      MODULE PROCEDURE mppsum_int, mppsum_a_int, mppsum_real, mppsum_a_real, mppsum_realdd, mppsum_a_realdd
1458   END INTERFACE
1459   INTERFACE mpp_max
1460      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
1461   END INTERFACE
1462   INTERFACE mpp_min
1463      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
1464   END INTERFACE
1465   INTERFACE mpp_minloc
1466      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
1467   END INTERFACE
1468   INTERFACE mpp_maxloc
1469      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
1470   END INTERFACE
1471
1472   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag
1473   LOGICAL, PUBLIC            ::   ln_nnogather          !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used)
1474   INTEGER, PUBLIC            ::   mpi_comm_oce          ! opa local communicator
1475   !!----------------------------------------------------------------------
1476CONTAINS
1477
1478   INTEGER FUNCTION lib_mpp_alloc(kumout)          ! Dummy function
1479      INTEGER, INTENT(in) ::   kumout
1480      lib_mpp_alloc = 0
1481   END FUNCTION lib_mpp_alloc
1482
1483   FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg,  kumond , kstop, localComm ) RESULT (function_value)
1484      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm
1485      CHARACTER(len=*),DIMENSION(:) ::   ldtxt
1486      CHARACTER(len=*) ::   ldname
1487      INTEGER ::   kumnam_ref, knumnam_cfg , kumond , kstop
1488      IF( PRESENT( localComm ) ) mpi_comm_oce = localComm
1489      function_value = 0
1490      IF( .FALSE. )   ldtxt(:) = 'never done'
1491      CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )
1492   END FUNCTION mynode
1493
1494   SUBROUTINE mppsync                       ! Dummy routine
1495   END SUBROUTINE mppsync
1496
1497   !!----------------------------------------------------------------------
1498   !!    ***  mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real  ***
1499   !!   
1500   !!----------------------------------------------------------------------
1501   !!
1502#  define OPERATION_MAX
1503#  define INTEGER_TYPE
1504#  define DIM_0d
1505#     define ROUTINE_ALLREDUCE           mppmax_int
1506#     include "mpp_allreduce_generic.h90"
1507#     undef ROUTINE_ALLREDUCE
1508#  undef DIM_0d
1509#  define DIM_1d
1510#     define ROUTINE_ALLREDUCE           mppmax_a_int
1511#     include "mpp_allreduce_generic.h90"
1512#     undef ROUTINE_ALLREDUCE
1513#  undef DIM_1d
1514#  undef INTEGER_TYPE
1515!
1516#  define REAL_TYPE
1517#  define DIM_0d
1518#     define ROUTINE_ALLREDUCE           mppmax_real
1519#     include "mpp_allreduce_generic.h90"
1520#     undef ROUTINE_ALLREDUCE
1521#  undef DIM_0d
1522#  define DIM_1d
1523#     define ROUTINE_ALLREDUCE           mppmax_a_real
1524#     include "mpp_allreduce_generic.h90"
1525#     undef ROUTINE_ALLREDUCE
1526#  undef DIM_1d
1527#  undef REAL_TYPE
1528#  undef OPERATION_MAX
1529   !!----------------------------------------------------------------------
1530   !!    ***  mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real  ***
1531   !!   
1532   !!----------------------------------------------------------------------
1533   !!
1534#  define OPERATION_MIN
1535#  define INTEGER_TYPE
1536#  define DIM_0d
1537#     define ROUTINE_ALLREDUCE           mppmin_int
1538#     include "mpp_allreduce_generic.h90"
1539#     undef ROUTINE_ALLREDUCE
1540#  undef DIM_0d
1541#  define DIM_1d
1542#     define ROUTINE_ALLREDUCE           mppmin_a_int
1543#     include "mpp_allreduce_generic.h90"
1544#     undef ROUTINE_ALLREDUCE
1545#  undef DIM_1d
1546#  undef INTEGER_TYPE
1547!
1548#  define REAL_TYPE
1549#  define DIM_0d
1550#     define ROUTINE_ALLREDUCE           mppmin_real
1551#     include "mpp_allreduce_generic.h90"
1552#     undef ROUTINE_ALLREDUCE
1553#  undef DIM_0d
1554#  define DIM_1d
1555#     define ROUTINE_ALLREDUCE           mppmin_a_real
1556#     include "mpp_allreduce_generic.h90"
1557#     undef ROUTINE_ALLREDUCE
1558#  undef DIM_1d
1559#  undef REAL_TYPE
1560#  undef OPERATION_MIN
1561
1562   !!----------------------------------------------------------------------
1563   !!    ***  mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real  ***
1564   !!   
1565   !!   Global sum of 1D array or a variable (integer, real or complex)
1566   !!----------------------------------------------------------------------
1567   !!
1568#  define OPERATION_SUM
1569#  define INTEGER_TYPE
1570#  define DIM_0d
1571#     define ROUTINE_ALLREDUCE           mppsum_int
1572#     include "mpp_allreduce_generic.h90"
1573#     undef ROUTINE_ALLREDUCE
1574#  undef DIM_0d
1575#  define DIM_1d
1576#     define ROUTINE_ALLREDUCE           mppsum_a_int
1577#     include "mpp_allreduce_generic.h90"
1578#     undef ROUTINE_ALLREDUCE
1579#  undef DIM_1d
1580#  undef INTEGER_TYPE
1581!
1582#  define REAL_TYPE
1583#  define DIM_0d
1584#     define ROUTINE_ALLREDUCE           mppsum_real
1585#     include "mpp_allreduce_generic.h90"
1586#     undef ROUTINE_ALLREDUCE
1587#  undef DIM_0d
1588#  define DIM_1d
1589#     define ROUTINE_ALLREDUCE           mppsum_a_real
1590#     include "mpp_allreduce_generic.h90"
1591#     undef ROUTINE_ALLREDUCE
1592#  undef DIM_1d
1593#  undef REAL_TYPE
1594#  undef OPERATION_SUM
1595
1596#  define OPERATION_SUM_DD
1597#  define COMPLEX_TYPE
1598#  define DIM_0d
1599#     define ROUTINE_ALLREDUCE           mppsum_realdd
1600#     include "mpp_allreduce_generic.h90"
1601#     undef ROUTINE_ALLREDUCE
1602#  undef DIM_0d
1603#  define DIM_1d
1604#     define ROUTINE_ALLREDUCE           mppsum_a_realdd
1605#     include "mpp_allreduce_generic.h90"
1606#     undef ROUTINE_ALLREDUCE
1607#  undef DIM_1d
1608#  undef COMPLEX_TYPE
1609#  undef OPERATION_SUM_DD
1610
1611   !!----------------------------------------------------------------------
1612   !!    ***  mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d
1613   !!   
1614   !!----------------------------------------------------------------------
1615   !!
1616#  define OPERATION_MINLOC
1617#  define DIM_2d
1618#     define ROUTINE_LOC           mpp_minloc2d
1619#     include "mpp_loc_generic.h90"
1620#     undef ROUTINE_LOC
1621#  undef DIM_2d
1622#  define DIM_3d
1623#     define ROUTINE_LOC           mpp_minloc3d
1624#     include "mpp_loc_generic.h90"
1625#     undef ROUTINE_LOC
1626#  undef DIM_3d
1627#  undef OPERATION_MINLOC
1628
1629#  define OPERATION_MAXLOC
1630#  define DIM_2d
1631#     define ROUTINE_LOC           mpp_maxloc2d
1632#     include "mpp_loc_generic.h90"
1633#     undef ROUTINE_LOC
1634#  undef DIM_2d
1635#  define DIM_3d
1636#     define ROUTINE_LOC           mpp_maxloc3d
1637#     include "mpp_loc_generic.h90"
1638#     undef ROUTINE_LOC
1639#  undef DIM_3d
1640#  undef OPERATION_MAXLOC
1641
1642   SUBROUTINE mpp_ilor( ld_switch, ldlast, kcom )
1643      LOGICAL, INTENT(in   ), DIMENSION(2) ::   ld_switch
1644      LOGICAL, INTENT(in   ), OPTIONAL     ::   ldlast
1645      INTEGER, INTENT(in   ), OPTIONAL     ::   kcom    ! ???
1646      WRITE(*,*) 'mpp_ilor: You should not have seen this print! error?', ld_switch
1647   END SUBROUTINE mpp_ilor
1648
1649   SUBROUTINE mppstop
1650      STOP      ! non MPP case, just stop the run
1651   END SUBROUTINE mppstop
1652
1653   SUBROUTINE mpp_ini_znl( knum )
1654      INTEGER :: knum
1655      WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum
1656   END SUBROUTINE mpp_ini_znl
1657
1658   SUBROUTINE mpp_comm_free( kcom )
1659      INTEGER :: kcom
1660      WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom
1661   END SUBROUTINE mpp_comm_free
1662   
1663#endif
1664
1665   !!----------------------------------------------------------------------
1666   !!   All cases:         ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam   routines
1667   !!----------------------------------------------------------------------
1668
1669   SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 ,   &
1670      &                 cd6, cd7, cd8, cd9, cd10 )
1671      !!----------------------------------------------------------------------
1672      !!                  ***  ROUTINE  stop_opa  ***
1673      !!
1674      !! ** Purpose :   print in ocean.outpput file a error message and
1675      !!                increment the error number (nstop) by one.
1676      !!----------------------------------------------------------------------
1677      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5
1678      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10
1679      !!----------------------------------------------------------------------
1680      !
1681      nstop = nstop + 1
1682      IF(lwp) THEN
1683         WRITE(numout,cform_err)
1684         IF( PRESENT(cd1 ) )   WRITE(numout,*) cd1
1685         IF( PRESENT(cd2 ) )   WRITE(numout,*) cd2
1686         IF( PRESENT(cd3 ) )   WRITE(numout,*) cd3
1687         IF( PRESENT(cd4 ) )   WRITE(numout,*) cd4
1688         IF( PRESENT(cd5 ) )   WRITE(numout,*) cd5
1689         IF( PRESENT(cd6 ) )   WRITE(numout,*) cd6
1690         IF( PRESENT(cd7 ) )   WRITE(numout,*) cd7
1691         IF( PRESENT(cd8 ) )   WRITE(numout,*) cd8
1692         IF( PRESENT(cd9 ) )   WRITE(numout,*) cd9
1693         IF( PRESENT(cd10) )   WRITE(numout,*) cd10
1694      ENDIF
1695                               CALL FLUSH(numout    )
1696      IF( numstp     /= -1 )   CALL FLUSH(numstp    )
1697      IF( numrun     /= -1 )   CALL FLUSH(numrun    )
1698      IF( numevo_ice /= -1 )   CALL FLUSH(numevo_ice)
1699      !
1700      IF( cd1 == 'STOP' ) THEN
1701         IF(lwp) WRITE(numout,*)  'huge E-R-R-O-R : immediate stop'
1702         CALL mppstop()
1703      ENDIF
1704      !
1705   END SUBROUTINE ctl_stop
1706
1707
1708   SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5,   &
1709      &                 cd6, cd7, cd8, cd9, cd10 )
1710      !!----------------------------------------------------------------------
1711      !!                  ***  ROUTINE  stop_warn  ***
1712      !!
1713      !! ** Purpose :   print in ocean.outpput file a error message and
1714      !!                increment the warning number (nwarn) by one.
1715      !!----------------------------------------------------------------------
1716      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5
1717      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10
1718      !!----------------------------------------------------------------------
1719      !
1720      nwarn = nwarn + 1
1721      IF(lwp) THEN
1722         WRITE(numout,cform_war)
1723         IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
1724         IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
1725         IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
1726         IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
1727         IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
1728         IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
1729         IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
1730         IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
1731         IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
1732         IF( PRESENT(cd10) ) WRITE(numout,*) cd10
1733      ENDIF
1734      CALL FLUSH(numout)
1735      !
1736   END SUBROUTINE ctl_warn
1737
1738
1739   SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea )
1740      !!----------------------------------------------------------------------
1741      !!                  ***  ROUTINE ctl_opn  ***
1742      !!
1743      !! ** Purpose :   Open file and check if required file is available.
1744      !!
1745      !! ** Method  :   Fortan open
1746      !!----------------------------------------------------------------------
1747      INTEGER          , INTENT(  out) ::   knum      ! logical unit to open
1748      CHARACTER(len=*) , INTENT(in   ) ::   cdfile    ! file name to open
1749      CHARACTER(len=*) , INTENT(in   ) ::   cdstat    ! disposition specifier
1750      CHARACTER(len=*) , INTENT(in   ) ::   cdform    ! formatting specifier
1751      CHARACTER(len=*) , INTENT(in   ) ::   cdacce    ! access specifier
1752      INTEGER          , INTENT(in   ) ::   klengh    ! record length
1753      INTEGER          , INTENT(in   ) ::   kout      ! number of logical units for write
1754      LOGICAL          , INTENT(in   ) ::   ldwp      ! boolean term for print
1755      INTEGER, OPTIONAL, INTENT(in   ) ::   karea     ! proc number
1756      !
1757      CHARACTER(len=80) ::   clfile
1758      INTEGER           ::   iost
1759      !!----------------------------------------------------------------------
1760      !
1761      ! adapt filename
1762      ! ----------------
1763      clfile = TRIM(cdfile)
1764      IF( PRESENT( karea ) ) THEN
1765         IF( karea > 1 )   WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1
1766      ENDIF
1767#if defined key_agrif
1768      IF( .NOT. Agrif_Root() )   clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile)
1769      knum=Agrif_Get_Unit()
1770#else
1771      knum=get_unit()
1772#endif
1773      !
1774      iost=0
1775      IF( cdacce(1:6) == 'DIRECT' )  THEN
1776         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh, ERR=100, IOSTAT=iost )
1777      ELSE
1778         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat             , ERR=100, IOSTAT=iost )
1779      ENDIF
1780      IF( iost == 0 ) THEN
1781         IF(ldwp) THEN
1782            WRITE(kout,*) '     file   : ', clfile,' open ok'
1783            WRITE(kout,*) '     unit   = ', knum
1784            WRITE(kout,*) '     status = ', cdstat
1785            WRITE(kout,*) '     form   = ', cdform
1786            WRITE(kout,*) '     access = ', cdacce
1787            WRITE(kout,*)
1788         ENDIF
1789      ENDIF
1790100   CONTINUE
1791      IF( iost /= 0 ) THEN
1792         IF(ldwp) THEN
1793            WRITE(kout,*)
1794            WRITE(kout,*) ' ===>>>> : bad opening file: ', clfile
1795            WRITE(kout,*) ' =======   ===  '
1796            WRITE(kout,*) '           unit   = ', knum
1797            WRITE(kout,*) '           status = ', cdstat
1798            WRITE(kout,*) '           form   = ', cdform
1799            WRITE(kout,*) '           access = ', cdacce
1800            WRITE(kout,*) '           iostat = ', iost
1801            WRITE(kout,*) '           we stop. verify the file '
1802            WRITE(kout,*)
1803         ELSE  !!! Force writing to make sure we get the information - at least once - in this violent STOP!!
1804            WRITE(*,*)
1805            WRITE(*,*) ' ===>>>> : bad opening file: ', clfile
1806            WRITE(*,*) ' =======   ===  '
1807            WRITE(*,*) '           unit   = ', knum
1808            WRITE(*,*) '           status = ', cdstat
1809            WRITE(*,*) '           form   = ', cdform
1810            WRITE(*,*) '           access = ', cdacce
1811            WRITE(*,*) '           iostat = ', iost
1812            WRITE(*,*) '           we stop. verify the file '
1813            WRITE(*,*)
1814         ENDIF
1815         CALL FLUSH( kout ) 
1816         STOP 'ctl_opn bad opening'
1817      ENDIF
1818      !
1819   END SUBROUTINE ctl_opn
1820
1821
1822   SUBROUTINE ctl_nam ( kios, cdnam, ldwp )
1823      !!----------------------------------------------------------------------
1824      !!                  ***  ROUTINE ctl_nam  ***
1825      !!
1826      !! ** Purpose :   Informations when error while reading a namelist
1827      !!
1828      !! ** Method  :   Fortan open
1829      !!----------------------------------------------------------------------
1830      INTEGER         , INTENT(inout) ::   kios    ! IO status after reading the namelist
1831      CHARACTER(len=*), INTENT(in   ) ::   cdnam   ! group name of namelist for which error occurs
1832      CHARACTER(len=5)                ::   clios   ! string to convert iostat in character for print
1833      LOGICAL         , INTENT(in   ) ::   ldwp    ! boolean term for print
1834      !!----------------------------------------------------------------------
1835      !
1836      WRITE (clios, '(I5.0)')   kios
1837      IF( kios < 0 ) THEN         
1838         CALL ctl_warn( 'end of record or file while reading namelist '   &
1839            &           // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
1840      ENDIF
1841      !
1842      IF( kios > 0 ) THEN
1843         CALL ctl_stop( 'misspelled variable in namelist '   &
1844            &           // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
1845      ENDIF
1846      kios = 0
1847      RETURN
1848      !
1849   END SUBROUTINE ctl_nam
1850
1851
1852   INTEGER FUNCTION get_unit()
1853      !!----------------------------------------------------------------------
1854      !!                  ***  FUNCTION  get_unit  ***
1855      !!
1856      !! ** Purpose :   return the index of an unused logical unit
1857      !!----------------------------------------------------------------------
1858      LOGICAL :: llopn
1859      !!----------------------------------------------------------------------
1860      !
1861      get_unit = 15   ! choose a unit that is big enough then it is not already used in NEMO
1862      llopn = .TRUE.
1863      DO WHILE( (get_unit < 998) .AND. llopn )
1864         get_unit = get_unit + 1
1865         INQUIRE( unit = get_unit, opened = llopn )
1866      END DO
1867      IF( (get_unit == 999) .AND. llopn ) THEN
1868         CALL ctl_stop( 'get_unit: All logical units until 999 are used...' )
1869         get_unit = -1
1870      ENDIF
1871      !
1872   END FUNCTION get_unit
1873
1874   !!----------------------------------------------------------------------
1875END MODULE lib_mpp
Note: See TracBrowser for help on using the repository browser.