source: trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 3598

Last change on this file since 3598 was 3598, checked in by rblod, 8 years ago

Change of some variable range for TAM in 3.4 - Ticket #1004

  • Property svn:keywords set to Id
File size: 129.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   !!----------------------------------------------------------------------
22
23   !!----------------------------------------------------------------------
24   !!   ctl_stop   : update momentum and tracer Kz from a tke scheme
25   !!   ctl_warn   : initialization, namelist read, and parameters control
26   !!   ctl_opn    : Open file and check if required file is available.
27   !!   get_unit    : give the index of an unused logical unit
28   !!----------------------------------------------------------------------
29#if   defined key_mpp_mpi
30   !!----------------------------------------------------------------------
31   !!   'key_mpp_mpi'             MPI massively parallel processing library
32   !!----------------------------------------------------------------------
33   !!   lib_mpp_alloc : allocate mpp arrays
34   !!   mynode        : indentify the processor unit
35   !!   mpp_lnk       : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d)
36   !!   mpp_lnk_3d_gather :  Message passing manadgement for two 3D arrays
37   !!   mpp_lnk_e     : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e)
38   !!   mpprecv         :
39   !!   mppsend       :   SUBROUTINE mpp_ini_znl
40   !!   mppscatter    :
41   !!   mppgather     :
42   !!   mpp_min       : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
43   !!   mpp_max       : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
44   !!   mpp_sum       : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
45   !!   mpp_minloc    :
46   !!   mpp_maxloc    :
47   !!   mppsync       :
48   !!   mppstop       :
49   !!   mppobc        : variant of mpp_lnk for open boundary condition
50   !!   mpp_ini_north : initialisation of north fold
51   !!   mpp_lbc_north : north fold processors gathering
52   !!   mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo
53   !!----------------------------------------------------------------------
54   USE dom_oce        ! ocean space and time domain
55   USE lbcnfd         ! north fold treatment
56   USE in_out_manager ! I/O manager
57
58   IMPLICIT NONE
59   PRIVATE
60
61   PUBLIC   ctl_stop, ctl_warn, get_unit, ctl_opn
62   PUBLIC   mynode, mppstop, mppsync, mpp_comm_free
63   PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e
64   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc
65   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e
66   PUBLIC   mppscatter, mppgather
67   PUBLIC   mppobc, mpp_ini_ice, mpp_ini_znl
68   PUBLIC   mppsize
69   PUBLIC   lib_mpp_alloc    ! Called in nemogcm.F90
70   PUBLIC   mppsend, mpprecv ! (PUBLIC for TAM)
71
72   !! * Interfaces
73   !! define generic interface for these routine as they are called sometimes
74   !! with scalar arguments instead of array arguments, which causes problems
75   !! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
76   INTERFACE mpp_min
77      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
78   END INTERFACE
79   INTERFACE mpp_max
80      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
81   END INTERFACE
82   INTERFACE mpp_sum
83      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, &
84                       mppsum_realdd, mppsum_a_realdd
85   END INTERFACE
86   INTERFACE mpp_lbc_north
87      MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d
88   END INTERFACE
89   INTERFACE mpp_minloc
90      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
91   END INTERFACE
92   INTERFACE mpp_maxloc
93      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
94   END INTERFACE
95
96   !! ========================= !!
97   !!  MPI  variable definition !!
98   !! ========================= !!
99!$AGRIF_DO_NOT_TREAT
100   INCLUDE 'mpif.h'
101!$AGRIF_END_DO_NOT_TREAT
102
103   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .TRUE.    !: mpp flag
104
105   INTEGER, PARAMETER         ::   nprocmax = 2**10   ! maximun dimension (required to be a power of 2)
106
107   INTEGER ::   mppsize        ! number of process
108   INTEGER ::   mpprank        ! process number  [ 0 - size-1 ]
109!$AGRIF_DO_NOT_TREAT
110   INTEGER, PUBLIC ::   mpi_comm_opa   ! opa local communicator
111!$AGRIF_END_DO_NOT_TREAT
112
113   INTEGER :: MPI_SUMDD
114
115   ! variables used in case of sea-ice
116   INTEGER, PUBLIC ::   ncomm_ice       !: communicator made by the processors with sea-ice (public so that it can be freed in limthd)
117   INTEGER ::   ngrp_iworld     !  group ID for the world processors (for rheology)
118   INTEGER ::   ngrp_ice        !  group ID for the ice processors (for rheology)
119   INTEGER ::   ndim_rank_ice   !  number of 'ice' processors
120   INTEGER ::   n_ice_root      !  number (in the comm_ice) of proc 0 in the ice comm
121   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_ice     ! dimension ndim_rank_ice
122
123   ! variables used for zonal integration
124   INTEGER, PUBLIC ::   ncomm_znl       !: communicator made by the processors on the same zonal average
125   LOGICAL, PUBLIC ::   l_znl_root      ! True on the 'left'most processor on the same row
126   INTEGER ::   ngrp_znl        ! group ID for the znl processors
127   INTEGER ::   ndim_rank_znl   ! number of processors on the same zonal average
128   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_znl  ! dimension ndim_rank_znl, number of the procs into the same znl domain
129
130   ! North fold condition in mpp_mpi with jpni > 1
131   INTEGER ::   ngrp_world        ! group ID for the world processors
132   INTEGER ::   ngrp_opa          ! group ID for the opa processors
133   INTEGER ::   ngrp_north        ! group ID for the northern processors (to be fold)
134   INTEGER ::   ncomm_north       ! communicator made by the processors belonging to ngrp_north
135   INTEGER ::   ndim_rank_north   ! number of 'sea' processor in the northern line (can be /= jpni !)
136   INTEGER ::   njmppmax          ! value of njmpp for the processors of the northern line
137   INTEGER ::   north_root        ! number (in the comm_opa) of proc 0 in the northern comm
138   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_north   ! dimension ndim_rank_north
139
140   ! Type of send : standard, buffered, immediate
141   CHARACTER(len=1) ::   cn_mpi_send = 'S'    ! type od mpi send/recieve (S=standard, B=bsend, I=isend)
142   LOGICAL          ::   l_isend = .FALSE.   ! isend use indicator (T if cn_mpi_send='I')
143   INTEGER          ::   nn_buffer = 0       ! size of the buffer in case of mpi_bsend
144
145   REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon  ! buffer in case of bsend
146
147   ! message passing arrays
148   REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE, SAVE ::   t4ns, t4sn   ! 2 x 3d for north-south & south-north
149   REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE, SAVE ::   t4ew, t4we   ! 2 x 3d for east-west & west-east
150   REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE, SAVE ::   t4p1, t4p2   ! 2 x 3d for north fold
151   REAL(wp), DIMENSION(:,:,:,:)  , ALLOCATABLE, SAVE ::   t3ns, t3sn   ! 3d for north-south & south-north
152   REAL(wp), DIMENSION(:,:,:,:)  , ALLOCATABLE, SAVE ::   t3ew, t3we   ! 3d for east-west & west-east
153   REAL(wp), DIMENSION(:,:,:,:)  , ALLOCATABLE, SAVE ::   t3p1, t3p2   ! 3d for north fold
154   REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE, SAVE ::   t2ns, t2sn   ! 2d for north-south & south-north
155   REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE, SAVE ::   t2ew, t2we   ! 2d for east-west & west-east
156   REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE, SAVE ::   t2p1, t2p2   ! 2d for north fold
157   REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE, SAVE ::   tr2ns, tr2sn ! 2d for north-south & south-north + extra outer halo
158   REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE, SAVE ::   tr2ew, tr2we ! 2d for east-west   & west-east   + extra outer halo
159
160   ! Arrays used in mpp_lbc_north_3d()
161   REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE, SAVE   ::   ztab, znorthloc
162   REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE, SAVE   ::   znorthgloio
163   REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE, SAVE   ::   zfoldwk      ! Workspace for message transfers avoiding mpi_allgather
164
165   ! Arrays used in mpp_lbc_north_2d()
166   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, SAVE    ::   ztab_2d, znorthloc_2d
167   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE    ::   znorthgloio_2d
168   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, SAVE    ::   zfoldwk_2d    ! Workspace for message transfers avoiding mpi_allgather
169
170   ! Arrays used in mpp_lbc_north_e()
171   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, SAVE    ::   ztab_e, znorthloc_e
172   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE    ::   znorthgloio_e
173
174   ! North fold arrays used to minimise the use of allgather operations. Set in nemo_northcomms (nemogcm) so need to be public
175   INTEGER, PUBLIC,  PARAMETER :: jpmaxngh = 8                 ! Assumed maximum number of active neighbours
176   INTEGER, PUBLIC,  PARAMETER :: jptyps   = 5                 ! Number of different neighbour lists to be used for northfold exchanges
177   INTEGER, PUBLIC,  DIMENSION (jpmaxngh,jptyps)    ::   isendto
178   INTEGER, PUBLIC,  DIMENSION (jptyps)             ::   nsndto
179   LOGICAL, PUBLIC                                  ::   ln_nnogather     = .FALSE.  ! namelist control of northfold comms
180   LOGICAL, PUBLIC                                  ::   l_north_nogather = .FALSE.  ! internal control of northfold comms
181   INTEGER, PUBLIC                                  ::   ityp
182   !!----------------------------------------------------------------------
183   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
184   !! $Id$
185   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
186   !!----------------------------------------------------------------------
187CONTAINS
188
189   INTEGER FUNCTION lib_mpp_alloc( kumout )
190      !!----------------------------------------------------------------------
191      !!              ***  routine lib_mpp_alloc  ***
192      !!----------------------------------------------------------------------
193      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical unit
194      !!----------------------------------------------------------------------
195      !
196      ALLOCATE( t4ns(jpi,jprecj,jpk,2,2) , t4sn(jpi,jprecj,jpk,2,2) ,                                            &
197         &      t4ew(jpj,jpreci,jpk,2,2) , t4we(jpj,jpreci,jpk,2,2) ,                                            &
198         &      t4p1(jpi,jprecj,jpk,2,2) , t4p2(jpi,jprecj,jpk,2,2) ,                                            &
199         &      t3ns(jpi,jprecj,jpk,2)   , t3sn(jpi,jprecj,jpk,2)   ,                                            &
200         &      t3ew(jpj,jpreci,jpk,2)   , t3we(jpj,jpreci,jpk,2)   ,                                            &
201         &      t3p1(jpi,jprecj,jpk,2)   , t3p2(jpi,jprecj,jpk,2)   ,                                            &
202         &      t2ns(jpi,jprecj    ,2)   , t2sn(jpi,jprecj    ,2)   ,                                            &
203         &      t2ew(jpj,jpreci    ,2)   , t2we(jpj,jpreci    ,2)   ,                                            &
204         &      t2p1(jpi,jprecj    ,2)   , t2p2(jpi,jprecj    ,2)   ,                                            &
205         !
206         &      tr2ns(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) ,                                                     &
207         &      tr2sn(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) ,                                                     &
208         &      tr2ew(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) ,                                                     &
209         &      tr2we(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) ,                                                     &
210         !
211         &      ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk) , znorthgloio(jpi,4,jpk,jpni) ,                        &
212         &      zfoldwk(jpi,4,jpk) ,                                                                             &
213         !
214         &      ztab_2d(jpiglo,4)  , znorthloc_2d(jpi,4)  , znorthgloio_2d(jpi,4,jpni)  ,                        &
215         &      zfoldwk_2d(jpi,4)  ,                                                                             &
216         !
217         &      ztab_e(jpiglo,4+2*jpr2dj) , znorthloc_e(jpi,4+2*jpr2dj) , znorthgloio_e(jpi,4+2*jpr2dj,jpni) ,   &
218         !
219         &      STAT=lib_mpp_alloc )
220         !
221      IF( lib_mpp_alloc /= 0 ) THEN
222         WRITE(kumout,cform_war)
223         WRITE(kumout,*) 'lib_mpp_alloc : failed to allocate arrays'
224      ENDIF
225      !
226   END FUNCTION lib_mpp_alloc
227
228
229   FUNCTION mynode( ldtxt, kumnam, kstop, localComm )
230      !!----------------------------------------------------------------------
231      !!                  ***  routine mynode  ***
232      !!
233      !! ** Purpose :   Find processor unit
234      !!----------------------------------------------------------------------
235      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt
236      INTEGER                      , INTENT(in   ) ::   kumnam       ! namelist logical unit
237      INTEGER                      , INTENT(inout) ::   kstop        ! stop indicator
238      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm
239      !
240      INTEGER ::   mynode, ierr, code, ji, ii
241      LOGICAL ::   mpi_was_called
242      !
243      NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij, ln_nnogather
244      !!----------------------------------------------------------------------
245      !
246      ii = 1
247      WRITE(ldtxt(ii),*)                                                                          ;   ii = ii + 1
248      WRITE(ldtxt(ii),*) 'mynode : mpi initialisation'                                            ;   ii = ii + 1
249      WRITE(ldtxt(ii),*) '~~~~~~ '                                                                ;   ii = ii + 1
250      !
251      jpni = -1; jpnj = -1; jpnij = -1
252      REWIND( kumnam )               ! Namelist namrun : parameters of the run
253      READ  ( kumnam, nammpp )
254      !                              ! control print
255      WRITE(ldtxt(ii),*) '   Namelist nammpp'                                                     ;   ii = ii + 1
256      WRITE(ldtxt(ii),*) '      mpi send type                      cn_mpi_send = ', cn_mpi_send   ;   ii = ii + 1
257      WRITE(ldtxt(ii),*) '      size in bytes of exported buffer   nn_buffer   = ', nn_buffer     ;   ii = ii + 1
258
259#if defined key_agrif
260      IF( .NOT. Agrif_Root() ) THEN
261         jpni  = Agrif_Parent(jpni )
262         jpnj  = Agrif_Parent(jpnj )
263         jpnij = Agrif_Parent(jpnij)
264      ENDIF
265#endif
266
267      IF(jpnij < 1)THEN
268         ! If jpnij is not specified in namelist then we calculate it - this
269         ! means there will be no land cutting out.
270         jpnij = jpni * jpnj
271      END IF
272
273      IF( (jpni < 1) .OR. (jpnj < 1) )THEN
274         WRITE(ldtxt(ii),*) '      jpni, jpnj and jpnij will be calculated automatically'; ii = ii + 1
275      ELSE
276         WRITE(ldtxt(ii),*) '      processor grid extent in i         jpni = ',jpni; ii = ii + 1
277         WRITE(ldtxt(ii),*) '      processor grid extent in j         jpnj = ',jpnj; ii = ii + 1
278         WRITE(ldtxt(ii),*) '      number of local domains           jpnij = ',jpnij; ii = ii +1
279      END IF
280
281      WRITE(ldtxt(ii),*) '      avoid use of mpi_allgather at the north fold  ln_nnogather = ', ln_nnogather  ; ii = ii + 1
282
283      CALL mpi_initialized ( mpi_was_called, code )
284      IF( code /= MPI_SUCCESS ) THEN
285         DO ji = 1, SIZE(ldtxt)
286            IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
287         END DO
288         WRITE(*, cform_err)
289         WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized'
290         CALL mpi_abort( mpi_comm_world, code, ierr )
291      ENDIF
292
293      IF( mpi_was_called ) THEN
294         !
295         SELECT CASE ( cn_mpi_send )
296         CASE ( 'S' )                ! Standard mpi send (blocking)
297            WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'                     ;   ii = ii + 1
298         CASE ( 'B' )                ! Buffer mpi send (blocking)
299            WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'                      ;   ii = ii + 1
300            IF( Agrif_Root() )   CALL mpi_init_opa( ldtxt, ii, ierr )
301         CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
302            WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'                   ;   ii = ii + 1
303            l_isend = .TRUE.
304         CASE DEFAULT
305            WRITE(ldtxt(ii),cform_err)                                                            ;   ii = ii + 1
306            WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send             ;   ii = ii + 1
307            kstop = kstop + 1
308         END SELECT
309      ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN
310         WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator '                  ;   ii = ii + 1
311         WRITE(ldtxt(ii),*) '          without calling MPI_Init before ! '                        ;   ii = ii + 1
312         kstop = kstop + 1
313      ELSE
314         SELECT CASE ( cn_mpi_send )
315         CASE ( 'S' )                ! Standard mpi send (blocking)
316            WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'                     ;   ii = ii + 1
317            CALL mpi_init( ierr )
318         CASE ( 'B' )                ! Buffer mpi send (blocking)
319            WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'                      ;   ii = ii + 1
320            IF( Agrif_Root() )   CALL mpi_init_opa( ldtxt, ii, ierr )
321         CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
322            WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'                   ;   ii = ii + 1
323            l_isend = .TRUE.
324            CALL mpi_init( ierr )
325         CASE DEFAULT
326            WRITE(ldtxt(ii),cform_err)                                                            ;   ii = ii + 1
327            WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send             ;   ii = ii + 1
328            kstop = kstop + 1
329         END SELECT
330         !
331      ENDIF
332
333      IF( PRESENT(localComm) ) THEN
334         IF( Agrif_Root() ) THEN
335            mpi_comm_opa = localComm
336         ENDIF
337      ELSE
338         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code)
339         IF( code /= MPI_SUCCESS ) THEN
340            DO ji = 1, SIZE(ldtxt)
341               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
342            END DO
343            WRITE(*, cform_err)
344            WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
345            CALL mpi_abort( mpi_comm_world, code, ierr )
346         ENDIF
347      ENDIF
348
349      CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr )
350      CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr )
351      mynode = mpprank
352      !
353      CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr)
354      !
355   END FUNCTION mynode
356
357
358   SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval )
359      !!----------------------------------------------------------------------
360      !!                  ***  routine mpp_lnk_3d  ***
361      !!
362      !! ** Purpose :   Message passing manadgement
363      !!
364      !! ** Method  :   Use mppsend and mpprecv function for passing mask
365      !!      between processors following neighboring subdomains.
366      !!            domain parameters
367      !!                    nlci   : first dimension of the local subdomain
368      !!                    nlcj   : second dimension of the local subdomain
369      !!                    nbondi : mark for "east-west local boundary"
370      !!                    nbondj : mark for "north-south local boundary"
371      !!                    noea   : number for local neighboring processors
372      !!                    nowe   : number for local neighboring processors
373      !!                    noso   : number for local neighboring processors
374      !!                    nono   : number for local neighboring processors
375      !!
376      !! ** Action  :   ptab with update value at its periphery
377      !!
378      !!----------------------------------------------------------------------
379      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
380      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
381      !                                                             ! = T , U , V , F , W points
382      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
383      !                                                             ! =  1. , the sign is kept
384      CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
385      REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
386      !!
387      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices
388      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
389      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
390      REAL(wp) ::   zland
391      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
392      !!----------------------------------------------------------------------
393
394      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
395      ELSE                         ;   zland = 0.e0      ! zero by default
396      ENDIF
397
398      ! 1. standard boundary treatment
399      ! ------------------------------
400      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values
401         !
402         ! WARNING ptab is defined only between nld and nle
403         DO jk = 1, jpk
404            DO jj = nlcj+1, jpj                 ! added line(s)   (inner only)
405               ptab(nldi  :nlei  , jj          ,jk) = ptab(nldi:nlei,     nlej,jk)
406               ptab(1     :nldi-1, jj          ,jk) = ptab(nldi     ,     nlej,jk)
407               ptab(nlei+1:nlci  , jj          ,jk) = ptab(     nlei,     nlej,jk)
408            END DO
409            DO ji = nlci+1, jpi                 ! added column(s) (full)
410               ptab(ji           ,nldj  :nlej  ,jk) = ptab(     nlei,nldj:nlej,jk)
411               ptab(ji           ,1     :nldj-1,jk) = ptab(     nlei,nldj     ,jk)
412               ptab(ji           ,nlej+1:jpj   ,jk) = ptab(     nlei,     nlej,jk)
413            END DO
414         END DO
415         !
416      ELSE                              ! standard close or cyclic treatment
417         !
418         !                                   ! East-West boundaries
419         !                                        !* Cyclic east-west
420         IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
421            ptab( 1 ,:,:) = ptab(jpim1,:,:)
422            ptab(jpi,:,:) = ptab(  2  ,:,:)
423         ELSE                                     !* closed
424            IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point
425                                         ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north
426         ENDIF
427         !                                   ! North-South boundaries (always closed)
428         IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point
429                                      ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north
430         !
431      ENDIF
432
433      ! 2. East and west directions exchange
434      ! ------------------------------------
435      ! we play with the neigbours AND the row number because of the periodicity
436      !
437      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
438      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
439         iihom = nlci-nreci
440         DO jl = 1, jpreci
441            t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
442            t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
443         END DO
444      END SELECT
445      !
446      !                           ! Migrations
447      imigr = jpreci * jpj * jpk
448      !
449      SELECT CASE ( nbondi )
450      CASE ( -1 )
451         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
452         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea )
453         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
454      CASE ( 0 )
455         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
456         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
457         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea )
458         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe )
459         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
460         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
461      CASE ( 1 )
462         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
463         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe )
464         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
465      END SELECT
466      !
467      !                           ! Write Dirichlet lateral conditions
468      iihom = nlci-jpreci
469      !
470      SELECT CASE ( nbondi )
471      CASE ( -1 )
472         DO jl = 1, jpreci
473            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
474         END DO
475      CASE ( 0 )
476         DO jl = 1, jpreci
477            ptab(jl      ,:,:) = t3we(:,jl,:,2)
478            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
479         END DO
480      CASE ( 1 )
481         DO jl = 1, jpreci
482            ptab(jl      ,:,:) = t3we(:,jl,:,2)
483         END DO
484      END SELECT
485
486
487      ! 3. North and south directions
488      ! -----------------------------
489      ! always closed : we play only with the neigbours
490      !
491      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
492         ijhom = nlcj-nrecj
493         DO jl = 1, jprecj
494            t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
495            t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
496         END DO
497      ENDIF
498      !
499      !                           ! Migrations
500      imigr = jprecj * jpi * jpk
501      !
502      SELECT CASE ( nbondj )
503      CASE ( -1 )
504         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
505         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono )
506         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
507      CASE ( 0 )
508         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
509         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 )
510         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono )
511         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso )
512         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
513         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
514      CASE ( 1 )
515         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
516         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso )
517         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
518      END SELECT
519      !
520      !                           ! Write Dirichlet lateral conditions
521      ijhom = nlcj-jprecj
522      !
523      SELECT CASE ( nbondj )
524      CASE ( -1 )
525         DO jl = 1, jprecj
526            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
527         END DO
528      CASE ( 0 )
529         DO jl = 1, jprecj
530            ptab(:,jl      ,:) = t3sn(:,jl,:,2)
531            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
532         END DO
533      CASE ( 1 )
534         DO jl = 1, jprecj
535            ptab(:,jl,:) = t3sn(:,jl,:,2)
536         END DO
537      END SELECT
538
539
540      ! 4. north fold treatment
541      ! -----------------------
542      !
543      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
544         !
545         SELECT CASE ( jpni )
546         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
547         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
548         END SELECT
549         !
550      ENDIF
551      !
552   END SUBROUTINE mpp_lnk_3d
553
554
555   SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
556      !!----------------------------------------------------------------------
557      !!                  ***  routine mpp_lnk_2d  ***
558      !!
559      !! ** Purpose :   Message passing manadgement for 2d array
560      !!
561      !! ** Method  :   Use mppsend and mpprecv function for passing mask
562      !!      between processors following neighboring subdomains.
563      !!            domain parameters
564      !!                    nlci   : first dimension of the local subdomain
565      !!                    nlcj   : second dimension of the local subdomain
566      !!                    nbondi : mark for "east-west local boundary"
567      !!                    nbondj : mark for "north-south local boundary"
568      !!                    noea   : number for local neighboring processors
569      !!                    nowe   : number for local neighboring processors
570      !!                    noso   : number for local neighboring processors
571      !!                    nono   : number for local neighboring processors
572      !!
573      !!----------------------------------------------------------------------
574      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied
575      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
576      !                                                         ! = T , U , V , F , W and I points
577      REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
578      !                                                         ! =  1. , the sign is kept
579      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
580      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
581      !!
582      INTEGER  ::   ji, jj, jl   ! dummy loop indices
583      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
584      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
585      REAL(wp) ::   zland
586      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
587      !!----------------------------------------------------------------------
588
589      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
590      ELSE                         ;   zland = 0.e0      ! zero by default
591      ENDIF
592
593      ! 1. standard boundary treatment
594      ! ------------------------------
595      !
596      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values
597         !
598         ! WARNING pt2d is defined only between nld and nle
599         DO jj = nlcj+1, jpj                 ! added line(s)   (inner only)
600            pt2d(nldi  :nlei  , jj          ) = pt2d(nldi:nlei,     nlej)
601            pt2d(1     :nldi-1, jj          ) = pt2d(nldi     ,     nlej)
602            pt2d(nlei+1:nlci  , jj          ) = pt2d(     nlei,     nlej)
603         END DO
604         DO ji = nlci+1, jpi                 ! added column(s) (full)
605            pt2d(ji           ,nldj  :nlej  ) = pt2d(     nlei,nldj:nlej)
606            pt2d(ji           ,1     :nldj-1) = pt2d(     nlei,nldj     )
607            pt2d(ji           ,nlej+1:jpj   ) = pt2d(     nlei,     nlej)
608         END DO
609         !
610      ELSE                              ! standard close or cyclic treatment
611         !
612         !                                   ! East-West boundaries
613         IF( nbondi == 2 .AND.   &                ! Cyclic east-west
614            &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
615            pt2d( 1 ,:) = pt2d(jpim1,:)                                    ! west
616            pt2d(jpi,:) = pt2d(  2  ,:)                                    ! east
617         ELSE                                     ! closed
618            IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point
619                                         pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north
620         ENDIF
621         !                                   ! North-South boundaries (always closed)
622            IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland    !south except F-point
623                                         pt2d(:,nlcj-jprecj+1:jpj   ) = zland    ! north
624         !
625      ENDIF
626
627      ! 2. East and west directions exchange
628      ! ------------------------------------
629      ! we play with the neigbours AND the row number because of the periodicity
630      !
631      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
632      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
633         iihom = nlci-nreci
634         DO jl = 1, jpreci
635            t2ew(:,jl,1) = pt2d(jpreci+jl,:)
636            t2we(:,jl,1) = pt2d(iihom +jl,:)
637         END DO
638      END SELECT
639      !
640      !                           ! Migrations
641      imigr = jpreci * jpj
642      !
643      SELECT CASE ( nbondi )
644      CASE ( -1 )
645         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
646         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
647         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
648      CASE ( 0 )
649         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
650         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
651         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
652         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
653         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
654         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
655      CASE ( 1 )
656         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
657         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
658         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
659      END SELECT
660      !
661      !                           ! Write Dirichlet lateral conditions
662      iihom = nlci - jpreci
663      !
664      SELECT CASE ( nbondi )
665      CASE ( -1 )
666         DO jl = 1, jpreci
667            pt2d(iihom+jl,:) = t2ew(:,jl,2)
668         END DO
669      CASE ( 0 )
670         DO jl = 1, jpreci
671            pt2d(jl      ,:) = t2we(:,jl,2)
672            pt2d(iihom+jl,:) = t2ew(:,jl,2)
673         END DO
674      CASE ( 1 )
675         DO jl = 1, jpreci
676            pt2d(jl      ,:) = t2we(:,jl,2)
677         END DO
678      END SELECT
679
680
681      ! 3. North and south directions
682      ! -----------------------------
683      ! always closed : we play only with the neigbours
684      !
685      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
686         ijhom = nlcj-nrecj
687         DO jl = 1, jprecj
688            t2sn(:,jl,1) = pt2d(:,ijhom +jl)
689            t2ns(:,jl,1) = pt2d(:,jprecj+jl)
690         END DO
691      ENDIF
692      !
693      !                           ! Migrations
694      imigr = jprecj * jpi
695      !
696      SELECT CASE ( nbondj )
697      CASE ( -1 )
698         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
699         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
700         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
701      CASE ( 0 )
702         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
703         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
704         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
705         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso )
706         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
707         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
708      CASE ( 1 )
709         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
710         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso )
711         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
712      END SELECT
713      !
714      !                           ! Write Dirichlet lateral conditions
715      ijhom = nlcj - jprecj
716      !
717      SELECT CASE ( nbondj )
718      CASE ( -1 )
719         DO jl = 1, jprecj
720            pt2d(:,ijhom+jl) = t2ns(:,jl,2)
721         END DO
722      CASE ( 0 )
723         DO jl = 1, jprecj
724            pt2d(:,jl      ) = t2sn(:,jl,2)
725            pt2d(:,ijhom+jl) = t2ns(:,jl,2)
726         END DO
727      CASE ( 1 )
728         DO jl = 1, jprecj
729            pt2d(:,jl      ) = t2sn(:,jl,2)
730         END DO
731      END SELECT
732
733
734      ! 4. north fold treatment
735      ! -----------------------
736      !
737      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
738         !
739         SELECT CASE ( jpni )
740         CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp
741         CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs.
742         END SELECT
743         !
744      ENDIF
745      !
746   END SUBROUTINE mpp_lnk_2d
747
748
749   SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn )
750      !!----------------------------------------------------------------------
751      !!                  ***  routine mpp_lnk_3d_gather  ***
752      !!
753      !! ** Purpose :   Message passing manadgement for two 3D arrays
754      !!
755      !! ** Method  :   Use mppsend and mpprecv function for passing mask
756      !!      between processors following neighboring subdomains.
757      !!            domain parameters
758      !!                    nlci   : first dimension of the local subdomain
759      !!                    nlcj   : second dimension of the local subdomain
760      !!                    nbondi : mark for "east-west local boundary"
761      !!                    nbondj : mark for "north-south local boundary"
762      !!                    noea   : number for local neighboring processors
763      !!                    nowe   : number for local neighboring processors
764      !!                    noso   : number for local neighboring processors
765      !!                    nono   : number for local neighboring processors
766      !!
767      !! ** Action  :   ptab1 and ptab2  with update value at its periphery
768      !!
769      !!----------------------------------------------------------------------
770      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab1     ! first and second 3D array on which
771      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab2     ! the boundary condition is applied
772      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1  ! nature of ptab1 and ptab2 arrays
773      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type2  ! i.e. grid-points = T , U , V , F or W points
774      REAL(wp)                        , INTENT(in   ) ::   psgn      ! =-1 the sign change across the north fold boundary
775      !!                                                             ! =  1. , the sign is kept
776      INTEGER  ::   jl   ! dummy loop indices
777      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
778      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
779      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
780      !!----------------------------------------------------------------------
781
782      ! 1. standard boundary treatment
783      ! ------------------------------
784      !                                      ! East-West boundaries
785      !                                           !* Cyclic east-west
786      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
787         ptab1( 1 ,:,:) = ptab1(jpim1,:,:)
788         ptab1(jpi,:,:) = ptab1(  2  ,:,:)
789         ptab2( 1 ,:,:) = ptab2(jpim1,:,:)
790         ptab2(jpi,:,:) = ptab2(  2  ,:,:)
791      ELSE                                        !* closed
792         IF( .NOT. cd_type1 == 'F' )   ptab1(     1       :jpreci,:,:) = 0.e0    ! south except at F-point
793         IF( .NOT. cd_type2 == 'F' )   ptab2(     1       :jpreci,:,:) = 0.e0
794                                       ptab1(nlci-jpreci+1:jpi   ,:,:) = 0.e0    ! north
795                                       ptab2(nlci-jpreci+1:jpi   ,:,:) = 0.e0
796      ENDIF
797
798
799      !                                      ! North-South boundaries
800      IF( .NOT. cd_type1 == 'F' )   ptab1(:,     1       :jprecj,:) = 0.e0    ! south except at F-point
801      IF( .NOT. cd_type2 == 'F' )   ptab2(:,     1       :jprecj,:) = 0.e0
802                                    ptab1(:,nlcj-jprecj+1:jpj   ,:) = 0.e0    ! north
803                                    ptab2(:,nlcj-jprecj+1:jpj   ,:) = 0.e0
804
805
806      ! 2. East and west directions exchange
807      ! ------------------------------------
808      ! we play with the neigbours AND the row number because of the periodicity
809      !
810      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
811      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
812         iihom = nlci-nreci
813         DO jl = 1, jpreci
814            t4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:)
815            t4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:)
816            t4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:)
817            t4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:)
818         END DO
819      END SELECT
820      !
821      !                           ! Migrations
822      imigr = jpreci * jpj * jpk *2
823      !
824      SELECT CASE ( nbondi )
825      CASE ( -1 )
826         CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 )
827         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr, noea )
828         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
829      CASE ( 0 )
830         CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
831         CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 )
832         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr, noea )
833         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr, nowe )
834         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
835         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
836      CASE ( 1 )
837         CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
838         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr, nowe )
839         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
840      END SELECT
841      !
842      !                           ! Write Dirichlet lateral conditions
843      iihom = nlci - jpreci
844      !
845      SELECT CASE ( nbondi )
846      CASE ( -1 )
847         DO jl = 1, jpreci
848            ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
849            ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
850         END DO
851      CASE ( 0 )
852         DO jl = 1, jpreci
853            ptab1(jl      ,:,:) = t4we(:,jl,:,1,2)
854            ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
855            ptab2(jl      ,:,:) = t4we(:,jl,:,2,2)
856            ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
857         END DO
858      CASE ( 1 )
859         DO jl = 1, jpreci
860            ptab1(jl      ,:,:) = t4we(:,jl,:,1,2)
861            ptab2(jl      ,:,:) = t4we(:,jl,:,2,2)
862         END DO
863      END SELECT
864
865
866      ! 3. North and south directions
867      ! -----------------------------
868      ! always closed : we play only with the neigbours
869      !
870      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
871         ijhom = nlcj - nrecj
872         DO jl = 1, jprecj
873            t4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:)
874            t4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:)
875            t4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:)
876            t4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:)
877         END DO
878      ENDIF
879      !
880      !                           ! Migrations
881      imigr = jprecj * jpi * jpk * 2
882      !
883      SELECT CASE ( nbondj )
884      CASE ( -1 )
885         CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 )
886         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr, nono )
887         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
888      CASE ( 0 )
889         CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
890         CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req2 )
891         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr, nono )
892         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr, noso )
893         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
894         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
895      CASE ( 1 )
896         CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
897         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr, noso )
898         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
899      END SELECT
900      !
901      !                           ! Write Dirichlet lateral conditions
902      ijhom = nlcj - jprecj
903      !
904      SELECT CASE ( nbondj )
905      CASE ( -1 )
906         DO jl = 1, jprecj
907            ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
908            ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
909         END DO
910      CASE ( 0 )
911         DO jl = 1, jprecj
912            ptab1(:,jl      ,:) = t4sn(:,jl,:,1,2)
913            ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
914            ptab2(:,jl      ,:) = t4sn(:,jl,:,2,2)
915            ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
916         END DO
917      CASE ( 1 )
918         DO jl = 1, jprecj
919            ptab1(:,jl,:) = t4sn(:,jl,:,1,2)
920            ptab2(:,jl,:) = t4sn(:,jl,:,2,2)
921         END DO
922      END SELECT
923
924
925      ! 4. north fold treatment
926      ! -----------------------
927      IF( npolj /= 0 ) THEN
928         !
929         SELECT CASE ( jpni )
930         CASE ( 1 )
931            CALL lbc_nfd      ( ptab1, cd_type1, psgn )   ! only for northern procs.
932            CALL lbc_nfd      ( ptab2, cd_type2, psgn )
933         CASE DEFAULT
934            CALL mpp_lbc_north( ptab1, cd_type1, psgn )   ! for all northern procs.
935            CALL mpp_lbc_north (ptab2, cd_type2, psgn)
936         END SELECT
937         !
938      ENDIF
939      !
940   END SUBROUTINE mpp_lnk_3d_gather
941
942
943   SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn )
944      !!----------------------------------------------------------------------
945      !!                  ***  routine mpp_lnk_2d_e  ***
946      !!
947      !! ** Purpose :   Message passing manadgement for 2d array (with halo)
948      !!
949      !! ** Method  :   Use mppsend and mpprecv function for passing mask
950      !!      between processors following neighboring subdomains.
951      !!            domain parameters
952      !!                    nlci   : first dimension of the local subdomain
953      !!                    nlcj   : second dimension of the local subdomain
954      !!                    jpr2di : number of rows for extra outer halo
955      !!                    jpr2dj : number of columns for extra outer halo
956      !!                    nbondi : mark for "east-west local boundary"
957      !!                    nbondj : mark for "north-south local boundary"
958      !!                    noea   : number for local neighboring processors
959      !!                    nowe   : number for local neighboring processors
960      !!                    noso   : number for local neighboring processors
961      !!                    nono   : number for local neighboring processors
962      !!
963      !!----------------------------------------------------------------------
964      REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
965      CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points
966      !                                                                                         ! = T , U , V , F , W and I points
967      REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the
968      !!                                                                                        ! north boundary, =  1. otherwise
969      INTEGER  ::   jl   ! dummy loop indices
970      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
971      INTEGER  ::   ipreci, iprecj             ! temporary integers
972      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
973      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
974      !!----------------------------------------------------------------------
975
976      ipreci = jpreci + jpr2di      ! take into account outer extra 2D overlap area
977      iprecj = jprecj + jpr2dj
978
979
980      ! 1. standard boundary treatment
981      ! ------------------------------
982      ! Order matters Here !!!!
983      !
984      !                                      !* North-South boundaries (always colsed)
985      IF( .NOT. cd_type == 'F' )   pt2d(:,  1-jpr2dj   :  jprecj  ) = 0.e0    ! south except at F-point
986                                   pt2d(:,nlcj-jprecj+1:jpj+jpr2dj) = 0.e0    ! north
987
988      !                                      ! East-West boundaries
989      !                                           !* Cyclic east-west
990      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
991         pt2d(1-jpr2di:     1    ,:) = pt2d(jpim1-jpr2di:  jpim1 ,:)       ! east
992         pt2d(   jpi  :jpi+jpr2di,:) = pt2d(     2      :2+jpr2di,:)       ! west
993         !
994      ELSE                                        !* closed
995         IF( .NOT. cd_type == 'F' )   pt2d(  1-jpr2di   :jpreci    ,:) = 0.e0    ! south except at F-point
996                                      pt2d(nlci-jpreci+1:jpi+jpr2di,:) = 0.e0    ! north
997      ENDIF
998      !
999
1000      ! north fold treatment
1001      ! -----------------------
1002      IF( npolj /= 0 ) THEN
1003         !
1004         SELECT CASE ( jpni )
1005         CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jpr2dj), cd_type, psgn, pr2dj=jpr2dj )
1006         CASE DEFAULT   ;   CALL mpp_lbc_north_e( pt2d                    , cd_type, psgn               )
1007         END SELECT
1008         !
1009      ENDIF
1010
1011      ! 2. East and west directions exchange
1012      ! ------------------------------------
1013      ! we play with the neigbours AND the row number because of the periodicity
1014      !
1015      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
1016      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
1017         iihom = nlci-nreci-jpr2di
1018         DO jl = 1, ipreci
1019            tr2ew(:,jl,1) = pt2d(jpreci+jl,:)
1020            tr2we(:,jl,1) = pt2d(iihom +jl,:)
1021         END DO
1022      END SELECT
1023      !
1024      !                           ! Migrations
1025      imigr = ipreci * ( jpj + 2*jpr2dj)
1026      !
1027      SELECT CASE ( nbondi )
1028      CASE ( -1 )
1029         CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 )
1030         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr, noea )
1031         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1032      CASE ( 0 )
1033         CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
1034         CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 )
1035         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr, noea )
1036         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr, nowe )
1037         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1038         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1039      CASE ( 1 )
1040         CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
1041         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr, nowe )
1042         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1043      END SELECT
1044      !
1045      !                           ! Write Dirichlet lateral conditions
1046      iihom = nlci - jpreci
1047      !
1048      SELECT CASE ( nbondi )
1049      CASE ( -1 )
1050         DO jl = 1, ipreci
1051            pt2d(iihom+jl,:) = tr2ew(:,jl,2)
1052         END DO
1053      CASE ( 0 )
1054         DO jl = 1, ipreci
1055            pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
1056            pt2d( iihom+jl,:) = tr2ew(:,jl,2)
1057         END DO
1058      CASE ( 1 )
1059         DO jl = 1, ipreci
1060            pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
1061         END DO
1062      END SELECT
1063
1064
1065      ! 3. North and south directions
1066      ! -----------------------------
1067      ! always closed : we play only with the neigbours
1068      !
1069      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
1070         ijhom = nlcj-nrecj-jpr2dj
1071         DO jl = 1, iprecj
1072            tr2sn(:,jl,1) = pt2d(:,ijhom +jl)
1073            tr2ns(:,jl,1) = pt2d(:,jprecj+jl)
1074         END DO
1075      ENDIF
1076      !
1077      !                           ! Migrations
1078      imigr = iprecj * ( jpi + 2*jpr2di )
1079      !
1080      SELECT CASE ( nbondj )
1081      CASE ( -1 )
1082         CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req1 )
1083         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr, nono )
1084         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1085      CASE ( 0 )
1086         CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
1087         CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req2 )
1088         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr, nono )
1089         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr, noso )
1090         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1091         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1092      CASE ( 1 )
1093         CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
1094         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr, noso )
1095         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1096      END SELECT
1097      !
1098      !                           ! Write Dirichlet lateral conditions
1099      ijhom = nlcj - jprecj
1100      !
1101      SELECT CASE ( nbondj )
1102      CASE ( -1 )
1103         DO jl = 1, iprecj
1104            pt2d(:,ijhom+jl) = tr2ns(:,jl,2)
1105         END DO
1106      CASE ( 0 )
1107         DO jl = 1, iprecj
1108            pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
1109            pt2d(:,ijhom+jl ) = tr2ns(:,jl,2)
1110         END DO
1111      CASE ( 1 )
1112         DO jl = 1, iprecj
1113            pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
1114         END DO
1115      END SELECT
1116
1117   END SUBROUTINE mpp_lnk_2d_e
1118
1119
1120   SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
1121      !!----------------------------------------------------------------------
1122      !!                  ***  routine mppsend  ***
1123      !!
1124      !! ** Purpose :   Send messag passing array
1125      !!
1126      !!----------------------------------------------------------------------
1127      REAL(wp), INTENT(inout) ::   pmess(*)   ! array of real
1128      INTEGER , INTENT(in   ) ::   kbytes     ! size of the array pmess
1129      INTEGER , INTENT(in   ) ::   kdest      ! receive process number
1130      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message
1131      INTEGER , INTENT(in   ) ::   md_req     ! argument for isend
1132      !!
1133      INTEGER ::   iflag
1134      !!----------------------------------------------------------------------
1135      !
1136      SELECT CASE ( cn_mpi_send )
1137      CASE ( 'S' )                ! Standard mpi send (blocking)
1138         CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa        , iflag )
1139      CASE ( 'B' )                ! Buffer mpi send (blocking)
1140         CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa        , iflag )
1141      CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
1142         ! be carefull, one more argument here : the mpi request identifier..
1143         CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa, md_req, iflag )
1144      END SELECT
1145      !
1146   END SUBROUTINE mppsend
1147
1148
1149   SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource )
1150      !!----------------------------------------------------------------------
1151      !!                  ***  routine mpprecv  ***
1152      !!
1153      !! ** Purpose :   Receive messag passing array
1154      !!
1155      !!----------------------------------------------------------------------
1156      REAL(wp), INTENT(inout) ::   pmess(*)   ! array of real
1157      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess
1158      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message
1159      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number
1160      !!
1161      INTEGER :: istatus(mpi_status_size)
1162      INTEGER :: iflag
1163      INTEGER :: use_source
1164      !!----------------------------------------------------------------------
1165      !
1166
1167      ! If a specific process number has been passed to the receive call,
1168      ! use that one. Default is to use mpi_any_source
1169      use_source=mpi_any_source
1170      if(present(ksource)) then
1171         use_source=ksource
1172      end if
1173
1174      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_opa, istatus, iflag )
1175      !
1176   END SUBROUTINE mpprecv
1177
1178
1179   SUBROUTINE mppgather( ptab, kp, pio )
1180      !!----------------------------------------------------------------------
1181      !!                   ***  routine mppgather  ***
1182      !!
1183      !! ** Purpose :   Transfert between a local subdomain array and a work
1184      !!     array which is distributed following the vertical level.
1185      !!
1186      !!----------------------------------------------------------------------
1187      REAL(wp), DIMENSION(jpi,jpj),       INTENT(in   ) ::   ptab   ! subdomain input array
1188      INTEGER ,                           INTENT(in   ) ::   kp     ! record length
1189      REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT(  out) ::   pio    ! subdomain input array
1190      !!
1191      INTEGER :: itaille, ierror   ! temporary integer
1192      !!---------------------------------------------------------------------
1193      !
1194      itaille = jpi * jpj
1195      CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille     ,   &
1196         &                            mpi_double_precision, kp , mpi_comm_opa, ierror )
1197      !
1198   END SUBROUTINE mppgather
1199
1200
1201   SUBROUTINE mppscatter( pio, kp, ptab )
1202      !!----------------------------------------------------------------------
1203      !!                  ***  routine mppscatter  ***
1204      !!
1205      !! ** Purpose :   Transfert between awork array which is distributed
1206      !!      following the vertical level and the local subdomain array.
1207      !!
1208      !!----------------------------------------------------------------------
1209      REAL(wp), DIMENSION(jpi,jpj,jpnij)  ::  pio        ! output array
1210      INTEGER                             ::   kp        ! Tag (not used with MPI
1211      REAL(wp), DIMENSION(jpi,jpj)        ::  ptab       ! subdomain array input
1212      !!
1213      INTEGER :: itaille, ierror   ! temporary integer
1214      !!---------------------------------------------------------------------
1215      !
1216      itaille=jpi*jpj
1217      !
1218      CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille     ,   &
1219         &                            mpi_double_precision, kp  , mpi_comm_opa, ierror )
1220      !
1221   END SUBROUTINE mppscatter
1222
1223
1224   SUBROUTINE mppmax_a_int( ktab, kdim, kcom )
1225      !!----------------------------------------------------------------------
1226      !!                  ***  routine mppmax_a_int  ***
1227      !!
1228      !! ** Purpose :   Find maximum value in an integer layout array
1229      !!
1230      !!----------------------------------------------------------------------
1231      INTEGER , INTENT(in   )                  ::   kdim   ! size of array
1232      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab   ! input array
1233      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom   !
1234      !!
1235      INTEGER :: ierror, localcomm   ! temporary integer
1236      INTEGER, DIMENSION(kdim) ::   iwork
1237      !!----------------------------------------------------------------------
1238      !
1239      localcomm = mpi_comm_opa
1240      IF( PRESENT(kcom) )   localcomm = kcom
1241      !
1242      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror )
1243      !
1244      ktab(:) = iwork(:)
1245      !
1246   END SUBROUTINE mppmax_a_int
1247
1248
1249   SUBROUTINE mppmax_int( ktab, kcom )
1250      !!----------------------------------------------------------------------
1251      !!                  ***  routine mppmax_int  ***
1252      !!
1253      !! ** Purpose :   Find maximum value in an integer layout array
1254      !!
1255      !!----------------------------------------------------------------------
1256      INTEGER, INTENT(inout)           ::   ktab      ! ???
1257      INTEGER, INTENT(in   ), OPTIONAL ::   kcom      ! ???
1258      !!
1259      INTEGER ::   ierror, iwork, localcomm   ! temporary integer
1260      !!----------------------------------------------------------------------
1261      !
1262      localcomm = mpi_comm_opa
1263      IF( PRESENT(kcom) )   localcomm = kcom
1264      !
1265      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror)
1266      !
1267      ktab = iwork
1268      !
1269   END SUBROUTINE mppmax_int
1270
1271
1272   SUBROUTINE mppmin_a_int( ktab, kdim, kcom )
1273      !!----------------------------------------------------------------------
1274      !!                  ***  routine mppmin_a_int  ***
1275      !!
1276      !! ** Purpose :   Find minimum value in an integer layout array
1277      !!
1278      !!----------------------------------------------------------------------
1279      INTEGER , INTENT( in  )                  ::   kdim        ! size of array
1280      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab        ! input array
1281      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array
1282      !!
1283      INTEGER ::   ierror, localcomm   ! temporary integer
1284      INTEGER, DIMENSION(kdim) ::   iwork
1285      !!----------------------------------------------------------------------
1286      !
1287      localcomm = mpi_comm_opa
1288      IF( PRESENT(kcom) )   localcomm = kcom
1289      !
1290      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror )
1291      !
1292      ktab(:) = iwork(:)
1293      !
1294   END SUBROUTINE mppmin_a_int
1295
1296
1297   SUBROUTINE mppmin_int( ktab, kcom )
1298      !!----------------------------------------------------------------------
1299      !!                  ***  routine mppmin_int  ***
1300      !!
1301      !! ** Purpose :   Find minimum value in an integer layout array
1302      !!
1303      !!----------------------------------------------------------------------
1304      INTEGER, INTENT(inout) ::   ktab      ! ???
1305      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array
1306      !!
1307      INTEGER ::  ierror, iwork, localcomm
1308      !!----------------------------------------------------------------------
1309      !
1310      localcomm = mpi_comm_opa
1311      IF( PRESENT(kcom) )   localcomm = kcom
1312      !
1313     CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror )
1314      !
1315      ktab = iwork
1316      !
1317   END SUBROUTINE mppmin_int
1318
1319
1320   SUBROUTINE mppsum_a_int( ktab, kdim )
1321      !!----------------------------------------------------------------------
1322      !!                  ***  routine mppsum_a_int  ***
1323      !!
1324      !! ** Purpose :   Global integer sum, 1D array case
1325      !!
1326      !!----------------------------------------------------------------------
1327      INTEGER, INTENT(in   )                   ::   kdim      ! ???
1328      INTEGER, INTENT(inout), DIMENSION (kdim) ::   ktab      ! ???
1329      !!
1330      INTEGER :: ierror
1331      INTEGER, DIMENSION (kdim) ::  iwork
1332      !!----------------------------------------------------------------------
1333      !
1334      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1335      !
1336      ktab(:) = iwork(:)
1337      !
1338   END SUBROUTINE mppsum_a_int
1339
1340
1341   SUBROUTINE mppsum_int( ktab )
1342      !!----------------------------------------------------------------------
1343      !!                 ***  routine mppsum_int  ***
1344      !!
1345      !! ** Purpose :   Global integer sum
1346      !!
1347      !!----------------------------------------------------------------------
1348      INTEGER, INTENT(inout) ::   ktab
1349      !!
1350      INTEGER :: ierror, iwork
1351      !!----------------------------------------------------------------------
1352      !
1353      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1354      !
1355      ktab = iwork
1356      !
1357   END SUBROUTINE mppsum_int
1358
1359
1360   SUBROUTINE mppmax_a_real( ptab, kdim, kcom )
1361      !!----------------------------------------------------------------------
1362      !!                 ***  routine mppmax_a_real  ***
1363      !!
1364      !! ** Purpose :   Maximum
1365      !!
1366      !!----------------------------------------------------------------------
1367      INTEGER , INTENT(in   )                  ::   kdim
1368      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab
1369      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom
1370      !!
1371      INTEGER :: ierror, localcomm
1372      REAL(wp), DIMENSION(kdim) ::  zwork
1373      !!----------------------------------------------------------------------
1374      !
1375      localcomm = mpi_comm_opa
1376      IF( PRESENT(kcom) ) localcomm = kcom
1377      !
1378      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror )
1379      ptab(:) = zwork(:)
1380      !
1381   END SUBROUTINE mppmax_a_real
1382
1383
1384   SUBROUTINE mppmax_real( ptab, kcom )
1385      !!----------------------------------------------------------------------
1386      !!                  ***  routine mppmax_real  ***
1387      !!
1388      !! ** Purpose :   Maximum
1389      !!
1390      !!----------------------------------------------------------------------
1391      REAL(wp), INTENT(inout)           ::   ptab   ! ???
1392      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ???
1393      !!
1394      INTEGER  ::   ierror, localcomm
1395      REAL(wp) ::   zwork
1396      !!----------------------------------------------------------------------
1397      !
1398      localcomm = mpi_comm_opa
1399      IF( PRESENT(kcom) )   localcomm = kcom
1400      !
1401      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror )
1402      ptab = zwork
1403      !
1404   END SUBROUTINE mppmax_real
1405
1406
1407   SUBROUTINE mppmin_a_real( ptab, kdim, kcom )
1408      !!----------------------------------------------------------------------
1409      !!                 ***  routine mppmin_a_real  ***
1410      !!
1411      !! ** Purpose :   Minimum of REAL, array case
1412      !!
1413      !!-----------------------------------------------------------------------
1414      INTEGER , INTENT(in   )                  ::   kdim
1415      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab
1416      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom
1417      !!
1418      INTEGER :: ierror, localcomm
1419      REAL(wp), DIMENSION(kdim) ::   zwork
1420      !!-----------------------------------------------------------------------
1421      !
1422      localcomm = mpi_comm_opa
1423      IF( PRESENT(kcom) ) localcomm = kcom
1424      !
1425      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror )
1426      ptab(:) = zwork(:)
1427      !
1428   END SUBROUTINE mppmin_a_real
1429
1430
1431   SUBROUTINE mppmin_real( ptab, kcom )
1432      !!----------------------------------------------------------------------
1433      !!                  ***  routine mppmin_real  ***
1434      !!
1435      !! ** Purpose :   minimum of REAL, scalar case
1436      !!
1437      !!-----------------------------------------------------------------------
1438      REAL(wp), INTENT(inout)           ::   ptab        !
1439      INTEGER , INTENT(in   ), OPTIONAL :: kcom
1440      !!
1441      INTEGER  ::   ierror
1442      REAL(wp) ::   zwork
1443      INTEGER :: localcomm
1444      !!-----------------------------------------------------------------------
1445      !
1446      localcomm = mpi_comm_opa
1447      IF( PRESENT(kcom) )   localcomm = kcom
1448      !
1449      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror )
1450      ptab = zwork
1451      !
1452   END SUBROUTINE mppmin_real
1453
1454
1455   SUBROUTINE mppsum_a_real( ptab, kdim, kcom )
1456      !!----------------------------------------------------------------------
1457      !!                  ***  routine mppsum_a_real  ***
1458      !!
1459      !! ** Purpose :   global sum, REAL ARRAY argument case
1460      !!
1461      !!-----------------------------------------------------------------------
1462      INTEGER , INTENT( in )                     ::   kdim      ! size of ptab
1463      REAL(wp), DIMENSION(kdim), INTENT( inout ) ::   ptab      ! input array
1464      INTEGER , INTENT( in ), OPTIONAL           :: kcom
1465      !!
1466      INTEGER                   ::   ierror    ! temporary integer
1467      INTEGER                   ::   localcomm
1468      REAL(wp), DIMENSION(kdim) ::   zwork     ! temporary workspace
1469      !!-----------------------------------------------------------------------
1470      !
1471      localcomm = mpi_comm_opa
1472      IF( PRESENT(kcom) )   localcomm = kcom
1473      !
1474      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror )
1475      ptab(:) = zwork(:)
1476      !
1477   END SUBROUTINE mppsum_a_real
1478
1479
1480   SUBROUTINE mppsum_real( ptab, kcom )
1481      !!----------------------------------------------------------------------
1482      !!                  ***  routine mppsum_real  ***
1483      !!
1484      !! ** Purpose :   global sum, SCALAR argument case
1485      !!
1486      !!-----------------------------------------------------------------------
1487      REAL(wp), INTENT(inout)           ::   ptab   ! input scalar
1488      INTEGER , INTENT(in   ), OPTIONAL ::   kcom
1489      !!
1490      INTEGER  ::   ierror, localcomm
1491      REAL(wp) ::   zwork
1492      !!-----------------------------------------------------------------------
1493      !
1494      localcomm = mpi_comm_opa
1495      IF( PRESENT(kcom) ) localcomm = kcom
1496      !
1497      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror )
1498      ptab = zwork
1499      !
1500   END SUBROUTINE mppsum_real
1501
1502   SUBROUTINE mppsum_realdd( ytab, kcom )
1503      !!----------------------------------------------------------------------
1504      !!                  ***  routine mppsum_realdd ***
1505      !!
1506      !! ** Purpose :   global sum in Massively Parallel Processing
1507      !!                SCALAR argument case for double-double precision
1508      !!
1509      !!-----------------------------------------------------------------------
1510      COMPLEX(wp), INTENT(inout)         :: ytab    ! input scalar
1511      INTEGER , INTENT( in  ), OPTIONAL :: kcom
1512
1513      !! * Local variables   (MPI version)
1514      INTEGER  ::    ierror
1515      INTEGER  ::   localcomm
1516      COMPLEX(wp) :: zwork
1517
1518      localcomm = mpi_comm_opa
1519      IF( PRESENT(kcom) ) localcomm = kcom
1520
1521      ! reduce local sums into global sum
1522      CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, &
1523                       MPI_SUMDD,localcomm,ierror)
1524      ytab = zwork
1525
1526   END SUBROUTINE mppsum_realdd
1527
1528
1529   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
1530      !!----------------------------------------------------------------------
1531      !!                  ***  routine mppsum_a_realdd  ***
1532      !!
1533      !! ** Purpose :   global sum in Massively Parallel Processing
1534      !!                COMPLEX ARRAY case for double-double precision
1535      !!
1536      !!-----------------------------------------------------------------------
1537      INTEGER , INTENT( in )                        ::   kdim      ! size of ytab
1538      COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) ::   ytab      ! input array
1539      INTEGER , INTENT( in  ), OPTIONAL :: kcom
1540
1541      !! * Local variables   (MPI version)
1542      INTEGER                      :: ierror    ! temporary integer
1543      INTEGER                      ::   localcomm
1544      COMPLEX(wp), DIMENSION(kdim) :: zwork     ! temporary workspace
1545
1546      localcomm = mpi_comm_opa
1547      IF( PRESENT(kcom) ) localcomm = kcom
1548
1549      CALL MPI_ALLREDUCE (ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, &
1550                       MPI_SUMDD,localcomm,ierror)
1551      ytab(:) = zwork(:)
1552
1553   END SUBROUTINE mppsum_a_realdd
1554
1555   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj )
1556      !!------------------------------------------------------------------------
1557      !!             ***  routine mpp_minloc  ***
1558      !!
1559      !! ** Purpose :   Compute the global minimum of an array ptab
1560      !!              and also give its global position
1561      !!
1562      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
1563      !!
1564      !!--------------------------------------------------------------------------
1565      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   ptab    ! Local 2D array
1566      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask   ! Local mask
1567      REAL(wp)                     , INTENT(  out) ::   pmin    ! Global minimum of ptab
1568      INTEGER                      , INTENT(  out) ::   ki, kj   ! index of minimum in global frame
1569      !!
1570      INTEGER , DIMENSION(2)   ::   ilocs
1571      INTEGER :: ierror
1572      REAL(wp) ::   zmin   ! local minimum
1573      REAL(wp), DIMENSION(2,1) ::   zain, zaout
1574      !!-----------------------------------------------------------------------
1575      !
1576      zmin  = MINVAL( ptab(:,:) , mask= pmask == 1.e0 )
1577      ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 )
1578      !
1579      ki = ilocs(1) + nimpp - 1
1580      kj = ilocs(2) + njmpp - 1
1581      !
1582      zain(1,:)=zmin
1583      zain(2,:)=ki+10000.*kj
1584      !
1585      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
1586      !
1587      pmin = zaout(1,1)
1588      kj = INT(zaout(2,1)/10000.)
1589      ki = INT(zaout(2,1) - 10000.*kj )
1590      !
1591   END SUBROUTINE mpp_minloc2d
1592
1593
1594   SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj ,kk)
1595      !!------------------------------------------------------------------------
1596      !!             ***  routine mpp_minloc  ***
1597      !!
1598      !! ** Purpose :   Compute the global minimum of an array ptab
1599      !!              and also give its global position
1600      !!
1601      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
1602      !!
1603      !!--------------------------------------------------------------------------
1604      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab         ! Local 2D array
1605      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask        ! Local mask
1606      REAL(wp)                         , INTENT(  out) ::   pmin         ! Global minimum of ptab
1607      INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of minimum in global frame
1608      !!
1609      INTEGER  ::   ierror
1610      REAL(wp) ::   zmin     ! local minimum
1611      INTEGER , DIMENSION(3)   ::   ilocs
1612      REAL(wp), DIMENSION(2,1) ::   zain, zaout
1613      !!-----------------------------------------------------------------------
1614      !
1615      zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
1616      ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
1617      !
1618      ki = ilocs(1) + nimpp - 1
1619      kj = ilocs(2) + njmpp - 1
1620      kk = ilocs(3)
1621      !
1622      zain(1,:)=zmin
1623      zain(2,:)=ki+10000.*kj+100000000.*kk
1624      !
1625      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
1626      !
1627      pmin = zaout(1,1)
1628      kk   = INT( zaout(2,1) / 100000000. )
1629      kj   = INT( zaout(2,1) - kk * 100000000. ) / 10000
1630      ki   = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
1631      !
1632   END SUBROUTINE mpp_minloc3d
1633
1634
1635   SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
1636      !!------------------------------------------------------------------------
1637      !!             ***  routine mpp_maxloc  ***
1638      !!
1639      !! ** Purpose :   Compute the global maximum of an array ptab
1640      !!              and also give its global position
1641      !!
1642      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
1643      !!
1644      !!--------------------------------------------------------------------------
1645      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   ptab     ! Local 2D array
1646      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask    ! Local mask
1647      REAL(wp)                     , INTENT(  out) ::   pmax     ! Global maximum of ptab
1648      INTEGER                      , INTENT(  out) ::   ki, kj   ! index of maximum in global frame
1649      !!
1650      INTEGER  :: ierror
1651      INTEGER, DIMENSION (2)   ::   ilocs
1652      REAL(wp) :: zmax   ! local maximum
1653      REAL(wp), DIMENSION(2,1) ::   zain, zaout
1654      !!-----------------------------------------------------------------------
1655      !
1656      zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 )
1657      ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 )
1658      !
1659      ki = ilocs(1) + nimpp - 1
1660      kj = ilocs(2) + njmpp - 1
1661      !
1662      zain(1,:) = zmax
1663      zain(2,:) = ki + 10000. * kj
1664      !
1665      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
1666      !
1667      pmax = zaout(1,1)
1668      kj   = INT( zaout(2,1) / 10000.     )
1669      ki   = INT( zaout(2,1) - 10000.* kj )
1670      !
1671   END SUBROUTINE mpp_maxloc2d
1672
1673
1674   SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
1675      !!------------------------------------------------------------------------
1676      !!             ***  routine mpp_maxloc  ***
1677      !!
1678      !! ** Purpose :  Compute the global maximum of an array ptab
1679      !!              and also give its global position
1680      !!
1681      !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
1682      !!
1683      !!--------------------------------------------------------------------------
1684      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab         ! Local 2D array
1685      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask        ! Local mask
1686      REAL(wp)                         , INTENT(  out) ::   pmax         ! Global maximum of ptab
1687      INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of maximum in global frame
1688      !!
1689      REAL(wp) :: zmax   ! local maximum
1690      REAL(wp), DIMENSION(2,1) ::   zain, zaout
1691      INTEGER , DIMENSION(3)   ::   ilocs
1692      INTEGER :: ierror
1693      !!-----------------------------------------------------------------------
1694      !
1695      zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
1696      ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
1697      !
1698      ki = ilocs(1) + nimpp - 1
1699      kj = ilocs(2) + njmpp - 1
1700      kk = ilocs(3)
1701      !
1702      zain(1,:)=zmax
1703      zain(2,:)=ki+10000.*kj+100000000.*kk
1704      !
1705      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
1706      !
1707      pmax = zaout(1,1)
1708      kk   = INT( zaout(2,1) / 100000000. )
1709      kj   = INT( zaout(2,1) - kk * 100000000. ) / 10000
1710      ki   = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
1711      !
1712   END SUBROUTINE mpp_maxloc3d
1713
1714
1715   SUBROUTINE mppsync()
1716      !!----------------------------------------------------------------------
1717      !!                  ***  routine mppsync  ***
1718      !!
1719      !! ** Purpose :   Massively parallel processors, synchroneous
1720      !!
1721      !!-----------------------------------------------------------------------
1722      INTEGER :: ierror
1723      !!-----------------------------------------------------------------------
1724      !
1725      CALL mpi_barrier( mpi_comm_opa, ierror )
1726      !
1727   END SUBROUTINE mppsync
1728
1729
1730   SUBROUTINE mppstop
1731      !!----------------------------------------------------------------------
1732      !!                  ***  routine mppstop  ***
1733      !!
1734      !! ** purpose :   Stop massively parallel processors method
1735      !!
1736      !!----------------------------------------------------------------------
1737      INTEGER ::   info
1738      !!----------------------------------------------------------------------
1739      !
1740      CALL mppsync
1741      CALL mpi_finalize( info )
1742      !
1743   END SUBROUTINE mppstop
1744
1745
1746   SUBROUTINE mppobc( ptab, kd1, kd2, kl, kk, ktype, kij , kumout)
1747      !!----------------------------------------------------------------------
1748      !!                  ***  routine mppobc  ***
1749      !!
1750      !! ** Purpose :   Message passing manadgement for open boundary
1751      !!     conditions array
1752      !!
1753      !! ** Method  :   Use mppsend and mpprecv function for passing mask
1754      !!       between processors following neighboring subdomains.
1755      !!       domain parameters
1756      !!                    nlci   : first dimension of the local subdomain
1757      !!                    nlcj   : second dimension of the local subdomain
1758      !!                    nbondi : mark for "east-west local boundary"
1759      !!                    nbondj : mark for "north-south local boundary"
1760      !!                    noea   : number for local neighboring processors
1761      !!                    nowe   : number for local neighboring processors
1762      !!                    noso   : number for local neighboring processors
1763      !!                    nono   : number for local neighboring processors
1764      !!
1765      !!----------------------------------------------------------------------
1766      USE wrk_nemo        ! Memory allocation
1767      !
1768      INTEGER , INTENT(in   )                     ::   kd1, kd2   ! starting and ending indices
1769      INTEGER , INTENT(in   )                     ::   kl         ! index of open boundary
1770      INTEGER , INTENT(in   )                     ::   kk         ! vertical dimension
1771      INTEGER , INTENT(in   )                     ::   ktype      ! define north/south or east/west cdt
1772      !                                                           !  = 1  north/south  ;  = 2  east/west
1773      INTEGER , INTENT(in   )                     ::   kij        ! horizontal dimension
1774      INTEGER , INTENT(in   )                     ::   kumout     ! ocean.output logical unit
1775      REAL(wp), INTENT(inout), DIMENSION(kij,kk)  ::   ptab       ! variable array
1776      !
1777      INTEGER ::   ji, jj, jk, jl        ! dummy loop indices
1778      INTEGER ::   iipt0, iipt1, ilpt1   ! local integers
1779      INTEGER ::   ijpt0, ijpt1          !   -       -
1780      INTEGER ::   imigr, iihom, ijhom   !   -       -
1781      INTEGER ::   ml_req1, ml_req2, ml_err    ! for key_mpi_isend
1782      INTEGER ::   ml_stat(MPI_STATUS_SIZE)    ! for key_mpi_isend
1783      REAL(wp), POINTER, DIMENSION(:,:) ::   ztab   ! temporary workspace
1784      !!----------------------------------------------------------------------
1785
1786      CALL wrk_alloc( jpi,jpj, ztab )
1787
1788      ! boundary condition initialization
1789      ! ---------------------------------
1790      ztab(:,:) = 0.e0
1791      !
1792      IF( ktype==1 ) THEN                                  ! north/south boundaries
1793         iipt0 = MAX( 1, MIN(kd1 - nimpp+1, nlci     ) )
1794         iipt1 = MAX( 0, MIN(kd2 - nimpp+1, nlci - 1 ) )
1795         ilpt1 = MAX( 1, MIN(kd2 - nimpp+1, nlci     ) )
1796         ijpt0 = MAX( 1, MIN(kl  - njmpp+1, nlcj     ) )
1797         ijpt1 = MAX( 0, MIN(kl  - njmpp+1, nlcj - 1 ) )
1798      ELSEIF( ktype==2 ) THEN                              ! east/west boundaries
1799         iipt0 = MAX( 1, MIN(kl  - nimpp+1, nlci     ) )
1800         iipt1 = MAX( 0, MIN(kl  - nimpp+1, nlci - 1 ) )
1801         ijpt0 = MAX( 1, MIN(kd1 - njmpp+1, nlcj     ) )
1802         ijpt1 = MAX( 0, MIN(kd2 - njmpp+1, nlcj - 1 ) )
1803         ilpt1 = MAX( 1, MIN(kd2 - njmpp+1, nlcj     ) )
1804      ELSE
1805         WRITE(kumout, cform_err)
1806         WRITE(kumout,*) 'mppobc : bad ktype'
1807         CALL mppstop
1808      ENDIF
1809
1810      ! Communication level by level
1811      ! ----------------------------
1812!!gm Remark : this is very time consumming!!!
1813      !                                         ! ------------------------ !
1814      DO jk = 1, kk                             !   Loop over the levels   !
1815         !                                      ! ------------------------ !
1816         !
1817         IF( ktype == 1 ) THEN                               ! north/south boundaries
1818            DO jj = ijpt0, ijpt1
1819               DO ji = iipt0, iipt1
1820                  ztab(ji,jj) = ptab(ji,jk)
1821               END DO
1822            END DO
1823         ELSEIF( ktype == 2 ) THEN                           ! east/west boundaries
1824            DO jj = ijpt0, ijpt1
1825               DO ji = iipt0, iipt1
1826                  ztab(ji,jj) = ptab(jj,jk)
1827               END DO
1828            END DO
1829         ENDIF
1830
1831
1832         ! 1. East and west directions
1833         ! ---------------------------
1834         !
1835         IF( nbondi /= 2 ) THEN         ! Read Dirichlet lateral conditions
1836            iihom = nlci-nreci
1837            DO jl = 1, jpreci
1838               t2ew(:,jl,1) = ztab(jpreci+jl,:)
1839               t2we(:,jl,1) = ztab(iihom +jl,:)
1840            END DO
1841         ENDIF
1842         !
1843         !                              ! Migrations
1844         imigr=jpreci*jpj
1845         !
1846         IF( nbondi == -1 ) THEN
1847            CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
1848            CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
1849            IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err )
1850         ELSEIF( nbondi == 0 ) THEN
1851            CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1852            CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
1853            CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
1854            CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
1855            IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err )
1856            IF(l_isend)   CALL mpi_wait( ml_req2, ml_stat, ml_err )
1857         ELSEIF( nbondi == 1 ) THEN
1858            CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1859            CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
1860            IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
1861         ENDIF
1862         !
1863         !                              ! Write Dirichlet lateral conditions
1864         iihom = nlci-jpreci
1865         !
1866         IF( nbondi == 0 .OR. nbondi == 1 ) THEN
1867            DO jl = 1, jpreci
1868               ztab(jl,:) = t2we(:,jl,2)
1869            END DO
1870         ENDIF
1871         IF( nbondi == -1 .OR. nbondi == 0 ) THEN
1872            DO jl = 1, jpreci
1873               ztab(iihom+jl,:) = t2ew(:,jl,2)
1874            END DO
1875         ENDIF
1876
1877
1878         ! 2. North and south directions
1879         ! -----------------------------
1880         !
1881         IF( nbondj /= 2 ) THEN         ! Read Dirichlet lateral conditions
1882            ijhom = nlcj-nrecj
1883            DO jl = 1, jprecj
1884               t2sn(:,jl,1) = ztab(:,ijhom +jl)
1885               t2ns(:,jl,1) = ztab(:,jprecj+jl)
1886            END DO
1887         ENDIF
1888         !
1889         !                              ! Migrations
1890         imigr = jprecj * jpi
1891         !
1892         IF( nbondj == -1 ) THEN
1893            CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
1894            CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
1895            IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
1896         ELSEIF( nbondj == 0 ) THEN
1897            CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1898            CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
1899            CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
1900            CALL mpprecv( 4, t2sn(1,1,2), imigr, noso )
1901            IF( l_isend )   CALL mpi_wait( ml_req1, ml_stat, ml_err )
1902            IF( l_isend )   CALL mpi_wait( ml_req2, ml_stat, ml_err )
1903         ELSEIF( nbondj == 1 ) THEN
1904            CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1905            CALL mpprecv( 4, t2sn(1,1,2), imigr, noso)
1906            IF( l_isend )   CALL mpi_wait( ml_req1, ml_stat, ml_err )
1907         ENDIF
1908         !
1909         !                              ! Write Dirichlet lateral conditions
1910         ijhom = nlcj - jprecj
1911         IF( nbondj == 0 .OR. nbondj == 1 ) THEN
1912            DO jl = 1, jprecj
1913               ztab(:,jl) = t2sn(:,jl,2)
1914            END DO
1915         ENDIF
1916         IF( nbondj == 0 .OR. nbondj == -1 ) THEN
1917            DO jl = 1, jprecj
1918               ztab(:,ijhom+jl) = t2ns(:,jl,2)
1919            END DO
1920         ENDIF
1921         IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN
1922            DO jj = ijpt0, ijpt1            ! north/south boundaries
1923               DO ji = iipt0,ilpt1
1924                  ptab(ji,jk) = ztab(ji,jj)
1925               END DO
1926            END DO
1927         ELSEIF( ktype==2 .AND. kd1 <= jpj+njmpp-1 .AND. njmpp <= kd2 ) THEN
1928            DO jj = ijpt0, ilpt1            ! east/west boundaries
1929               DO ji = iipt0,iipt1
1930                  ptab(jj,jk) = ztab(ji,jj)
1931               END DO
1932            END DO
1933         ENDIF
1934         !
1935      END DO
1936      !
1937      CALL wrk_dealloc( jpi,jpj, ztab )
1938      !
1939   END SUBROUTINE mppobc
1940
1941
1942   SUBROUTINE mpp_comm_free( kcom )
1943      !!----------------------------------------------------------------------
1944      !!----------------------------------------------------------------------
1945      INTEGER, INTENT(in) ::   kcom
1946      !!
1947      INTEGER :: ierr
1948      !!----------------------------------------------------------------------
1949      !
1950      CALL MPI_COMM_FREE(kcom, ierr)
1951      !
1952   END SUBROUTINE mpp_comm_free
1953
1954
1955   SUBROUTINE mpp_ini_ice( pindic, kumout )
1956      !!----------------------------------------------------------------------
1957      !!               ***  routine mpp_ini_ice  ***
1958      !!
1959      !! ** Purpose :   Initialize special communicator for ice areas
1960      !!      condition together with global variables needed in the ddmpp folding
1961      !!
1962      !! ** Method  : - Look for ice processors in ice routines
1963      !!              - Put their number in nrank_ice
1964      !!              - Create groups for the world processors and the ice processors
1965      !!              - Create a communicator for ice processors
1966      !!
1967      !! ** output
1968      !!      njmppmax = njmpp for northern procs
1969      !!      ndim_rank_ice = number of processors with ice
1970      !!      nrank_ice (ndim_rank_ice) = ice processors
1971      !!      ngrp_iworld = group ID for the world processors
1972      !!      ngrp_ice = group ID for the ice processors
1973      !!      ncomm_ice = communicator for the ice procs.
1974      !!      n_ice_root = number (in the world) of proc 0 in the ice comm.
1975      !!
1976      !!----------------------------------------------------------------------
1977      INTEGER, INTENT(in) ::   pindic
1978      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical unit
1979      !!
1980      INTEGER :: jjproc
1981      INTEGER :: ii, ierr
1982      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kice
1983      INTEGER, ALLOCATABLE, DIMENSION(:) ::   zwork
1984      !!----------------------------------------------------------------------
1985      !
1986      ! Since this is just an init routine and these arrays are of length jpnij
1987      ! then don't use wrk_nemo module - just allocate and deallocate.
1988      ALLOCATE( kice(jpnij), zwork(jpnij), STAT=ierr )
1989      IF( ierr /= 0 ) THEN
1990         WRITE(kumout, cform_err)
1991         WRITE(kumout,*) 'mpp_ini_ice : failed to allocate 2, 1D arrays (jpnij in length)'
1992         CALL mppstop
1993      ENDIF
1994
1995      ! Look for how many procs with sea-ice
1996      !
1997      kice = 0
1998      DO jjproc = 1, jpnij
1999         IF( jjproc == narea .AND. pindic .GT. 0 )   kice(jjproc) = 1
2000      END DO
2001      !
2002      zwork = 0
2003      CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_opa, ierr )
2004      ndim_rank_ice = SUM( zwork )
2005
2006      ! Allocate the right size to nrank_north
2007      IF( ALLOCATED ( nrank_ice ) )   DEALLOCATE( nrank_ice )
2008      ALLOCATE( nrank_ice(ndim_rank_ice) )
2009      !
2010      ii = 0
2011      nrank_ice = 0
2012      DO jjproc = 1, jpnij
2013         IF( zwork(jjproc) == 1) THEN
2014            ii = ii + 1
2015            nrank_ice(ii) = jjproc -1
2016         ENDIF
2017      END DO
2018
2019      ! Create the world group
2020      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_iworld, ierr )
2021
2022      ! Create the ice group from the world group
2023      CALL MPI_GROUP_INCL( ngrp_iworld, ndim_rank_ice, nrank_ice, ngrp_ice, ierr )
2024
2025      ! Create the ice communicator , ie the pool of procs with sea-ice
2026      CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_ice, ncomm_ice, ierr )
2027
2028      ! Find proc number in the world of proc 0 in the north
2029      ! The following line seems to be useless, we just comment & keep it as reminder
2030      ! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_iworld,n_ice_root,ierr)
2031      !
2032      CALL MPI_GROUP_FREE(ngrp_ice, ierr)
2033      CALL MPI_GROUP_FREE(ngrp_iworld, ierr)
2034
2035      DEALLOCATE(kice, zwork)
2036      !
2037   END SUBROUTINE mpp_ini_ice
2038
2039
2040   SUBROUTINE mpp_ini_znl( kumout )
2041      !!----------------------------------------------------------------------
2042      !!               ***  routine mpp_ini_znl  ***
2043      !!
2044      !! ** Purpose :   Initialize special communicator for computing zonal sum
2045      !!
2046      !! ** Method  : - Look for processors in the same row
2047      !!              - Put their number in nrank_znl
2048      !!              - Create group for the znl processors
2049      !!              - Create a communicator for znl processors
2050      !!              - Determine if processor should write znl files
2051      !!
2052      !! ** output
2053      !!      ndim_rank_znl = number of processors on the same row
2054      !!      ngrp_znl = group ID for the znl processors
2055      !!      ncomm_znl = communicator for the ice procs.
2056      !!      n_znl_root = number (in the world) of proc 0 in the ice comm.
2057      !!
2058      !!----------------------------------------------------------------------
2059      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical units
2060      !
2061      INTEGER :: jproc      ! dummy loop integer
2062      INTEGER :: ierr, ii   ! local integer
2063      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kwork
2064      !!----------------------------------------------------------------------
2065      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world     : ', ngrp_world
2066      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
2067      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_opa   : ', mpi_comm_opa
2068      !
2069      ALLOCATE( kwork(jpnij), STAT=ierr )
2070      IF( ierr /= 0 ) THEN
2071         WRITE(kumout, cform_err)
2072         WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij'
2073         CALL mppstop
2074      ENDIF
2075
2076      IF( jpnj == 1 ) THEN
2077         ngrp_znl  = ngrp_world
2078         ncomm_znl = mpi_comm_opa
2079      ELSE
2080         !
2081         CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_opa, ierr )
2082         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
2083         !-$$        CALL flush(numout)
2084         !
2085         ! Count number of processors on the same row
2086         ndim_rank_znl = 0
2087         DO jproc=1,jpnij
2088            IF ( kwork(jproc) == njmpp ) THEN
2089               ndim_rank_znl = ndim_rank_znl + 1
2090            ENDIF
2091         END DO
2092         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
2093         !-$$        CALL flush(numout)
2094         ! Allocate the right size to nrank_znl
2095         IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
2096         ALLOCATE(nrank_znl(ndim_rank_znl))
2097         ii = 0
2098         nrank_znl (:) = 0
2099         DO jproc=1,jpnij
2100            IF ( kwork(jproc) == njmpp) THEN
2101               ii = ii + 1
2102               nrank_znl(ii) = jproc -1
2103            ENDIF
2104         END DO
2105         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
2106         !-$$        CALL flush(numout)
2107
2108         ! Create the opa group
2109         CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_opa,ierr)
2110         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
2111         !-$$        CALL flush(numout)
2112
2113         ! Create the znl group from the opa group
2114         CALL MPI_GROUP_INCL  ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
2115         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
2116         !-$$        CALL flush(numout)
2117
2118         ! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
2119         CALL MPI_COMM_CREATE ( mpi_comm_opa, ngrp_znl, ncomm_znl, ierr )
2120         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
2121         !-$$        CALL flush(numout)
2122         !
2123      END IF
2124
2125      ! Determines if processor if the first (starting from i=1) on the row
2126      IF ( jpni == 1 ) THEN
2127         l_znl_root = .TRUE.
2128      ELSE
2129         l_znl_root = .FALSE.
2130         kwork (1) = nimpp
2131         CALL mpp_min ( kwork(1), kcom = ncomm_znl)
2132         IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
2133      END IF
2134
2135      DEALLOCATE(kwork)
2136
2137   END SUBROUTINE mpp_ini_znl
2138
2139
2140   SUBROUTINE mpp_ini_north
2141      !!----------------------------------------------------------------------
2142      !!               ***  routine mpp_ini_north  ***
2143      !!
2144      !! ** Purpose :   Initialize special communicator for north folding
2145      !!      condition together with global variables needed in the mpp folding
2146      !!
2147      !! ** Method  : - Look for northern processors
2148      !!              - Put their number in nrank_north
2149      !!              - Create groups for the world processors and the north processors
2150      !!              - Create a communicator for northern processors
2151      !!
2152      !! ** output
2153      !!      njmppmax = njmpp for northern procs
2154      !!      ndim_rank_north = number of processors in the northern line
2155      !!      nrank_north (ndim_rank_north) = number  of the northern procs.
2156      !!      ngrp_world = group ID for the world processors
2157      !!      ngrp_north = group ID for the northern processors
2158      !!      ncomm_north = communicator for the northern procs.
2159      !!      north_root = number (in the world) of proc 0 in the northern comm.
2160      !!
2161      !!----------------------------------------------------------------------
2162      INTEGER ::   ierr
2163      INTEGER ::   jjproc
2164      INTEGER ::   ii, ji
2165      !!----------------------------------------------------------------------
2166      !
2167      njmppmax = MAXVAL( njmppt )
2168      !
2169      ! Look for how many procs on the northern boundary
2170      ndim_rank_north = 0
2171      DO jjproc = 1, jpnij
2172         IF( njmppt(jjproc) == njmppmax )   ndim_rank_north = ndim_rank_north + 1
2173      END DO
2174      !
2175      ! Allocate the right size to nrank_north
2176      IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
2177      ALLOCATE( nrank_north(ndim_rank_north) )
2178
2179      ! Fill the nrank_north array with proc. number of northern procs.
2180      ! Note : the rank start at 0 in MPI
2181      ii = 0
2182      DO ji = 1, jpnij
2183         IF ( njmppt(ji) == njmppmax   ) THEN
2184            ii=ii+1
2185            nrank_north(ii)=ji-1
2186         END IF
2187      END DO
2188      !
2189      ! create the world group
2190      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
2191      !
2192      ! Create the North group from the world group
2193      CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
2194      !
2195      ! Create the North communicator , ie the pool of procs in the north group
2196      CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_north, ncomm_north, ierr )
2197      !
2198   END SUBROUTINE mpp_ini_north
2199
2200
2201   SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )
2202      !!---------------------------------------------------------------------
2203      !!                   ***  routine mpp_lbc_north_3d  ***
2204      !!
2205      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2206      !!              in mpp configuration in case of jpn1 > 1
2207      !!
2208      !! ** Method  :   North fold condition and mpp with more than one proc
2209      !!              in i-direction require a specific treatment. We gather
2210      !!              the 4 northern lines of the global domain on 1 processor
2211      !!              and apply lbc north-fold on this sub array. Then we
2212      !!              scatter the north fold array back to the processors.
2213      !!
2214      !!----------------------------------------------------------------------
2215      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d      ! 3D array on which the b.c. is applied
2216      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
2217      !                                                              !   = T ,  U , V , F or W  gridpoints
2218      REAL(wp)                        , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
2219      !!                                                             ! =  1. , the sign is kept
2220      INTEGER ::   ji, jj, jr
2221      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2222      INTEGER ::   ijpj, ijpjm1, ij, iproc
2223      INTEGER, DIMENSION (jpmaxngh)          ::   ml_req_nf          ! for mpi_isend when avoiding mpi_allgather
2224      INTEGER                                ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
2225      INTEGER, DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
2226      !!----------------------------------------------------------------------
2227      !
2228      ijpj   = 4
2229      ityp = -1
2230      ijpjm1 = 3
2231      ztab(:,:,:) = 0.e0
2232      !
2233      DO jj = nlcj - ijpj +1, nlcj          ! put in znorthloc the last 4 jlines of pt3d
2234         ij = jj - nlcj + ijpj
2235         znorthloc(:,ij,:) = pt3d(:,jj,:)
2236      END DO
2237      !
2238      !                                     ! Build in procs of ncomm_north the znorthgloio
2239      itaille = jpi * jpk * ijpj
2240      IF ( l_north_nogather ) THEN
2241         !
2242         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified
2243         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange
2244         !
2245         DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array
2246            ij = jj - nlcj + ijpj
2247            DO ji = 1, nlci
2248               ztab(ji+nimpp-1,ij,:) = pt3d(ji,jj,:)
2249            END DO
2250         END DO
2251
2252         !
2253         ! Set the exchange type in order to access the correct list of active neighbours
2254         !
2255         SELECT CASE ( cd_type )
2256            CASE ( 'T' , 'W' )
2257               ityp = 1
2258            CASE ( 'U' )
2259               ityp = 2
2260            CASE ( 'V' )
2261               ityp = 3
2262            CASE ( 'F' )
2263               ityp = 4
2264            CASE ( 'I' )
2265               ityp = 5
2266            CASE DEFAULT
2267               ityp = -1                    ! Set a default value for unsupported types which
2268                                            ! will cause a fallback to the mpi_allgather method
2269         END SELECT
2270         IF ( ityp .gt. 0 ) THEN
2271
2272            DO jr = 1,nsndto(ityp)
2273               CALL mppsend(5, znorthloc, itaille, isendto(jr,ityp), ml_req_nf(jr) )
2274            END DO
2275            DO jr = 1,nsndto(ityp)
2276               CALL mpprecv(5, zfoldwk, itaille, isendto(jr,ityp))
2277               iproc = isendto(jr,ityp) + 1
2278               ildi = nldit (iproc)
2279               ilei = nleit (iproc)
2280               iilb = nimppt(iproc)
2281               DO jj = 1, ijpj
2282                  DO ji = ildi, ilei
2283                     ztab(ji+iilb-1,jj,:) = zfoldwk(ji,jj,:)
2284                  END DO
2285               END DO
2286            END DO
2287            IF (l_isend) THEN
2288               DO jr = 1,nsndto(ityp)
2289                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
2290               END DO
2291            ENDIF
2292
2293         ENDIF
2294
2295      ENDIF
2296
2297      IF ( ityp .lt. 0 ) THEN
2298         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                &
2299            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2300         !
2301         DO jr = 1, ndim_rank_north         ! recover the global north array
2302            iproc = nrank_north(jr) + 1
2303            ildi  = nldit (iproc)
2304            ilei  = nleit (iproc)
2305            iilb  = nimppt(iproc)
2306            DO jj = 1, ijpj
2307               DO ji = ildi, ilei
2308                  ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr)
2309               END DO
2310            END DO
2311         END DO
2312      ENDIF
2313      !
2314      ! The ztab array has been either:
2315      !  a. Fully populated by the mpi_allgather operation or
2316      !  b. Had the active points for this domain and northern neighbours populated
2317      !     by peer to peer exchanges
2318      ! Either way the array may be folded by lbc_nfd and the result for the span of
2319      ! this domain will be identical.
2320      !
2321      CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
2322      !
2323      DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d
2324         ij = jj - nlcj + ijpj
2325         DO ji= 1, nlci
2326            pt3d(ji,jj,:) = ztab(ji+nimpp-1,ij,:)
2327         END DO
2328      END DO
2329      !
2330   END SUBROUTINE mpp_lbc_north_3d
2331
2332
2333   SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn)
2334      !!---------------------------------------------------------------------
2335      !!                   ***  routine mpp_lbc_north_2d  ***
2336      !!
2337      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2338      !!              in mpp configuration in case of jpn1 > 1 (for 2d array )
2339      !!
2340      !! ** Method  :   North fold condition and mpp with more than one proc
2341      !!              in i-direction require a specific treatment. We gather
2342      !!              the 4 northern lines of the global domain on 1 processor
2343      !!              and apply lbc north-fold on this sub array. Then we
2344      !!              scatter the north fold array back to the processors.
2345      !!
2346      !!----------------------------------------------------------------------
2347      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 3D array on which the b.c. is applied
2348      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
2349      !                                                          !   = T ,  U , V , F or W  gridpoints
2350      REAL(wp)                    , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
2351      !!                                                             ! =  1. , the sign is kept
2352      INTEGER ::   ji, jj, jr
2353      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2354      INTEGER ::   ijpj, ijpjm1, ij, iproc
2355      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          ! for mpi_isend when avoiding mpi_allgather
2356      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
2357      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
2358      !!----------------------------------------------------------------------
2359      !
2360      ijpj   = 4
2361      ityp = -1
2362      ijpjm1 = 3
2363      ztab_2d(:,:) = 0.e0
2364      !
2365      DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc_2d the last 4 jlines of pt2d
2366         ij = jj - nlcj + ijpj
2367         znorthloc_2d(:,ij) = pt2d(:,jj)
2368      END DO
2369
2370      !                                     ! Build in procs of ncomm_north the znorthgloio_2d
2371      itaille = jpi * ijpj
2372      IF ( l_north_nogather ) THEN
2373         !
2374         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified
2375         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange
2376         !
2377         DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array
2378            ij = jj - nlcj + ijpj
2379            DO ji = 1, nlci
2380               ztab_2d(ji+nimpp-1,ij) = pt2d(ji,jj)
2381            END DO
2382         END DO
2383
2384         !
2385         ! Set the exchange type in order to access the correct list of active neighbours
2386         !
2387         SELECT CASE ( cd_type )
2388            CASE ( 'T' , 'W' )
2389               ityp = 1
2390            CASE ( 'U' )
2391               ityp = 2
2392            CASE ( 'V' )
2393               ityp = 3
2394            CASE ( 'F' )
2395               ityp = 4
2396            CASE ( 'I' )
2397               ityp = 5
2398            CASE DEFAULT
2399               ityp = -1                    ! Set a default value for unsupported types which
2400                                            ! will cause a fallback to the mpi_allgather method
2401         END SELECT
2402
2403         IF ( ityp .gt. 0 ) THEN
2404
2405            DO jr = 1,nsndto(ityp)
2406               CALL mppsend(5, znorthloc_2d, itaille, isendto(jr,ityp), ml_req_nf(jr) )
2407            END DO
2408            DO jr = 1,nsndto(ityp)
2409               CALL mpprecv(5, zfoldwk_2d, itaille, isendto(jr,ityp))
2410               iproc = isendto(jr,ityp) + 1
2411               ildi = nldit (iproc)
2412               ilei = nleit (iproc)
2413               iilb = nimppt(iproc)
2414               DO jj = 1, ijpj
2415                  DO ji = ildi, ilei
2416                     ztab_2d(ji+iilb-1,jj) = zfoldwk_2d(ji,jj)
2417                  END DO
2418               END DO
2419            END DO
2420            IF (l_isend) THEN
2421               DO jr = 1,nsndto(ityp)
2422                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
2423               END DO
2424            ENDIF
2425
2426         ENDIF
2427
2428      ENDIF
2429
2430      IF ( ityp .lt. 0 ) THEN
2431         CALL MPI_ALLGATHER( znorthloc_2d  , itaille, MPI_DOUBLE_PRECISION,        &
2432            &                znorthgloio_2d, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2433         !
2434         DO jr = 1, ndim_rank_north            ! recover the global north array
2435            iproc = nrank_north(jr) + 1
2436            ildi = nldit (iproc)
2437            ilei = nleit (iproc)
2438            iilb = nimppt(iproc)
2439            DO jj = 1, ijpj
2440               DO ji = ildi, ilei
2441                  ztab_2d(ji+iilb-1,jj) = znorthgloio_2d(ji,jj,jr)
2442               END DO
2443            END DO
2444         END DO
2445      ENDIF
2446      !
2447      ! The ztab array has been either:
2448      !  a. Fully populated by the mpi_allgather operation or
2449      !  b. Had the active points for this domain and northern neighbours populated
2450      !     by peer to peer exchanges
2451      ! Either way the array may be folded by lbc_nfd and the result for the span of
2452      ! this domain will be identical.
2453      !
2454      CALL lbc_nfd( ztab_2d, cd_type, psgn )   ! North fold boundary condition
2455      !
2456      !
2457      DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
2458         ij = jj - nlcj + ijpj
2459         DO ji = 1, nlci
2460            pt2d(ji,jj) = ztab_2d(ji+nimpp-1,ij)
2461         END DO
2462      END DO
2463      !
2464   END SUBROUTINE mpp_lbc_north_2d
2465
2466
2467   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)
2468      !!---------------------------------------------------------------------
2469      !!                   ***  routine mpp_lbc_north_2d  ***
2470      !!
2471      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2472      !!              in mpp configuration in case of jpn1 > 1 and for 2d
2473      !!              array with outer extra halo
2474      !!
2475      !! ** Method  :   North fold condition and mpp with more than one proc
2476      !!              in i-direction require a specific treatment. We gather
2477      !!              the 4+2*jpr2dj northern lines of the global domain on 1
2478      !!              processor and apply lbc north-fold on this sub array.
2479      !!              Then we scatter the north fold array back to the processors.
2480      !!
2481      !!----------------------------------------------------------------------
2482      REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
2483      CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points
2484      !                                                                                         !   = T ,  U , V , F or W -points
2485      REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! = -1. the sign change across the
2486      !!                                                                                        ! north fold, =  1. otherwise
2487      INTEGER ::   ji, jj, jr
2488      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2489      INTEGER ::   ijpj, ij, iproc
2490      !!----------------------------------------------------------------------
2491      !
2492      ijpj=4
2493      ztab_e(:,:) = 0.e0
2494
2495      ij=0
2496      ! put in znorthloc_e the last 4 jlines of pt2d
2497      DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
2498         ij = ij + 1
2499         DO ji = 1, jpi
2500            znorthloc_e(ji,ij)=pt2d(ji,jj)
2501         END DO
2502      END DO
2503      !
2504      itaille = jpi * ( ijpj + 2 * jpr2dj )
2505      CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    &
2506         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2507      !
2508      DO jr = 1, ndim_rank_north            ! recover the global north array
2509         iproc = nrank_north(jr) + 1
2510         ildi = nldit (iproc)
2511         ilei = nleit (iproc)
2512         iilb = nimppt(iproc)
2513         DO jj = 1, ijpj+2*jpr2dj
2514            DO ji = ildi, ilei
2515               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
2516            END DO
2517         END DO
2518      END DO
2519
2520
2521      ! 2. North-Fold boundary conditions
2522      ! ----------------------------------
2523      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )
2524
2525      ij = jpr2dj
2526      !! Scatter back to pt2d
2527      DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj
2528      ij  = ij +1
2529         DO ji= 1, nlci
2530            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
2531         END DO
2532      END DO
2533      !
2534   END SUBROUTINE mpp_lbc_north_e
2535
2536
2537   SUBROUTINE mpi_init_opa( ldtxt, ksft, code )
2538      !!---------------------------------------------------------------------
2539      !!                   ***  routine mpp_init.opa  ***
2540      !!
2541      !! ** Purpose :: export and attach a MPI buffer for bsend
2542      !!
2543      !! ** Method  :: define buffer size in namelist, if 0 no buffer attachment
2544      !!            but classical mpi_init
2545      !!
2546      !! History :: 01/11 :: IDRIS initial version for IBM only
2547      !!            08/04 :: R. Benshila, generalisation
2548      !!---------------------------------------------------------------------
2549      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt
2550      INTEGER                      , INTENT(inout) ::   ksft
2551      INTEGER                      , INTENT(  out) ::   code
2552      INTEGER                                      ::   ierr, ji
2553      LOGICAL                                      ::   mpi_was_called
2554      !!---------------------------------------------------------------------
2555      !
2556      CALL mpi_initialized( mpi_was_called, code )      ! MPI initialization
2557      IF ( code /= MPI_SUCCESS ) THEN
2558         DO ji = 1, SIZE(ldtxt)
2559            IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
2560         END DO
2561         WRITE(*, cform_err)
2562         WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized'
2563         CALL mpi_abort( mpi_comm_world, code, ierr )
2564      ENDIF
2565      !
2566      IF( .NOT. mpi_was_called ) THEN
2567         CALL mpi_init( code )
2568         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code )
2569         IF ( code /= MPI_SUCCESS ) THEN
2570            DO ji = 1, SIZE(ldtxt)
2571               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
2572            END DO
2573            WRITE(*, cform_err)
2574            WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
2575            CALL mpi_abort( mpi_comm_world, code, ierr )
2576         ENDIF
2577      ENDIF
2578      !
2579      IF( nn_buffer > 0 ) THEN
2580         WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of  : ', nn_buffer   ;   ksft = ksft + 1
2581         ! Buffer allocation and attachment
2582         ALLOCATE( tampon(nn_buffer), stat = ierr )
2583         IF( ierr /= 0 ) THEN
2584            DO ji = 1, SIZE(ldtxt)
2585               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
2586            END DO
2587            WRITE(*, cform_err)
2588            WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr
2589            CALL mpi_abort( mpi_comm_world, code, ierr )
2590         END IF
2591         CALL mpi_buffer_attach( tampon, nn_buffer, code )
2592      ENDIF
2593      !
2594   END SUBROUTINE mpi_init_opa
2595
2596   SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype)
2597      !!---------------------------------------------------------------------
2598      !!   Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
2599      !!
2600      !!   Modification of original codes written by David H. Bailey
2601      !!   This subroutine computes yddb(i) = ydda(i)+yddb(i)
2602      !!---------------------------------------------------------------------
2603      INTEGER, INTENT(in)                         :: ilen, itype
2604      COMPLEX(wp), DIMENSION(ilen), INTENT(in)     :: ydda
2605      COMPLEX(wp), DIMENSION(ilen), INTENT(inout)  :: yddb
2606      !
2607      REAL(wp) :: zerr, zt1, zt2    ! local work variables
2608      INTEGER :: ji, ztmp           ! local scalar
2609
2610      ztmp = itype   ! avoid compilation warning
2611
2612      DO ji=1,ilen
2613      ! Compute ydda + yddb using Knuth's trick.
2614         zt1  = real(ydda(ji)) + real(yddb(ji))
2615         zerr = zt1 - real(ydda(ji))
2616         zt2  = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
2617                + aimag(ydda(ji)) + aimag(yddb(ji))
2618
2619         ! The result is zt1 + zt2, after normalization.
2620         yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
2621      END DO
2622
2623   END SUBROUTINE DDPDD_MPI
2624
2625#else
2626   !!----------------------------------------------------------------------
2627   !!   Default case:            Dummy module        share memory computing
2628   !!----------------------------------------------------------------------
2629   USE in_out_manager
2630
2631   INTERFACE mpp_sum
2632      MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i, mppsum_realdd, mppsum_a_realdd
2633   END INTERFACE
2634   INTERFACE mpp_max
2635      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
2636   END INTERFACE
2637   INTERFACE mpp_min
2638      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
2639   END INTERFACE
2640   INTERFACE mppobc
2641      MODULE PROCEDURE mppobc_1d, mppobc_2d, mppobc_3d, mppobc_4d
2642   END INTERFACE
2643   INTERFACE mpp_minloc
2644      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
2645   END INTERFACE
2646   INTERFACE mpp_maxloc
2647      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
2648   END INTERFACE
2649
2650   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag
2651   LOGICAL, PUBLIC            ::   ln_nnogather  = .FALSE.  !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used)
2652   INTEGER :: ncomm_ice
2653   !!----------------------------------------------------------------------
2654CONTAINS
2655
2656   INTEGER FUNCTION lib_mpp_alloc(kumout)          ! Dummy function
2657      INTEGER, INTENT(in) ::   kumout
2658      lib_mpp_alloc = 0
2659   END FUNCTION lib_mpp_alloc
2660
2661   FUNCTION mynode( ldtxt, kumnam, kstop, localComm ) RESULT (function_value)
2662      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm
2663      CHARACTER(len=*),DIMENSION(:) ::   ldtxt
2664      INTEGER ::   kumnam, kstop
2665      IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) )   function_value = 0
2666      IF( .FALSE. )   ldtxt(:) = 'never done'
2667   END FUNCTION mynode
2668
2669   SUBROUTINE mppsync                       ! Dummy routine
2670   END SUBROUTINE mppsync
2671
2672   SUBROUTINE mpp_sum_as( parr, kdim, kcom )      ! Dummy routine
2673      REAL   , DIMENSION(:) :: parr
2674      INTEGER               :: kdim
2675      INTEGER, OPTIONAL     :: kcom
2676      WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
2677   END SUBROUTINE mpp_sum_as
2678
2679   SUBROUTINE mpp_sum_a2s( parr, kdim, kcom )      ! Dummy routine
2680      REAL   , DIMENSION(:,:) :: parr
2681      INTEGER               :: kdim
2682      INTEGER, OPTIONAL     :: kcom
2683      WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
2684   END SUBROUTINE mpp_sum_a2s
2685
2686   SUBROUTINE mpp_sum_ai( karr, kdim, kcom )      ! Dummy routine
2687      INTEGER, DIMENSION(:) :: karr
2688      INTEGER               :: kdim
2689      INTEGER, OPTIONAL     :: kcom
2690      WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
2691   END SUBROUTINE mpp_sum_ai
2692
2693   SUBROUTINE mpp_sum_s( psca, kcom )            ! Dummy routine
2694      REAL                  :: psca
2695      INTEGER, OPTIONAL     :: kcom
2696      WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
2697   END SUBROUTINE mpp_sum_s
2698
2699   SUBROUTINE mpp_sum_i( kint, kcom )            ! Dummy routine
2700      integer               :: kint
2701      INTEGER, OPTIONAL     :: kcom
2702      WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
2703   END SUBROUTINE mpp_sum_i
2704
2705   SUBROUTINE mppsum_realdd( ytab, kcom )
2706      COMPLEX(wp), INTENT(inout)         :: ytab    ! input scalar
2707      INTEGER , INTENT( in  ), OPTIONAL :: kcom
2708      WRITE(*,*) 'mppsum_realdd: You should not have seen this print! error?', ytab
2709   END SUBROUTINE mppsum_realdd
2710
2711   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
2712      INTEGER , INTENT( in )                        ::   kdim      ! size of ytab
2713      COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) ::   ytab      ! input array
2714      INTEGER , INTENT( in  ), OPTIONAL :: kcom
2715      WRITE(*,*) 'mppsum_a_realdd: You should not have seen this print! error?', kdim, ytab(1), kcom
2716   END SUBROUTINE mppsum_a_realdd
2717
2718   SUBROUTINE mppmax_a_real( parr, kdim, kcom )
2719      REAL   , DIMENSION(:) :: parr
2720      INTEGER               :: kdim
2721      INTEGER, OPTIONAL     :: kcom
2722      WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
2723   END SUBROUTINE mppmax_a_real
2724
2725   SUBROUTINE mppmax_real( psca, kcom )
2726      REAL                  :: psca
2727      INTEGER, OPTIONAL     :: kcom
2728      WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca, kcom
2729   END SUBROUTINE mppmax_real
2730
2731   SUBROUTINE mppmin_a_real( parr, kdim, kcom )
2732      REAL   , DIMENSION(:) :: parr
2733      INTEGER               :: kdim
2734      INTEGER, OPTIONAL     :: kcom
2735      WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
2736   END SUBROUTINE mppmin_a_real
2737
2738   SUBROUTINE mppmin_real( psca, kcom )
2739      REAL                  :: psca
2740      INTEGER, OPTIONAL     :: kcom
2741      WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca, kcom
2742   END SUBROUTINE mppmin_real
2743
2744   SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
2745      INTEGER, DIMENSION(:) :: karr
2746      INTEGER               :: kdim
2747      INTEGER, OPTIONAL     :: kcom
2748      WRITE(*,*) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
2749   END SUBROUTINE mppmax_a_int
2750
2751   SUBROUTINE mppmax_int( kint, kcom)
2752      INTEGER               :: kint
2753      INTEGER, OPTIONAL     :: kcom
2754      WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint, kcom
2755   END SUBROUTINE mppmax_int
2756
2757   SUBROUTINE mppmin_a_int( karr, kdim, kcom )
2758      INTEGER, DIMENSION(:) :: karr
2759      INTEGER               :: kdim
2760      INTEGER, OPTIONAL     :: kcom
2761      WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
2762   END SUBROUTINE mppmin_a_int
2763
2764   SUBROUTINE mppmin_int( kint, kcom )
2765      INTEGER               :: kint
2766      INTEGER, OPTIONAL     :: kcom
2767      WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom
2768   END SUBROUTINE mppmin_int
2769
2770   SUBROUTINE mppobc_1d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
2771      INTEGER  ::   kd1, kd2, kl , kk, ktype, kij, knum
2772      REAL, DIMENSION(:) ::   parr           ! variable array
2773      WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1), kd1, kd2, kl, kk, ktype, kij, knum
2774   END SUBROUTINE mppobc_1d
2775
2776   SUBROUTINE mppobc_2d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
2777      INTEGER  ::   kd1, kd2, kl , kk, ktype, kij, knum
2778      REAL, DIMENSION(:,:) ::   parr           ! variable array
2779      WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1), kd1, kd2, kl, kk, ktype, kij, knum
2780   END SUBROUTINE mppobc_2d
2781
2782   SUBROUTINE mppobc_3d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
2783      INTEGER  ::   kd1, kd2, kl , kk, ktype, kij, knum
2784      REAL, DIMENSION(:,:,:) ::   parr           ! variable array
2785      WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1,1), kd1, kd2, kl, kk, ktype, kij, knum
2786   END SUBROUTINE mppobc_3d
2787
2788   SUBROUTINE mppobc_4d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
2789      INTEGER  ::   kd1, kd2, kl , kk, ktype, kij, knum
2790      REAL, DIMENSION(:,:,:,:) ::   parr           ! variable array
2791      WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1,1,1), kd1, kd2, kl, kk, ktype, kij, knum
2792   END SUBROUTINE mppobc_4d
2793
2794   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj )
2795      REAL                   :: pmin
2796      REAL , DIMENSION (:,:) :: ptab, pmask
2797      INTEGER :: ki, kj
2798      WRITE(*,*) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1)
2799   END SUBROUTINE mpp_minloc2d
2800
2801   SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk )
2802      REAL                     :: pmin
2803      REAL , DIMENSION (:,:,:) :: ptab, pmask
2804      INTEGER :: ki, kj, kk
2805      WRITE(*,*) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
2806   END SUBROUTINE mpp_minloc3d
2807
2808   SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
2809      REAL                   :: pmax
2810      REAL , DIMENSION (:,:) :: ptab, pmask
2811      INTEGER :: ki, kj
2812      WRITE(*,*) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1)
2813   END SUBROUTINE mpp_maxloc2d
2814
2815   SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
2816      REAL                     :: pmax
2817      REAL , DIMENSION (:,:,:) :: ptab, pmask
2818      INTEGER :: ki, kj, kk
2819      WRITE(*,*) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
2820   END SUBROUTINE mpp_maxloc3d
2821
2822   SUBROUTINE mppstop
2823      WRITE(*,*) 'mppstop: You should not have seen this print if running in mpp mode! error?...'
2824      WRITE(*,*) 'mppstop: ..otherwise this is a stop condition raised by ctl_stop in single processor mode'
2825      STOP
2826   END SUBROUTINE mppstop
2827
2828   SUBROUTINE mpp_ini_ice( kcom, knum )
2829      INTEGER :: kcom, knum
2830      WRITE(*,*) 'mpp_ini_ice: You should not have seen this print! error?', kcom, knum
2831   END SUBROUTINE mpp_ini_ice
2832
2833   SUBROUTINE mpp_ini_znl( knum )
2834      INTEGER :: knum
2835      WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum
2836   END SUBROUTINE mpp_ini_znl
2837
2838   SUBROUTINE mpp_comm_free( kcom )
2839      INTEGER :: kcom
2840      WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom
2841   END SUBROUTINE mpp_comm_free
2842#endif
2843
2844   !!----------------------------------------------------------------------
2845   !!   All cases:         ctl_stop, ctl_warn, get_unit, ctl_opn   routines
2846   !!----------------------------------------------------------------------
2847
2848   SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 ,   &
2849      &                 cd6, cd7, cd8, cd9, cd10 )
2850      !!----------------------------------------------------------------------
2851      !!                  ***  ROUTINE  stop_opa  ***
2852      !!
2853      !! ** Purpose :   print in ocean.outpput file a error message and
2854      !!                increment the error number (nstop) by one.
2855      !!----------------------------------------------------------------------
2856      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5
2857      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10
2858      !!----------------------------------------------------------------------
2859      !
2860      nstop = nstop + 1
2861      IF(lwp) THEN
2862         WRITE(numout,cform_err)
2863         IF( PRESENT(cd1 ) )   WRITE(numout,*) cd1
2864         IF( PRESENT(cd2 ) )   WRITE(numout,*) cd2
2865         IF( PRESENT(cd3 ) )   WRITE(numout,*) cd3
2866         IF( PRESENT(cd4 ) )   WRITE(numout,*) cd4
2867         IF( PRESENT(cd5 ) )   WRITE(numout,*) cd5
2868         IF( PRESENT(cd6 ) )   WRITE(numout,*) cd6
2869         IF( PRESENT(cd7 ) )   WRITE(numout,*) cd7
2870         IF( PRESENT(cd8 ) )   WRITE(numout,*) cd8
2871         IF( PRESENT(cd9 ) )   WRITE(numout,*) cd9
2872         IF( PRESENT(cd10) )   WRITE(numout,*) cd10
2873      ENDIF
2874                               CALL FLUSH(numout    )
2875      IF( numstp     /= -1 )   CALL FLUSH(numstp    )
2876      IF( numsol     /= -1 )   CALL FLUSH(numsol    )
2877      IF( numevo_ice /= -1 )   CALL FLUSH(numevo_ice)
2878      !
2879      IF( cd1 == 'STOP' ) THEN
2880         IF(lwp) WRITE(numout,*)  'huge E-R-R-O-R : immediate stop'
2881         CALL mppstop()
2882      ENDIF
2883      !
2884   END SUBROUTINE ctl_stop
2885
2886
2887   SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5,   &
2888      &                 cd6, cd7, cd8, cd9, cd10 )
2889      !!----------------------------------------------------------------------
2890      !!                  ***  ROUTINE  stop_warn  ***
2891      !!
2892      !! ** Purpose :   print in ocean.outpput file a error message and
2893      !!                increment the warning number (nwarn) by one.
2894      !!----------------------------------------------------------------------
2895      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5
2896      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10
2897      !!----------------------------------------------------------------------
2898      !
2899      nwarn = nwarn + 1
2900      IF(lwp) THEN
2901         WRITE(numout,cform_war)
2902         IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
2903         IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
2904         IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
2905         IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
2906         IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
2907         IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
2908         IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
2909         IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
2910         IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
2911         IF( PRESENT(cd10) ) WRITE(numout,*) cd10
2912      ENDIF
2913      CALL FLUSH(numout)
2914      !
2915   END SUBROUTINE ctl_warn
2916
2917
2918   SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea )
2919      !!----------------------------------------------------------------------
2920      !!                  ***  ROUTINE ctl_opn  ***
2921      !!
2922      !! ** Purpose :   Open file and check if required file is available.
2923      !!
2924      !! ** Method  :   Fortan open
2925      !!----------------------------------------------------------------------
2926      INTEGER          , INTENT(  out) ::   knum      ! logical unit to open
2927      CHARACTER(len=*) , INTENT(in   ) ::   cdfile    ! file name to open
2928      CHARACTER(len=*) , INTENT(in   ) ::   cdstat    ! disposition specifier
2929      CHARACTER(len=*) , INTENT(in   ) ::   cdform    ! formatting specifier
2930      CHARACTER(len=*) , INTENT(in   ) ::   cdacce    ! access specifier
2931      INTEGER          , INTENT(in   ) ::   klengh    ! record length
2932      INTEGER          , INTENT(in   ) ::   kout      ! number of logical units for write
2933      LOGICAL          , INTENT(in   ) ::   ldwp      ! boolean term for print
2934      INTEGER, OPTIONAL, INTENT(in   ) ::   karea     ! proc number
2935      !!
2936      CHARACTER(len=80) ::   clfile
2937      INTEGER           ::   iost
2938      !!----------------------------------------------------------------------
2939
2940      ! adapt filename
2941      ! ----------------
2942      clfile = TRIM(cdfile)
2943      IF( PRESENT( karea ) ) THEN
2944         IF( karea > 1 )   WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1
2945      ENDIF
2946#if defined key_agrif
2947      IF( .NOT. Agrif_Root() )   clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile)
2948      knum=Agrif_Get_Unit()
2949#else
2950      knum=get_unit()
2951#endif
2952
2953      iost=0
2954      IF( cdacce(1:6) == 'DIRECT' )  THEN
2955         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh, ERR=100, IOSTAT=iost )
2956      ELSE
2957         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat             , ERR=100, IOSTAT=iost )
2958      ENDIF
2959      IF( iost == 0 ) THEN
2960         IF(ldwp) THEN
2961            WRITE(kout,*) '     file   : ', clfile,' open ok'
2962            WRITE(kout,*) '     unit   = ', knum
2963            WRITE(kout,*) '     status = ', cdstat
2964            WRITE(kout,*) '     form   = ', cdform
2965            WRITE(kout,*) '     access = ', cdacce
2966            WRITE(kout,*)
2967         ENDIF
2968      ENDIF
2969100   CONTINUE
2970      IF( iost /= 0 ) THEN
2971         IF(ldwp) THEN
2972            WRITE(kout,*)
2973            WRITE(kout,*) ' ===>>>> : bad opening file: ', clfile
2974            WRITE(kout,*) ' =======   ===  '
2975            WRITE(kout,*) '           unit   = ', knum
2976            WRITE(kout,*) '           status = ', cdstat
2977            WRITE(kout,*) '           form   = ', cdform
2978            WRITE(kout,*) '           access = ', cdacce
2979            WRITE(kout,*) '           iostat = ', iost
2980            WRITE(kout,*) '           we stop. verify the file '
2981            WRITE(kout,*)
2982         ENDIF
2983         STOP 'ctl_opn bad opening'
2984      ENDIF
2985
2986   END SUBROUTINE ctl_opn
2987
2988
2989   INTEGER FUNCTION get_unit()
2990      !!----------------------------------------------------------------------
2991      !!                  ***  FUNCTION  get_unit  ***
2992      !!
2993      !! ** Purpose :   return the index of an unused logical unit
2994      !!----------------------------------------------------------------------
2995      LOGICAL :: llopn
2996      !!----------------------------------------------------------------------
2997      !
2998      get_unit = 15   ! choose a unit that is big enough then it is not already used in NEMO
2999      llopn = .TRUE.
3000      DO WHILE( (get_unit < 998) .AND. llopn )
3001         get_unit = get_unit + 1
3002         INQUIRE( unit = get_unit, opened = llopn )
3003      END DO
3004      IF( (get_unit == 999) .AND. llopn ) THEN
3005         CALL ctl_stop( 'get_unit: All logical units until 999 are used...' )
3006         get_unit = -1
3007      ENDIF
3008      !
3009   END FUNCTION get_unit
3010
3011   !!----------------------------------------------------------------------
3012END MODULE lib_mpp
Note: See TracBrowser for help on using the repository browser.