source: branches/2015/dev_r5546_CNRS19_HPC_scalability/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 5579

Last change on this file since 5579 was 5579, checked in by mcastril, 5 years ago

ticket #1539 Performance optimizations on NEMO 3.6 limhdf routine

  • Property svn:keywords set to Id
File size: 172.7 KB
Line 
1MODULE lib_mpp
2   !!======================================================================
3   !!                       ***  MODULE  lib_mpp  ***
4   !! Ocean numerics:  massively parallel processing library
5   !!=====================================================================
6   !! History :  OPA  !  1994  (M. Guyon, J. Escobar, M. Imbard)  Original code
7   !!            7.0  !  1997  (A.M. Treguier)  SHMEM additions
8   !!            8.0  !  1998  (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
9   !!                 !  1998  (J.M. Molines) Open boundary conditions
10   !!   NEMO     1.0  !  2003  (J.-M. Molines, G. Madec)  F90, free form
11   !!                 !  2003  (J.M. Molines) add mpp_ini_north(_3d,_2d)
12   !!             -   !  2004  (R. Bourdalle Badie)  isend option in mpi
13   !!                 !  2004  (J.M. Molines) minloc, maxloc
14   !!             -   !  2005  (G. Madec, S. Masson)  npolj=5,6 F-point & ice cases
15   !!             -   !  2005  (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort
16   !!             -   !  2005  (R. Benshila, G. Madec)  add extra halo case
17   !!             -   !  2008  (R. Benshila) add mpp_ini_ice
18   !!            3.2  !  2009  (R. Benshila) SHMEM suppression, north fold in lbc_nfd
19   !!            3.2  !  2009  (O. Marti)    add mpp_ini_znl
20   !!            4.0  !  2011  (G. Madec)  move ctl_ routines from in_out_manager
21   !!            3.5  !  2012  (S.Mocavero, I. Epicoco) Add 'mpp_lnk_bdy_3d', 'mpp_lnk_obc_3d',
22   !!                          'mpp_lnk_bdy_2d' and 'mpp_lnk_obc_2d' routines and update
23   !!                          the mppobc routine to optimize the BDY and OBC communications
24   !!            3.5  !  2013  ( C. Ethe, G. Madec ) message passing arrays as local variables
25   !!            3.5  !  2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations
26   !!----------------------------------------------------------------------
27
28   !!----------------------------------------------------------------------
29   !!   ctl_stop   : update momentum and tracer Kz from a tke scheme
30   !!   ctl_warn   : initialization, namelist read, and parameters control
31   !!   ctl_opn    : Open file and check if required file is available.
32   !!   ctl_nam    : Prints informations when an error occurs while reading a namelist
33   !!   get_unit   : give the index of an unused logical unit
34   !!----------------------------------------------------------------------
35#if   defined key_mpp_mpi
36   !!----------------------------------------------------------------------
37   !!   'key_mpp_mpi'             MPI massively parallel processing library
38   !!----------------------------------------------------------------------
39   !!   lib_mpp_alloc : allocate mpp arrays
40   !!   mynode        : indentify the processor unit
41   !!   mpp_lnk       : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d)
42   !!   mpp_lnk_3d_gather :  Message passing manadgement for two 3D arrays
43   !!   mpp_lnk_e     : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e)
44   !!   mpp_lnk_icb   : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb)
45   !!   mpprecv         :
46   !!   mppsend       :   SUBROUTINE mpp_ini_znl
47   !!   mppscatter    :
48   !!   mppgather     :
49   !!   mpp_min       : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
50   !!   mpp_max       : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
51   !!   mpp_sum       : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
52   !!   mpp_minloc    :
53   !!   mpp_maxloc    :
54   !!   mppsync       :
55   !!   mppstop       :
56   !!   mpp_ini_north : initialisation of north fold
57   !!   mpp_lbc_north : north fold processors gathering
58   !!   mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo
59   !!   mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs
60   !!----------------------------------------------------------------------
61   USE dom_oce        ! ocean space and time domain
62   USE lbcnfd         ! north fold treatment
63   USE in_out_manager ! I/O manager
64   USE wrk_nemo       ! work arrays
65
66   IMPLICIT NONE
67   PRIVATE
68   
69   PUBLIC   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam
70   PUBLIC   mynode, mppstop, mppsync, mpp_comm_free
71   PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e
72   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc
73   PUBLIC   mpp_max_multiple
74   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e
75   PUBLIC   mpp_lnk_2d_9 , mpp_lnk_2d_multiple 
76   PUBLIC   mppscatter, mppgather
77   PUBLIC   mpp_ini_ice, mpp_ini_znl
78   PUBLIC   mppsize
79   PUBLIC   mppsend, mpprecv                          ! needed by TAM and ICB routines
80   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d
81   PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb
82   PUBLIC   mpprank
83
84   TYPE arrayptr
85      REAL , DIMENSION (:,:),  POINTER :: pt2d
86   END TYPE arrayptr
87   PUBLIC   arrayptr
88   
89   !! * Interfaces
90   !! define generic interface for these routine as they are called sometimes
91   !! with scalar arguments instead of array arguments, which causes problems
92   !! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
93   INTERFACE mpp_min
94      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
95   END INTERFACE
96   INTERFACE mpp_max
97      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
98   END INTERFACE
99   INTERFACE mpp_sum
100      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, &
101                       mppsum_realdd, mppsum_a_realdd
102   END INTERFACE
103   INTERFACE mpp_lbc_north
104      MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d
105   END INTERFACE
106   INTERFACE mpp_minloc
107      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
108   END INTERFACE
109   INTERFACE mpp_maxloc
110      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
111   END INTERFACE
112
113   INTERFACE mpp_max_multiple
114      MODULE PROCEDURE mppmax_real_multiple
115   END INTERFACE
116
117   !! ========================= !!
118   !!  MPI  variable definition !!
119   !! ========================= !!
120!$AGRIF_DO_NOT_TREAT
121   INCLUDE 'mpif.h'
122!$AGRIF_END_DO_NOT_TREAT
123
124   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .TRUE.    !: mpp flag
125
126   INTEGER, PARAMETER         ::   nprocmax = 2**10   ! maximun dimension (required to be a power of 2)
127
128   INTEGER ::   mppsize        ! number of process
129   INTEGER ::   mpprank        ! process number  [ 0 - size-1 ]
130!$AGRIF_DO_NOT_TREAT
131   INTEGER, PUBLIC ::   mpi_comm_opa   ! opa local communicator
132!$AGRIF_END_DO_NOT_TREAT
133
134   INTEGER :: MPI_SUMDD
135
136   ! variables used in case of sea-ice
137   INTEGER, PUBLIC ::   ncomm_ice       !: communicator made by the processors with sea-ice (public so that it can be freed in limthd)
138   INTEGER ::   ngrp_iworld     !  group ID for the world processors (for rheology)
139   INTEGER ::   ngrp_ice        !  group ID for the ice processors (for rheology)
140   INTEGER ::   ndim_rank_ice   !  number of 'ice' processors
141   INTEGER ::   n_ice_root      !  number (in the comm_ice) of proc 0 in the ice comm
142   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_ice     ! dimension ndim_rank_ice
143
144   ! variables used for zonal integration
145   INTEGER, PUBLIC ::   ncomm_znl       !: communicator made by the processors on the same zonal average
146   LOGICAL, PUBLIC ::   l_znl_root      ! True on the 'left'most processor on the same row
147   INTEGER ::   ngrp_znl        ! group ID for the znl processors
148   INTEGER ::   ndim_rank_znl   ! number of processors on the same zonal average
149   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_znl  ! dimension ndim_rank_znl, number of the procs into the same znl domain
150
151   ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM)
152   INTEGER, PUBLIC ::   ngrp_world        ! group ID for the world processors
153   INTEGER, PUBLIC ::   ngrp_opa          ! group ID for the opa processors
154   INTEGER, PUBLIC ::   ngrp_north        ! group ID for the northern processors (to be fold)
155   INTEGER, PUBLIC ::   ncomm_north       ! communicator made by the processors belonging to ngrp_north
156   INTEGER, PUBLIC ::   ndim_rank_north   ! number of 'sea' processor in the northern line (can be /= jpni !)
157   INTEGER, PUBLIC ::   njmppmax          ! value of njmpp for the processors of the northern line
158   INTEGER, PUBLIC ::   north_root        ! number (in the comm_opa) of proc 0 in the northern comm
159   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, PUBLIC ::   nrank_north   ! dimension ndim_rank_north
160
161   ! Type of send : standard, buffered, immediate
162   CHARACTER(len=1), PUBLIC ::   cn_mpi_send   ! type od mpi send/recieve (S=standard, B=bsend, I=isend)
163   LOGICAL, PUBLIC          ::   l_isend = .FALSE.   ! isend use indicator (T if cn_mpi_send='I')
164   INTEGER, PUBLIC          ::   nn_buffer     ! size of the buffer in case of mpi_bsend
165
166   REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon  ! buffer in case of bsend
167
168   LOGICAL, PUBLIC                                  ::   ln_nnogather       ! namelist control of northfold comms
169   LOGICAL, PUBLIC                                  ::   l_north_nogather = .FALSE.  ! internal control of northfold comms
170   INTEGER, PUBLIC                                  ::   ityp
171   !!----------------------------------------------------------------------
172   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
173   !! $Id$
174   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
175   !!----------------------------------------------------------------------
176CONTAINS
177
178
179   FUNCTION mynode( ldtxt, ldname, kumnam_ref , kumnam_cfg , kumond , kstop, localComm )
180      !!----------------------------------------------------------------------
181      !!                  ***  routine mynode  ***
182      !!
183      !! ** Purpose :   Find processor unit
184      !!----------------------------------------------------------------------
185      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt
186      CHARACTER(len=*)             , INTENT(in   ) ::   ldname
187      INTEGER                      , INTENT(in   ) ::   kumnam_ref     ! logical unit for reference namelist
188      INTEGER                      , INTENT(in   ) ::   kumnam_cfg     ! logical unit for configuration namelist
189      INTEGER                      , INTENT(inout) ::   kumond         ! logical unit for namelist output
190      INTEGER                      , INTENT(inout) ::   kstop          ! stop indicator
191      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm
192      !
193      INTEGER ::   mynode, ierr, code, ji, ii, ios
194      LOGICAL ::   mpi_was_called
195      !
196      NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij, ln_nnogather
197      !!----------------------------------------------------------------------
198      !
199      ii = 1
200      WRITE(ldtxt(ii),*)                                                                          ;   ii = ii + 1
201      WRITE(ldtxt(ii),*) 'mynode : mpi initialisation'                                            ;   ii = ii + 1
202      WRITE(ldtxt(ii),*) '~~~~~~ '                                                                ;   ii = ii + 1
203      !
204
205      REWIND( kumnam_ref )              ! Namelist nammpp in reference namelist: mpi variables
206      READ  ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901)
207901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp )
208
209      REWIND( kumnam_cfg )              ! Namelist nammpp in configuration namelist: mpi variables
210      READ  ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 )
211902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp )
212
213      !                              ! control print
214      WRITE(ldtxt(ii),*) '   Namelist nammpp'                                                     ;   ii = ii + 1
215      WRITE(ldtxt(ii),*) '      mpi send type                      cn_mpi_send = ', cn_mpi_send   ;   ii = ii + 1
216      WRITE(ldtxt(ii),*) '      size in bytes of exported buffer   nn_buffer   = ', nn_buffer     ;   ii = ii + 1
217
218#if defined key_agrif
219      IF( .NOT. Agrif_Root() ) THEN
220         jpni  = Agrif_Parent(jpni )
221         jpnj  = Agrif_Parent(jpnj )
222         jpnij = Agrif_Parent(jpnij)
223      ENDIF
224#endif
225
226      IF(jpnij < 1)THEN
227         ! If jpnij is not specified in namelist then we calculate it - this
228         ! means there will be no land cutting out.
229         jpnij = jpni * jpnj
230      END IF
231
232      IF( (jpni < 1) .OR. (jpnj < 1) )THEN
233         WRITE(ldtxt(ii),*) '      jpni, jpnj and jpnij will be calculated automatically'; ii = ii + 1
234      ELSE
235         WRITE(ldtxt(ii),*) '      processor grid extent in i         jpni = ',jpni; ii = ii + 1
236         WRITE(ldtxt(ii),*) '      processor grid extent in j         jpnj = ',jpnj; ii = ii + 1
237         WRITE(ldtxt(ii),*) '      number of local domains           jpnij = ',jpnij; ii = ii +1
238      END IF
239
240      WRITE(ldtxt(ii),*) '      avoid use of mpi_allgather at the north fold  ln_nnogather = ', ln_nnogather  ; ii = ii + 1
241
242      CALL mpi_initialized ( mpi_was_called, code )
243      IF( code /= MPI_SUCCESS ) THEN
244         DO ji = 1, SIZE(ldtxt)
245            IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
246         END DO
247         WRITE(*, cform_err)
248         WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized'
249         CALL mpi_abort( mpi_comm_world, code, ierr )
250      ENDIF
251
252      IF( mpi_was_called ) THEN
253         !
254         SELECT CASE ( cn_mpi_send )
255         CASE ( 'S' )                ! Standard mpi send (blocking)
256            WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'                     ;   ii = ii + 1
257         CASE ( 'B' )                ! Buffer mpi send (blocking)
258            WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'                      ;   ii = ii + 1
259            IF( Agrif_Root() )   CALL mpi_init_opa( ldtxt, ii, ierr )
260         CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
261            WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'                   ;   ii = ii + 1
262            l_isend = .TRUE.
263         CASE DEFAULT
264            WRITE(ldtxt(ii),cform_err)                                                            ;   ii = ii + 1
265            WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send             ;   ii = ii + 1
266            kstop = kstop + 1
267         END SELECT
268      ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN
269         WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator '                  ;   ii = ii + 1
270         WRITE(ldtxt(ii),*) '          without calling MPI_Init before ! '                        ;   ii = ii + 1
271         kstop = kstop + 1
272      ELSE
273         SELECT CASE ( cn_mpi_send )
274         CASE ( 'S' )                ! Standard mpi send (blocking)
275            WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'                     ;   ii = ii + 1
276            CALL mpi_init( ierr )
277         CASE ( 'B' )                ! Buffer mpi send (blocking)
278            WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'                      ;   ii = ii + 1
279            IF( Agrif_Root() )   CALL mpi_init_opa( ldtxt, ii, ierr )
280         CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
281            WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'                   ;   ii = ii + 1
282            l_isend = .TRUE.
283            CALL mpi_init( ierr )
284         CASE DEFAULT
285            WRITE(ldtxt(ii),cform_err)                                                            ;   ii = ii + 1
286            WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send             ;   ii = ii + 1
287            kstop = kstop + 1
288         END SELECT
289         !
290      ENDIF
291
292      IF( PRESENT(localComm) ) THEN
293         IF( Agrif_Root() ) THEN
294            mpi_comm_opa = localComm
295         ENDIF
296      ELSE
297         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code)
298         IF( code /= MPI_SUCCESS ) THEN
299            DO ji = 1, SIZE(ldtxt)
300               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
301            END DO
302            WRITE(*, cform_err)
303            WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
304            CALL mpi_abort( mpi_comm_world, code, ierr )
305         ENDIF
306      ENDIF
307
308      CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr )
309      CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr )
310      mynode = mpprank
311
312      IF( mynode == 0 ) THEN
313         CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )
314         WRITE(kumond, nammpp)     
315      ENDIF
316      !
317      CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr)
318      !
319   END FUNCTION mynode
320
321   SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval )
322      !!----------------------------------------------------------------------
323      !!                  ***  routine mpp_lnk_3d  ***
324      !!
325      !! ** Purpose :   Message passing manadgement
326      !!
327      !! ** Method  :   Use mppsend and mpprecv function for passing mask
328      !!      between processors following neighboring subdomains.
329      !!            domain parameters
330      !!                    nlci   : first dimension of the local subdomain
331      !!                    nlcj   : second dimension of the local subdomain
332      !!                    nbondi : mark for "east-west local boundary"
333      !!                    nbondj : mark for "north-south local boundary"
334      !!                    noea   : number for local neighboring processors
335      !!                    nowe   : number for local neighboring processors
336      !!                    noso   : number for local neighboring processors
337      !!                    nono   : number for local neighboring processors
338      !!
339      !! ** Action  :   ptab with update value at its periphery
340      !!
341      !!----------------------------------------------------------------------
342      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
343      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
344      !                                                             ! = T , U , V , F , W points
345      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
346      !                                                             ! =  1. , the sign is kept
347      CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
348      REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
349      !!
350      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices
351      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
352      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
353      REAL(wp) ::   zland
354      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
355      !
356      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north
357      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east
358
359      !!----------------------------------------------------------------------
360     
361      ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   &
362         &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  )
363
364      !
365      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
366      ELSE                         ;   zland = 0.e0      ! zero by default
367      ENDIF
368
369      ! 1. standard boundary treatment
370      ! ------------------------------
371      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values
372         !
373         ! WARNING ptab is defined only between nld and nle
374         DO jk = 1, jpk
375            DO jj = nlcj+1, jpj                 ! added line(s)   (inner only)
376               ptab(nldi  :nlei  , jj          ,jk) = ptab(nldi:nlei,     nlej,jk)
377               ptab(1     :nldi-1, jj          ,jk) = ptab(nldi     ,     nlej,jk)
378               ptab(nlei+1:nlci  , jj          ,jk) = ptab(     nlei,     nlej,jk)
379            END DO
380            DO ji = nlci+1, jpi                 ! added column(s) (full)
381               ptab(ji           ,nldj  :nlej  ,jk) = ptab(     nlei,nldj:nlej,jk)
382               ptab(ji           ,1     :nldj-1,jk) = ptab(     nlei,nldj     ,jk)
383               ptab(ji           ,nlej+1:jpj   ,jk) = ptab(     nlei,     nlej,jk)
384            END DO
385         END DO
386         !
387      ELSE                              ! standard close or cyclic treatment
388         !
389         !                                   ! East-West boundaries
390         !                                        !* Cyclic east-west
391         IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
392            ptab( 1 ,:,:) = ptab(jpim1,:,:)
393            ptab(jpi,:,:) = ptab(  2  ,:,:)
394         ELSE                                     !* closed
395            IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point
396                                         ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north
397         ENDIF
398         !                                   ! North-South boundaries (always closed)
399         IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point
400                                      ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north
401         !
402      ENDIF
403
404      ! 2. East and west directions exchange
405      ! ------------------------------------
406      ! we play with the neigbours AND the row number because of the periodicity
407      !
408      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
409      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
410         iihom = nlci-nreci
411         DO jl = 1, jpreci
412            zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
413            zt3we(:,jl,:,1) = ptab(iihom +jl,:,:)
414         END DO
415      END SELECT
416      !
417      !                           ! Migrations
418      imigr = jpreci * jpj * jpk
419      !
420      SELECT CASE ( nbondi )
421      CASE ( -1 )
422         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 )
423         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
424         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
425      CASE ( 0 )
426         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
427         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 )
428         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
429         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
430         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
431         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
432      CASE ( 1 )
433         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
434         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
435         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
436      END SELECT
437      !
438      !                           ! Write Dirichlet lateral conditions
439      iihom = nlci-jpreci
440      !
441      SELECT CASE ( nbondi )
442      CASE ( -1 )
443         DO jl = 1, jpreci
444            ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
445         END DO
446      CASE ( 0 )
447         DO jl = 1, jpreci
448            ptab(jl      ,:,:) = zt3we(:,jl,:,2)
449            ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
450         END DO
451      CASE ( 1 )
452         DO jl = 1, jpreci
453            ptab(jl      ,:,:) = zt3we(:,jl,:,2)
454         END DO
455      END SELECT
456
457
458      ! 3. North and south directions
459      ! -----------------------------
460      ! always closed : we play only with the neigbours
461      !
462      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
463         ijhom = nlcj-nrecj
464         DO jl = 1, jprecj
465            zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
466            zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
467         END DO
468      ENDIF
469      !
470      !                           ! Migrations
471      imigr = jprecj * jpi * jpk
472      !
473      SELECT CASE ( nbondj )
474      CASE ( -1 )
475         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 )
476         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
477         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
478      CASE ( 0 )
479         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
480         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 )
481         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
482         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
483         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
484         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
485      CASE ( 1 )
486         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
487         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
488         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
489      END SELECT
490      !
491      !                           ! Write Dirichlet lateral conditions
492      ijhom = nlcj-jprecj
493      !
494      SELECT CASE ( nbondj )
495      CASE ( -1 )
496         DO jl = 1, jprecj
497            ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
498         END DO
499      CASE ( 0 )
500         DO jl = 1, jprecj
501            ptab(:,jl      ,:) = zt3sn(:,jl,:,2)
502            ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
503         END DO
504      CASE ( 1 )
505         DO jl = 1, jprecj
506            ptab(:,jl,:) = zt3sn(:,jl,:,2)
507         END DO
508      END SELECT
509
510
511      ! 4. north fold treatment
512      ! -----------------------
513      !
514      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
515         !
516         SELECT CASE ( jpni )
517         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
518         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
519         END SELECT
520         !
521      ENDIF
522      !
523      DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we )
524      !
525   END SUBROUTINE mpp_lnk_3d
526
527   SUBROUTINE mpp_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields , cd_mpp, pval )
528      !!----------------------------------------------------------------------
529      !!                  ***  routine mpp_lnk_2d_multiple  ***
530      !!
531      !! ** Purpose :   Message passing management for multiple 2d arrays
532      !!
533      !! ** Method  :   Use mppsend and mpprecv function for passing mask
534      !!      between processors following neighboring subdomains.
535      !!            domain parameters
536      !!                    nlci   : first dimension of the local subdomain
537      !!                    nlcj   : second dimension of the local subdomain
538      !!                    nbondi : mark for "east-west local boundary"
539      !!                    nbondj : mark for "north-south local boundary"
540      !!                    noea   : number for local neighboring processors
541      !!                    nowe   : number for local neighboring processors
542      !!                    noso   : number for local neighboring processors
543      !!                    nono   : number for local neighboring processors
544      !!
545      !!----------------------------------------------------------------------
546
547      INTEGER :: num_fields
548      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array
549      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points
550      !                                                               ! = T , U , V , F , W and I points
551      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary
552      !                                                               ! =  1. , the sign is kept
553      CHARACTER(len=3), OPTIONAL    , INTENT(in   ) ::   cd_mpp       ! fill the overlap area only
554      REAL(wp)        , OPTIONAL    , INTENT(in   ) ::   pval         ! background value (used at closed boundaries)
555      !!
556      INTEGER  ::   ji, jj, jl   ! dummy loop indices
557      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES
558      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
559      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
560
561      REAL(wp) ::   zland
562      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
563      !
564      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north
565      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east
566
567      !!----------------------------------------------------------------------
568
569      ALLOCATE( zt2ns(jpi,jprecj,2*num_fields), zt2sn(jpi,jprecj,2*num_fields),  &
570         &      zt2ew(jpj,jpreci,2*num_fields), zt2we(jpj,jpreci,2*num_fields)   )
571
572      !
573      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
574      ELSE                         ;   zland = 0.e0      ! zero by default
575      ENDIF
576
577      ! 1. standard boundary treatment
578      ! ------------------------------
579      !
580      !First Array
581      DO ii = 1 , num_fields
582         IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values
583            !
584            ! WARNING pt2d is defined only between nld and nle
585            DO jj = nlcj+1, jpj                 ! added line(s)   (inner only)
586               pt2d_array(ii)%pt2d(nldi  :nlei  , jj) = pt2d_array(ii)%pt2d(nldi:nlei, nlej)
587               pt2d_array(ii)%pt2d(1     :nldi-1, jj) = pt2d_array(ii)%pt2d(nldi     , nlej)
588               pt2d_array(ii)%pt2d(nlei+1:nlci  , jj) = pt2d_array(ii)%pt2d(     nlei, nlej) 
589            END DO
590            DO ji = nlci+1, jpi                 ! added column(s) (full)
591               pt2d_array(ii)%pt2d(ji, nldj  :nlej  ) = pt2d_array(ii)%pt2d(nlei, nldj:nlej)
592               pt2d_array(ii)%pt2d(ji, 1     :nldj-1) = pt2d_array(ii)%pt2d(nlei, nldj     )
593               pt2d_array(ii)%pt2d(ji, nlej+1:jpj   ) = pt2d_array(ii)%pt2d(nlei,      nlej)
594            END DO
595            !
596         ELSE                              ! standard close or cyclic treatment
597            !
598            !                                   ! East-West boundaries
599            IF( nbondi == 2 .AND.   &                ! Cyclic east-west
600               &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
601               pt2d_array(ii)%pt2d(  1  , : ) = pt2d_array(ii)%pt2d( jpim1, : )                                    ! west
602               pt2d_array(ii)%pt2d( jpi , : ) = pt2d_array(ii)%pt2d(   2  , : )                                    ! east
603            ELSE                                     ! closed
604               IF( .NOT. type_array(ii) == 'F' )   pt2d_array(ii)%pt2d(            1 : jpreci,:) = zland    ! south except F-point
605                                                   pt2d_array(ii)%pt2d(nlci-jpreci+1 : jpi   ,:) = zland    ! north
606            ENDIF
607            !                                   ! North-South boundaries (always closed)
608               IF( .NOT. type_array(ii) == 'F' )   pt2d_array(ii)%pt2d(:,             1:jprecj ) = zland    ! south except F-point
609                                                   pt2d_array(ii)%pt2d(:, nlcj-jprecj+1:jpj    ) = zland    ! north
610            !
611         ENDIF
612      END DO
613
614      ! 2. East and west directions exchange
615      ! ------------------------------------
616      ! we play with the neigbours AND the row number because of the periodicity
617      !
618      DO ii = 1 , num_fields
619         SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
620         CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
621            iihom = nlci-nreci
622            DO jl = 1, jpreci
623               zt2ew( : , jl , ii ) = pt2d_array(ii)%pt2d( jpreci+jl , : )
624               zt2we( : , jl , ii ) = pt2d_array(ii)%pt2d( iihom +jl , : )
625            END DO
626         END SELECT
627      END DO
628      !
629      !                           ! Migrations
630      imigr = jpreci * jpj
631      !
632      SELECT CASE ( nbondi )
633      CASE ( -1 )
634         CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req1 )
635         CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea )
636         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
637      CASE ( 0 )
638         CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 )
639         CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req2 )
640         CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea )
641         CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe )
642         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
643         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
644      CASE ( 1 )
645         CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 )
646         CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe )
647         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
648      END SELECT
649      !
650      !                           ! Write Dirichlet lateral conditions
651      iihom = nlci - jpreci
652      !
653
654      DO ii = 1 , num_fields
655         SELECT CASE ( nbondi )
656         CASE ( -1 )
657            DO jl = 1, jpreci
658               pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii)
659            END DO
660         CASE ( 0 )
661            DO jl = 1, jpreci
662               pt2d_array(ii)%pt2d( jl , : ) = zt2we(:,jl,num_fields+ii)
663               pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii)
664            END DO
665         CASE ( 1 )
666            DO jl = 1, jpreci
667               pt2d_array(ii)%pt2d( jl , : )= zt2we(:,jl,num_fields+ii)
668            END DO
669         END SELECT
670      END DO
671     
672      ! 3. North and south directions
673      ! -----------------------------
674      ! always closed : we play only with the neigbours
675      !
676      !First Array
677      DO ii = 1 , num_fields
678         IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
679            ijhom = nlcj-nrecj
680            DO jl = 1, jprecj
681               zt2sn(:,jl , ii) = pt2d_array(ii)%pt2d( : , ijhom +jl )
682               zt2ns(:,jl , ii) = pt2d_array(ii)%pt2d( : , jprecj+jl )
683            END DO
684         ENDIF
685      END DO
686      !
687      !                           ! Migrations
688      imigr = jprecj * jpi
689      !
690      SELECT CASE ( nbondj )
691      CASE ( -1 )
692         CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req1 )
693         CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono )
694         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
695      CASE ( 0 )
696         CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 )
697         CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req2 )
698         CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono )
699         CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso )
700         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
701         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
702      CASE ( 1 )
703         CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 )
704         CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso )
705         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
706      END SELECT
707      !
708      !                           ! Write Dirichlet lateral conditions
709      ijhom = nlcj - jprecj
710      !
711
712      DO ii = 1 , num_fields
713         !First Array
714         SELECT CASE ( nbondj )
715         CASE ( -1 )
716            DO jl = 1, jprecj
717               pt2d_array(ii)%pt2d( : , ijhom+jl ) = zt2ns( : , jl , num_fields+ii )
718            END DO
719         CASE ( 0 )
720            DO jl = 1, jprecj
721               pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii)
722               pt2d_array(ii)%pt2d( : , ijhom + jl ) = zt2ns( : , jl , num_fields + ii )
723            END DO
724         CASE ( 1 )
725            DO jl = 1, jprecj
726               pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii )
727            END DO
728         END SELECT
729      END DO
730     
731      ! 4. north fold treatment
732      ! -----------------------
733      !
734         !First Array
735      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
736         !
737         SELECT CASE ( jpni )
738         CASE ( 1 )     ;   
739             DO ii = 1 , num_fields 
740                       CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp
741             END DO
742         CASE DEFAULT   ;   CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields )   ! for all northern procs.
743         END SELECT
744         !
745      ENDIF
746        !
747     
748      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we )
749      !
750   END SUBROUTINE mpp_lnk_2d_multiple
751
752   
753   SUBROUTINE load_array(pt2d,cd_type,psgn,pt2d_array, type_array, psgn_array,num_fields)
754      !!---------------------------------------------------------------------
755      REAL(wp), DIMENSION(jpi,jpj), TARGET   ,   INTENT(inout) ::   pt2d    ! Second 2D array on which the boundary condition is applied
756      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type ! define the nature of ptab array grid-points
757      REAL(wp)                    , INTENT(in   ) ::   psgn    ! =-1 the sign change across the north fold boundary
758      TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array
759      CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of ptab array grid-points
760      REAL(wp)         , DIMENSION(9) ::   psgn_array    ! =-1 the sign change across the north fold boundary
761      INTEGER                      , INTENT (inout):: num_fields 
762      !!---------------------------------------------------------------------
763      num_fields=num_fields+1
764      pt2d_array(num_fields)%pt2d=>pt2d
765      type_array(num_fields)=cd_type
766      psgn_array(num_fields)=psgn
767   END SUBROUTINE load_array
768   
769   
770   SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   &
771      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   &
772      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval)
773      !!---------------------------------------------------------------------
774      ! Second 2D array on which the boundary condition is applied
775      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA   
776      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE
777      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
778      ! define the nature of ptab array grid-points
779      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA
780      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE
781      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI
782      ! =-1 the sign change across the north fold boundary
783      REAL(wp)                                      , INTENT(in   ) ::   psgnA   
784      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE
785      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI   
786      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
787      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
788      !!
789      TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array 
790      CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of ptab array grid-points
791      !                                                         ! = T , U , V , F , W and I points
792      REAL(wp)         , DIMENSION(9) ::   psgn_array    ! =-1 the sign change across the north fold boundary
793      INTEGER :: num_fields
794      !!---------------------------------------------------------------------
795
796      num_fields = 0
797
798      !! Load the first array
799      CALL load_array(pt2dA,cd_typeA,psgnA,pt2d_array, type_array, psgn_array,num_fields)
800
801      !! Look if more arrays are added
802      IF(PRESENT (psgnB) )CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields)
803      IF(PRESENT (psgnC) )CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields)
804      IF(PRESENT (psgnD) )CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields)
805      IF(PRESENT (psgnE) )CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields)
806      IF(PRESENT (psgnF) )CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields)
807      IF(PRESENT (psgnG) )CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields)
808      IF(PRESENT (psgnH) )CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields)
809      IF(PRESENT (psgnI) )CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields)
810     
811      CALL mpp_lnk_2d_multiple(pt2d_array,type_array,psgn_array,num_fields,cd_mpp,pval)
812   END SUBROUTINE mpp_lnk_2d_9
813
814
815   SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
816      !!----------------------------------------------------------------------
817      !!                  ***  routine mpp_lnk_2d  ***
818      !!
819      !! ** Purpose :   Message passing manadgement for 2d array
820      !!
821      !! ** Method  :   Use mppsend and mpprecv function for passing mask
822      !!      between processors following neighboring subdomains.
823      !!            domain parameters
824      !!                    nlci   : first dimension of the local subdomain
825      !!                    nlcj   : second dimension of the local subdomain
826      !!                    nbondi : mark for "east-west local boundary"
827      !!                    nbondj : mark for "north-south local boundary"
828      !!                    noea   : number for local neighboring processors
829      !!                    nowe   : number for local neighboring processors
830      !!                    noso   : number for local neighboring processors
831      !!                    nono   : number for local neighboring processors
832      !!
833      !!----------------------------------------------------------------------
834      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied
835      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
836      !                                                         ! = T , U , V , F , W and I points
837      REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
838      !                                                         ! =  1. , the sign is kept
839      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
840      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
841      !!
842      INTEGER  ::   ji, jj, jl   ! dummy loop indices
843      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
844      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
845      REAL(wp) ::   zland
846      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
847      !
848      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north
849      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east
850
851      !!----------------------------------------------------------------------
852
853      ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  &
854         &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   )
855
856      !
857      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
858      ELSE                         ;   zland = 0.e0      ! zero by default
859      ENDIF
860
861      ! 1. standard boundary treatment
862      ! ------------------------------
863      !
864      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values
865         !
866         ! WARNING pt2d is defined only between nld and nle
867         DO jj = nlcj+1, jpj                 ! added line(s)   (inner only)
868            pt2d(nldi  :nlei  , jj          ) = pt2d(nldi:nlei,     nlej)
869            pt2d(1     :nldi-1, jj          ) = pt2d(nldi     ,     nlej)
870            pt2d(nlei+1:nlci  , jj          ) = pt2d(     nlei,     nlej)
871         END DO
872         DO ji = nlci+1, jpi                 ! added column(s) (full)
873            pt2d(ji           ,nldj  :nlej  ) = pt2d(     nlei,nldj:nlej)
874            pt2d(ji           ,1     :nldj-1) = pt2d(     nlei,nldj     )
875            pt2d(ji           ,nlej+1:jpj   ) = pt2d(     nlei,     nlej)
876         END DO
877         !
878      ELSE                              ! standard close or cyclic treatment
879         !
880         !                                   ! East-West boundaries
881         IF( nbondi == 2 .AND.   &                ! Cyclic east-west
882            &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
883            pt2d( 1 ,:) = pt2d(jpim1,:)                                    ! west
884            pt2d(jpi,:) = pt2d(  2  ,:)                                    ! east
885         ELSE                                     ! closed
886            IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point
887                                         pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north
888         ENDIF
889         !                                   ! North-South boundaries (always closed)
890            IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland    !south except F-point
891                                         pt2d(:,nlcj-jprecj+1:jpj   ) = zland    ! north
892         !
893      ENDIF
894
895      ! 2. East and west directions exchange
896      ! ------------------------------------
897      ! we play with the neigbours AND the row number because of the periodicity
898      !
899      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
900      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
901         iihom = nlci-nreci
902         DO jl = 1, jpreci
903            zt2ew(:,jl,1) = pt2d(jpreci+jl,:)
904            zt2we(:,jl,1) = pt2d(iihom +jl,:)
905         END DO
906      END SELECT
907      !
908      !                           ! Migrations
909      imigr = jpreci * jpj
910      !
911      SELECT CASE ( nbondi )
912      CASE ( -1 )
913         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )
914         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
915         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
916      CASE ( 0 )
917         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
918         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )
919         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
920         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
921         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
922         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
923      CASE ( 1 )
924         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
925         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
926         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
927      END SELECT
928      !
929      !                           ! Write Dirichlet lateral conditions
930      iihom = nlci - jpreci
931      !
932      SELECT CASE ( nbondi )
933      CASE ( -1 )
934         DO jl = 1, jpreci
935            pt2d(iihom+jl,:) = zt2ew(:,jl,2)
936         END DO
937      CASE ( 0 )
938         DO jl = 1, jpreci
939            pt2d(jl      ,:) = zt2we(:,jl,2)
940            pt2d(iihom+jl,:) = zt2ew(:,jl,2)
941         END DO
942      CASE ( 1 )
943         DO jl = 1, jpreci
944            pt2d(jl      ,:) = zt2we(:,jl,2)
945         END DO
946      END SELECT
947
948
949      ! 3. North and south directions
950      ! -----------------------------
951      ! always closed : we play only with the neigbours
952      !
953      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
954         ijhom = nlcj-nrecj
955         DO jl = 1, jprecj
956            zt2sn(:,jl,1) = pt2d(:,ijhom +jl)
957            zt2ns(:,jl,1) = pt2d(:,jprecj+jl)
958         END DO
959      ENDIF
960      !
961      !                           ! Migrations
962      imigr = jprecj * jpi
963      !
964      SELECT CASE ( nbondj )
965      CASE ( -1 )
966         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )
967         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
968         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
969      CASE ( 0 )
970         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
971         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )
972         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
973         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
974         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
975         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
976      CASE ( 1 )
977         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
978         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
979         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
980      END SELECT
981      !
982      !                           ! Write Dirichlet lateral conditions
983      ijhom = nlcj - jprecj
984      !
985      SELECT CASE ( nbondj )
986      CASE ( -1 )
987         DO jl = 1, jprecj
988            pt2d(:,ijhom+jl) = zt2ns(:,jl,2)
989         END DO
990      CASE ( 0 )
991         DO jl = 1, jprecj
992            pt2d(:,jl      ) = zt2sn(:,jl,2)
993            pt2d(:,ijhom+jl) = zt2ns(:,jl,2)
994         END DO
995      CASE ( 1 )
996         DO jl = 1, jprecj
997            pt2d(:,jl      ) = zt2sn(:,jl,2)
998         END DO
999      END SELECT
1000
1001
1002      ! 4. north fold treatment
1003      ! -----------------------
1004      !
1005      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
1006         !
1007         SELECT CASE ( jpni )
1008         CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp
1009         CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs.
1010         END SELECT
1011         !
1012      ENDIF
1013      !
1014      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we )
1015      !
1016   END SUBROUTINE mpp_lnk_2d
1017
1018
1019   SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn )
1020      !!----------------------------------------------------------------------
1021      !!                  ***  routine mpp_lnk_3d_gather  ***
1022      !!
1023      !! ** Purpose :   Message passing manadgement for two 3D arrays
1024      !!
1025      !! ** Method  :   Use mppsend and mpprecv function for passing mask
1026      !!      between processors following neighboring subdomains.
1027      !!            domain parameters
1028      !!                    nlci   : first dimension of the local subdomain
1029      !!                    nlcj   : second dimension of the local subdomain
1030      !!                    nbondi : mark for "east-west local boundary"
1031      !!                    nbondj : mark for "north-south local boundary"
1032      !!                    noea   : number for local neighboring processors
1033      !!                    nowe   : number for local neighboring processors
1034      !!                    noso   : number for local neighboring processors
1035      !!                    nono   : number for local neighboring processors
1036      !!
1037      !! ** Action  :   ptab1 and ptab2  with update value at its periphery
1038      !!
1039      !!----------------------------------------------------------------------
1040      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab1     ! first and second 3D array on which
1041      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab2     ! the boundary condition is applied
1042      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1  ! nature of ptab1 and ptab2 arrays
1043      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type2  ! i.e. grid-points = T , U , V , F or W points
1044      REAL(wp)                        , INTENT(in   ) ::   psgn      ! =-1 the sign change across the north fold boundary
1045      !!                                                             ! =  1. , the sign is kept
1046      INTEGER  ::   jl   ! dummy loop indices
1047      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
1048      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
1049      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
1050      !
1051      REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zt4ns, zt4sn   ! 2 x 3d for north-south & south-north
1052      REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zt4ew, zt4we   ! 2 x 3d for east-west & west-east
1053
1054      !!----------------------------------------------------------------------
1055      ALLOCATE( zt4ns(jpi,jprecj,jpk,2,2), zt4sn(jpi,jprecj,jpk,2,2) ,    &
1056         &      zt4ew(jpj,jpreci,jpk,2,2), zt4we(jpj,jpreci,jpk,2,2) )
1057
1058
1059      ! 1. standard boundary treatment
1060      ! ------------------------------
1061      !                                      ! East-West boundaries
1062      !                                           !* Cyclic east-west
1063      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
1064         ptab1( 1 ,:,:) = ptab1(jpim1,:,:)
1065         ptab1(jpi,:,:) = ptab1(  2  ,:,:)
1066         ptab2( 1 ,:,:) = ptab2(jpim1,:,:)
1067         ptab2(jpi,:,:) = ptab2(  2  ,:,:)
1068      ELSE                                        !* closed
1069         IF( .NOT. cd_type1 == 'F' )   ptab1(     1       :jpreci,:,:) = 0.e0    ! south except at F-point
1070         IF( .NOT. cd_type2 == 'F' )   ptab2(     1       :jpreci,:,:) = 0.e0
1071                                       ptab1(nlci-jpreci+1:jpi   ,:,:) = 0.e0    ! north
1072                                       ptab2(nlci-jpreci+1:jpi   ,:,:) = 0.e0
1073      ENDIF
1074
1075
1076      !                                      ! North-South boundaries
1077      IF( .NOT. cd_type1 == 'F' )   ptab1(:,     1       :jprecj,:) = 0.e0    ! south except at F-point
1078      IF( .NOT. cd_type2 == 'F' )   ptab2(:,     1       :jprecj,:) = 0.e0
1079                                    ptab1(:,nlcj-jprecj+1:jpj   ,:) = 0.e0    ! north
1080                                    ptab2(:,nlcj-jprecj+1:jpj   ,:) = 0.e0
1081
1082
1083      ! 2. East and west directions exchange
1084      ! ------------------------------------
1085      ! we play with the neigbours AND the row number because of the periodicity
1086      !
1087      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
1088      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
1089         iihom = nlci-nreci
1090         DO jl = 1, jpreci
1091            zt4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:)
1092            zt4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:)
1093            zt4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:)
1094            zt4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:)
1095         END DO
1096      END SELECT
1097      !
1098      !                           ! Migrations
1099      imigr = jpreci * jpj * jpk *2
1100      !
1101      SELECT CASE ( nbondi )
1102      CASE ( -1 )
1103         CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req1 )
1104         CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea )
1105         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1106      CASE ( 0 )
1107         CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
1108         CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req2 )
1109         CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea )
1110         CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe )
1111         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1112         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
1113      CASE ( 1 )
1114         CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
1115         CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe )
1116         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1117      END SELECT
1118      !
1119      !                           ! Write Dirichlet lateral conditions
1120      iihom = nlci - jpreci
1121      !
1122      SELECT CASE ( nbondi )
1123      CASE ( -1 )
1124         DO jl = 1, jpreci
1125            ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2)
1126            ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2)
1127         END DO
1128      CASE ( 0 )
1129         DO jl = 1, jpreci
1130            ptab1(jl      ,:,:) = zt4we(:,jl,:,1,2)
1131            ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2)
1132            ptab2(jl      ,:,:) = zt4we(:,jl,:,2,2)
1133            ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2)
1134         END DO
1135      CASE ( 1 )
1136         DO jl = 1, jpreci
1137            ptab1(jl      ,:,:) = zt4we(:,jl,:,1,2)
1138            ptab2(jl      ,:,:) = zt4we(:,jl,:,2,2)
1139         END DO
1140      END SELECT
1141
1142
1143      ! 3. North and south directions
1144      ! -----------------------------
1145      ! always closed : we play only with the neigbours
1146      !
1147      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
1148         ijhom = nlcj - nrecj
1149         DO jl = 1, jprecj
1150            zt4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:)
1151            zt4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:)
1152            zt4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:)
1153            zt4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:)
1154         END DO
1155      ENDIF
1156      !
1157      !                           ! Migrations
1158      imigr = jprecj * jpi * jpk * 2
1159      !
1160      SELECT CASE ( nbondj )
1161      CASE ( -1 )
1162         CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req1 )
1163         CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono )
1164         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1165      CASE ( 0 )
1166         CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 )
1167         CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req2 )
1168         CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono )
1169         CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso )
1170         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1171         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
1172      CASE ( 1 )
1173         CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 )
1174         CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso )
1175         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1176      END SELECT
1177      !
1178      !                           ! Write Dirichlet lateral conditions
1179      ijhom = nlcj - jprecj
1180      !
1181      SELECT CASE ( nbondj )
1182      CASE ( -1 )
1183         DO jl = 1, jprecj
1184            ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2)
1185            ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2)
1186         END DO
1187      CASE ( 0 )
1188         DO jl = 1, jprecj
1189            ptab1(:,jl      ,:) = zt4sn(:,jl,:,1,2)
1190            ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2)
1191            ptab2(:,jl      ,:) = zt4sn(:,jl,:,2,2)
1192            ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2)
1193         END DO
1194      CASE ( 1 )
1195         DO jl = 1, jprecj
1196            ptab1(:,jl,:) = zt4sn(:,jl,:,1,2)
1197            ptab2(:,jl,:) = zt4sn(:,jl,:,2,2)
1198         END DO
1199      END SELECT
1200
1201
1202      ! 4. north fold treatment
1203      ! -----------------------
1204      IF( npolj /= 0 ) THEN
1205         !
1206         SELECT CASE ( jpni )
1207         CASE ( 1 )
1208            CALL lbc_nfd      ( ptab1, cd_type1, psgn )   ! only for northern procs.
1209            CALL lbc_nfd      ( ptab2, cd_type2, psgn )
1210         CASE DEFAULT
1211            CALL mpp_lbc_north( ptab1, cd_type1, psgn )   ! for all northern procs.
1212            CALL mpp_lbc_north (ptab2, cd_type2, psgn)
1213         END SELECT
1214         !
1215      ENDIF
1216      !
1217      DEALLOCATE( zt4ns, zt4sn, zt4ew, zt4we )
1218      !
1219   END SUBROUTINE mpp_lnk_3d_gather
1220
1221
1222   SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj )
1223      !!----------------------------------------------------------------------
1224      !!                  ***  routine mpp_lnk_2d_e  ***
1225      !!
1226      !! ** Purpose :   Message passing manadgement for 2d array (with halo)
1227      !!
1228      !! ** Method  :   Use mppsend and mpprecv function for passing mask
1229      !!      between processors following neighboring subdomains.
1230      !!            domain parameters
1231      !!                    nlci   : first dimension of the local subdomain
1232      !!                    nlcj   : second dimension of the local subdomain
1233      !!                    jpri   : number of rows for extra outer halo
1234      !!                    jprj   : number of columns for extra outer halo
1235      !!                    nbondi : mark for "east-west local boundary"
1236      !!                    nbondj : mark for "north-south local boundary"
1237      !!                    noea   : number for local neighboring processors
1238      !!                    nowe   : number for local neighboring processors
1239      !!                    noso   : number for local neighboring processors
1240      !!                    nono   : number for local neighboring processors
1241      !!
1242      !!----------------------------------------------------------------------
1243      INTEGER                                             , INTENT(in   ) ::   jpri
1244      INTEGER                                             , INTENT(in   ) ::   jprj
1245      REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
1246      CHARACTER(len=1)                                    , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points
1247      !                                                                                 ! = T , U , V , F , W and I points
1248      REAL(wp)                                            , INTENT(in   ) ::   psgn     ! =-1 the sign change across the
1249      !!                                                                                ! north boundary, =  1. otherwise
1250      INTEGER  ::   jl   ! dummy loop indices
1251      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
1252      INTEGER  ::   ipreci, iprecj             ! temporary integers
1253      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
1254      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
1255      !!
1256      REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns
1257      REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn
1258      REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe
1259      REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew
1260      !!----------------------------------------------------------------------
1261
1262      ipreci = jpreci + jpri      ! take into account outer extra 2D overlap area
1263      iprecj = jprecj + jprj
1264
1265
1266      ! 1. standard boundary treatment
1267      ! ------------------------------
1268      ! Order matters Here !!!!
1269      !
1270      !                                      !* North-South boundaries (always colsed)
1271      IF( .NOT. cd_type == 'F' )   pt2d(:,  1-jprj   :  jprecj  ) = 0.e0    ! south except at F-point
1272                                   pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0.e0    ! north
1273
1274      !                                      ! East-West boundaries
1275      !                                           !* Cyclic east-west
1276      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
1277         pt2d(1-jpri:     1    ,:) = pt2d(jpim1-jpri:  jpim1 ,:)       ! east
1278         pt2d(   jpi  :jpi+jpri,:) = pt2d(     2      :2+jpri,:)       ! west
1279         !
1280      ELSE                                        !* closed
1281         IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0.e0    ! south except at F-point
1282                                      pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0    ! north
1283      ENDIF
1284      !
1285
1286      ! north fold treatment
1287      ! -----------------------
1288      IF( npolj /= 0 ) THEN
1289         !
1290         SELECT CASE ( jpni )
1291         CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )
1292         CASE DEFAULT   ;   CALL mpp_lbc_north_e( pt2d                    , cd_type, psgn               )
1293         END SELECT
1294         !
1295      ENDIF
1296
1297      ! 2. East and west directions exchange
1298      ! ------------------------------------
1299      ! we play with the neigbours AND the row number because of the periodicity
1300      !
1301      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
1302      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
1303         iihom = nlci-nreci-jpri
1304         DO jl = 1, ipreci
1305            r2dew(:,jl,1) = pt2d(jpreci+jl,:)
1306            r2dwe(:,jl,1) = pt2d(iihom +jl,:)
1307         END DO
1308      END SELECT
1309      !
1310      !                           ! Migrations
1311      imigr = ipreci * ( jpj + 2*jprj)
1312      !
1313      SELECT CASE ( nbondi )
1314      CASE ( -1 )
1315         CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 )
1316         CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
1317         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1318      CASE ( 0 )
1319         CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
1320         CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 )
1321         CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
1322         CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
1323         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1324         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1325      CASE ( 1 )
1326         CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
1327         CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
1328         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1329      END SELECT
1330      !
1331      !                           ! Write Dirichlet lateral conditions
1332      iihom = nlci - jpreci
1333      !
1334      SELECT CASE ( nbondi )
1335      CASE ( -1 )
1336         DO jl = 1, ipreci
1337            pt2d(iihom+jl,:) = r2dew(:,jl,2)
1338         END DO
1339      CASE ( 0 )
1340         DO jl = 1, ipreci
1341            pt2d(jl-jpri,:) = r2dwe(:,jl,2)
1342            pt2d( iihom+jl,:) = r2dew(:,jl,2)
1343         END DO
1344      CASE ( 1 )
1345         DO jl = 1, ipreci
1346            pt2d(jl-jpri,:) = r2dwe(:,jl,2)
1347         END DO
1348      END SELECT
1349
1350
1351      ! 3. North and south directions
1352      ! -----------------------------
1353      ! always closed : we play only with the neigbours
1354      !
1355      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
1356         ijhom = nlcj-nrecj-jprj
1357         DO jl = 1, iprecj
1358            r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
1359            r2dns(:,jl,1) = pt2d(:,jprecj+jl)
1360         END DO
1361      ENDIF
1362      !
1363      !                           ! Migrations
1364      imigr = iprecj * ( jpi + 2*jpri )
1365      !
1366      SELECT CASE ( nbondj )
1367      CASE ( -1 )
1368         CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 )
1369         CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
1370         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1371      CASE ( 0 )
1372         CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
1373         CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 )
1374         CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
1375         CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
1376         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1377         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1378      CASE ( 1 )
1379         CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
1380         CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
1381         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1382      END SELECT
1383      !
1384      !                           ! Write Dirichlet lateral conditions
1385      ijhom = nlcj - jprecj
1386      !
1387      SELECT CASE ( nbondj )
1388      CASE ( -1 )
1389         DO jl = 1, iprecj
1390            pt2d(:,ijhom+jl) = r2dns(:,jl,2)
1391         END DO
1392      CASE ( 0 )
1393         DO jl = 1, iprecj
1394            pt2d(:,jl-jprj) = r2dsn(:,jl,2)
1395            pt2d(:,ijhom+jl ) = r2dns(:,jl,2)
1396         END DO
1397      CASE ( 1 )
1398         DO jl = 1, iprecj
1399            pt2d(:,jl-jprj) = r2dsn(:,jl,2)
1400         END DO
1401      END SELECT
1402
1403   END SUBROUTINE mpp_lnk_2d_e
1404
1405
1406   SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
1407      !!----------------------------------------------------------------------
1408      !!                  ***  routine mppsend  ***
1409      !!
1410      !! ** Purpose :   Send messag passing array
1411      !!
1412      !!----------------------------------------------------------------------
1413      REAL(wp), INTENT(inout) ::   pmess(*)   ! array of real
1414      INTEGER , INTENT(in   ) ::   kbytes     ! size of the array pmess
1415      INTEGER , INTENT(in   ) ::   kdest      ! receive process number
1416      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message
1417      INTEGER , INTENT(in   ) ::   md_req     ! argument for isend
1418      !!
1419      INTEGER ::   iflag
1420      !!----------------------------------------------------------------------
1421      !
1422      SELECT CASE ( cn_mpi_send )
1423      CASE ( 'S' )                ! Standard mpi send (blocking)
1424         CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa        , iflag )
1425      CASE ( 'B' )                ! Buffer mpi send (blocking)
1426         CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa        , iflag )
1427      CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
1428         ! be carefull, one more argument here : the mpi request identifier..
1429         CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa, md_req, iflag )
1430      END SELECT
1431      !
1432   END SUBROUTINE mppsend
1433
1434
1435   SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource )
1436      !!----------------------------------------------------------------------
1437      !!                  ***  routine mpprecv  ***
1438      !!
1439      !! ** Purpose :   Receive messag passing array
1440      !!
1441      !!----------------------------------------------------------------------
1442      REAL(wp), INTENT(inout) ::   pmess(*)   ! array of real
1443      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess
1444      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message
1445      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number
1446      !!
1447      INTEGER :: istatus(mpi_status_size)
1448      INTEGER :: iflag
1449      INTEGER :: use_source
1450      !!----------------------------------------------------------------------
1451      !
1452
1453      ! If a specific process number has been passed to the receive call,
1454      ! use that one. Default is to use mpi_any_source
1455      use_source=mpi_any_source
1456      if(present(ksource)) then
1457         use_source=ksource
1458      end if
1459
1460      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_opa, istatus, iflag )
1461      !
1462   END SUBROUTINE mpprecv
1463
1464
1465   SUBROUTINE mppgather( ptab, kp, pio )
1466      !!----------------------------------------------------------------------
1467      !!                   ***  routine mppgather  ***
1468      !!
1469      !! ** Purpose :   Transfert between a local subdomain array and a work
1470      !!     array which is distributed following the vertical level.
1471      !!
1472      !!----------------------------------------------------------------------
1473      REAL(wp), DIMENSION(jpi,jpj),       INTENT(in   ) ::   ptab   ! subdomain input array
1474      INTEGER ,                           INTENT(in   ) ::   kp     ! record length
1475      REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT(  out) ::   pio    ! subdomain input array
1476      !!
1477      INTEGER :: itaille, ierror   ! temporary integer
1478      !!---------------------------------------------------------------------
1479      !
1480      itaille = jpi * jpj
1481      CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille     ,   &
1482         &                            mpi_double_precision, kp , mpi_comm_opa, ierror )
1483      !
1484   END SUBROUTINE mppgather
1485
1486
1487   SUBROUTINE mppscatter( pio, kp, ptab )
1488      !!----------------------------------------------------------------------
1489      !!                  ***  routine mppscatter  ***
1490      !!
1491      !! ** Purpose :   Transfert between awork array which is distributed
1492      !!      following the vertical level and the local subdomain array.
1493      !!
1494      !!----------------------------------------------------------------------
1495      REAL(wp), DIMENSION(jpi,jpj,jpnij)  ::  pio        ! output array
1496      INTEGER                             ::   kp        ! Tag (not used with MPI
1497      REAL(wp), DIMENSION(jpi,jpj)        ::  ptab       ! subdomain array input
1498      !!
1499      INTEGER :: itaille, ierror   ! temporary integer
1500      !!---------------------------------------------------------------------
1501      !
1502      itaille=jpi*jpj
1503      !
1504      CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille     ,   &
1505         &                            mpi_double_precision, kp  , mpi_comm_opa, ierror )
1506      !
1507   END SUBROUTINE mppscatter
1508
1509
1510   SUBROUTINE mppmax_a_int( ktab, kdim, kcom )
1511      !!----------------------------------------------------------------------
1512      !!                  ***  routine mppmax_a_int  ***
1513      !!
1514      !! ** Purpose :   Find maximum value in an integer layout array
1515      !!
1516      !!----------------------------------------------------------------------
1517      INTEGER , INTENT(in   )                  ::   kdim   ! size of array
1518      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab   ! input array
1519      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom   !
1520      !!
1521      INTEGER :: ierror, localcomm   ! temporary integer
1522      INTEGER, DIMENSION(kdim) ::   iwork
1523      !!----------------------------------------------------------------------
1524      !
1525      localcomm = mpi_comm_opa
1526      IF( PRESENT(kcom) )   localcomm = kcom
1527      !
1528      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror )
1529      !
1530      ktab(:) = iwork(:)
1531      !
1532   END SUBROUTINE mppmax_a_int
1533
1534
1535   SUBROUTINE mppmax_int( ktab, kcom )
1536      !!----------------------------------------------------------------------
1537      !!                  ***  routine mppmax_int  ***
1538      !!
1539      !! ** Purpose :   Find maximum value in an integer layout array
1540      !!
1541      !!----------------------------------------------------------------------
1542      INTEGER, INTENT(inout)           ::   ktab      ! ???
1543      INTEGER, INTENT(in   ), OPTIONAL ::   kcom      ! ???
1544      !!
1545      INTEGER ::   ierror, iwork, localcomm   ! temporary integer
1546      !!----------------------------------------------------------------------
1547      !
1548      localcomm = mpi_comm_opa
1549      IF( PRESENT(kcom) )   localcomm = kcom
1550      !
1551      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror)
1552      !
1553      ktab = iwork
1554      !
1555   END SUBROUTINE mppmax_int
1556
1557
1558   SUBROUTINE mppmin_a_int( ktab, kdim, kcom )
1559      !!----------------------------------------------------------------------
1560      !!                  ***  routine mppmin_a_int  ***
1561      !!
1562      !! ** Purpose :   Find minimum value in an integer layout array
1563      !!
1564      !!----------------------------------------------------------------------
1565      INTEGER , INTENT( in  )                  ::   kdim        ! size of array
1566      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab        ! input array
1567      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array
1568      !!
1569      INTEGER ::   ierror, localcomm   ! temporary integer
1570      INTEGER, DIMENSION(kdim) ::   iwork
1571      !!----------------------------------------------------------------------
1572      !
1573      localcomm = mpi_comm_opa
1574      IF( PRESENT(kcom) )   localcomm = kcom
1575      !
1576      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror )
1577      !
1578      ktab(:) = iwork(:)
1579      !
1580   END SUBROUTINE mppmin_a_int
1581
1582
1583   SUBROUTINE mppmin_int( ktab, kcom )
1584      !!----------------------------------------------------------------------
1585      !!                  ***  routine mppmin_int  ***
1586      !!
1587      !! ** Purpose :   Find minimum value in an integer layout array
1588      !!
1589      !!----------------------------------------------------------------------
1590      INTEGER, INTENT(inout) ::   ktab      ! ???
1591      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array
1592      !!
1593      INTEGER ::  ierror, iwork, localcomm
1594      !!----------------------------------------------------------------------
1595      !
1596      localcomm = mpi_comm_opa
1597      IF( PRESENT(kcom) )   localcomm = kcom
1598      !
1599     CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror )
1600      !
1601      ktab = iwork
1602      !
1603   END SUBROUTINE mppmin_int
1604
1605
1606   SUBROUTINE mppsum_a_int( ktab, kdim )
1607      !!----------------------------------------------------------------------
1608      !!                  ***  routine mppsum_a_int  ***
1609      !!
1610      !! ** Purpose :   Global integer sum, 1D array case
1611      !!
1612      !!----------------------------------------------------------------------
1613      INTEGER, INTENT(in   )                   ::   kdim      ! ???
1614      INTEGER, INTENT(inout), DIMENSION (kdim) ::   ktab      ! ???
1615      !!
1616      INTEGER :: ierror
1617      INTEGER, DIMENSION (kdim) ::  iwork
1618      !!----------------------------------------------------------------------
1619      !
1620      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1621      !
1622      ktab(:) = iwork(:)
1623      !
1624   END SUBROUTINE mppsum_a_int
1625
1626
1627   SUBROUTINE mppsum_int( ktab )
1628      !!----------------------------------------------------------------------
1629      !!                 ***  routine mppsum_int  ***
1630      !!
1631      !! ** Purpose :   Global integer sum
1632      !!
1633      !!----------------------------------------------------------------------
1634      INTEGER, INTENT(inout) ::   ktab
1635      !!
1636      INTEGER :: ierror, iwork
1637      !!----------------------------------------------------------------------
1638      !
1639      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1640      !
1641      ktab = iwork
1642      !
1643   END SUBROUTINE mppsum_int
1644
1645
1646   SUBROUTINE mppmax_a_real( ptab, kdim, kcom )
1647      !!----------------------------------------------------------------------
1648      !!                 ***  routine mppmax_a_real  ***
1649      !!
1650      !! ** Purpose :   Maximum
1651      !!
1652      !!----------------------------------------------------------------------
1653      INTEGER , INTENT(in   )                  ::   kdim
1654      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab
1655      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom
1656      !!
1657      INTEGER :: ierror, localcomm
1658      REAL(wp), DIMENSION(kdim) ::  zwork
1659      !!----------------------------------------------------------------------
1660      !
1661      localcomm = mpi_comm_opa
1662      IF( PRESENT(kcom) ) localcomm = kcom
1663      !
1664      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror )
1665      ptab(:) = zwork(:)
1666      !
1667   END SUBROUTINE mppmax_a_real
1668
1669
1670   SUBROUTINE mppmax_real( ptab, kcom )
1671      !!----------------------------------------------------------------------
1672      !!                  ***  routine mppmax_real  ***
1673      !!
1674      !! ** Purpose :   Maximum
1675      !!
1676      !!----------------------------------------------------------------------
1677      REAL(wp), INTENT(inout)           ::   ptab   ! ???
1678      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ???
1679      !!
1680      INTEGER  ::   ierror, localcomm
1681      REAL(wp) ::   zwork
1682      !!----------------------------------------------------------------------
1683      !
1684      localcomm = mpi_comm_opa
1685      IF( PRESENT(kcom) )   localcomm = kcom
1686      !
1687      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror )
1688      ptab = zwork
1689      !
1690   END SUBROUTINE mppmax_real
1691
1692   SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom  )
1693      !!----------------------------------------------------------------------
1694      !!                  ***  routine mppmax_real  ***
1695      !!
1696      !! ** Purpose :   Maximum
1697      !!
1698      !!----------------------------------------------------------------------
1699      REAL(wp), DIMENSION(:) ,  INTENT(inout)           ::   ptab   ! ???
1700      INTEGER , INTENT(in   )           ::   NUM
1701      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ???
1702      !!
1703      INTEGER  ::   ierror, localcomm
1704      REAL(wp) , POINTER , DIMENSION(:) ::   zwork
1705      !!----------------------------------------------------------------------
1706      !
1707      CALL wrk_alloc(NUM , zwork)
1708      localcomm = mpi_comm_opa
1709      IF( PRESENT(kcom) )   localcomm = kcom
1710      !
1711      CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror )
1712      ptab = zwork
1713      CALL wrk_dealloc(NUM , zwork)
1714      !
1715   END SUBROUTINE mppmax_real_multiple
1716
1717
1718   SUBROUTINE mppmin_a_real( ptab, kdim, kcom )
1719      !!----------------------------------------------------------------------
1720      !!                 ***  routine mppmin_a_real  ***
1721      !!
1722      !! ** Purpose :   Minimum of REAL, array case
1723      !!
1724      !!-----------------------------------------------------------------------
1725      INTEGER , INTENT(in   )                  ::   kdim
1726      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab
1727      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom
1728      !!
1729      INTEGER :: ierror, localcomm
1730      REAL(wp), DIMENSION(kdim) ::   zwork
1731      !!-----------------------------------------------------------------------
1732      !
1733      localcomm = mpi_comm_opa
1734      IF( PRESENT(kcom) ) localcomm = kcom
1735      !
1736      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror )
1737      ptab(:) = zwork(:)
1738      !
1739   END SUBROUTINE mppmin_a_real
1740
1741
1742   SUBROUTINE mppmin_real( ptab, kcom )
1743      !!----------------------------------------------------------------------
1744      !!                  ***  routine mppmin_real  ***
1745      !!
1746      !! ** Purpose :   minimum of REAL, scalar case
1747      !!
1748      !!-----------------------------------------------------------------------
1749      REAL(wp), INTENT(inout)           ::   ptab        !
1750      INTEGER , INTENT(in   ), OPTIONAL :: kcom
1751      !!
1752      INTEGER  ::   ierror
1753      REAL(wp) ::   zwork
1754      INTEGER :: localcomm
1755      !!-----------------------------------------------------------------------
1756      !
1757      localcomm = mpi_comm_opa
1758      IF( PRESENT(kcom) )   localcomm = kcom
1759      !
1760      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror )
1761      ptab = zwork
1762      !
1763   END SUBROUTINE mppmin_real
1764
1765
1766   SUBROUTINE mppsum_a_real( ptab, kdim, kcom )
1767      !!----------------------------------------------------------------------
1768      !!                  ***  routine mppsum_a_real  ***
1769      !!
1770      !! ** Purpose :   global sum, REAL ARRAY argument case
1771      !!
1772      !!-----------------------------------------------------------------------
1773      INTEGER , INTENT( in )                     ::   kdim      ! size of ptab
1774      REAL(wp), DIMENSION(kdim), INTENT( inout ) ::   ptab      ! input array
1775      INTEGER , INTENT( in ), OPTIONAL           :: kcom
1776      !!
1777      INTEGER                   ::   ierror    ! temporary integer
1778      INTEGER                   ::   localcomm
1779      REAL(wp), DIMENSION(kdim) ::   zwork     ! temporary workspace
1780      !!-----------------------------------------------------------------------
1781      !
1782      localcomm = mpi_comm_opa
1783      IF( PRESENT(kcom) )   localcomm = kcom
1784      !
1785      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror )
1786      ptab(:) = zwork(:)
1787      !
1788   END SUBROUTINE mppsum_a_real
1789
1790
1791   SUBROUTINE mppsum_real( ptab, kcom )
1792      !!----------------------------------------------------------------------
1793      !!                  ***  routine mppsum_real  ***
1794      !!
1795      !! ** Purpose :   global sum, SCALAR argument case
1796      !!
1797      !!-----------------------------------------------------------------------
1798      REAL(wp), INTENT(inout)           ::   ptab   ! input scalar
1799      INTEGER , INTENT(in   ), OPTIONAL ::   kcom
1800      !!
1801      INTEGER  ::   ierror, localcomm
1802      REAL(wp) ::   zwork
1803      !!-----------------------------------------------------------------------
1804      !
1805      localcomm = mpi_comm_opa
1806      IF( PRESENT(kcom) ) localcomm = kcom
1807      !
1808      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror )
1809      ptab = zwork
1810      !
1811   END SUBROUTINE mppsum_real
1812
1813   SUBROUTINE mppsum_realdd( ytab, kcom )
1814      !!----------------------------------------------------------------------
1815      !!                  ***  routine mppsum_realdd ***
1816      !!
1817      !! ** Purpose :   global sum in Massively Parallel Processing
1818      !!                SCALAR argument case for double-double precision
1819      !!
1820      !!-----------------------------------------------------------------------
1821      COMPLEX(wp), INTENT(inout)         :: ytab    ! input scalar
1822      INTEGER , INTENT( in  ), OPTIONAL :: kcom
1823
1824      !! * Local variables   (MPI version)
1825      INTEGER  ::    ierror
1826      INTEGER  ::   localcomm
1827      COMPLEX(wp) :: zwork
1828
1829      localcomm = mpi_comm_opa
1830      IF( PRESENT(kcom) ) localcomm = kcom
1831
1832      ! reduce local sums into global sum
1833      CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, &
1834                       MPI_SUMDD,localcomm,ierror)
1835      ytab = zwork
1836
1837   END SUBROUTINE mppsum_realdd
1838
1839
1840   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
1841      !!----------------------------------------------------------------------
1842      !!                  ***  routine mppsum_a_realdd  ***
1843      !!
1844      !! ** Purpose :   global sum in Massively Parallel Processing
1845      !!                COMPLEX ARRAY case for double-double precision
1846      !!
1847      !!-----------------------------------------------------------------------
1848      INTEGER , INTENT( in )                        ::   kdim      ! size of ytab
1849      COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) ::   ytab      ! input array
1850      INTEGER , INTENT( in  ), OPTIONAL :: kcom
1851
1852      !! * Local variables   (MPI version)
1853      INTEGER                      :: ierror    ! temporary integer
1854      INTEGER                      ::   localcomm
1855      COMPLEX(wp), DIMENSION(kdim) :: zwork     ! temporary workspace
1856
1857      localcomm = mpi_comm_opa
1858      IF( PRESENT(kcom) ) localcomm = kcom
1859
1860      CALL MPI_ALLREDUCE (ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, &
1861                       MPI_SUMDD,localcomm,ierror)
1862      ytab(:) = zwork(:)
1863
1864   END SUBROUTINE mppsum_a_realdd
1865
1866   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj )
1867      !!------------------------------------------------------------------------
1868      !!             ***  routine mpp_minloc  ***
1869      !!
1870      !! ** Purpose :   Compute the global minimum of an array ptab
1871      !!              and also give its global position
1872      !!
1873      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
1874      !!
1875      !!--------------------------------------------------------------------------
1876      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   ptab    ! Local 2D array
1877      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask   ! Local mask
1878      REAL(wp)                     , INTENT(  out) ::   pmin    ! Global minimum of ptab
1879      INTEGER                      , INTENT(  out) ::   ki, kj   ! index of minimum in global frame
1880      !!
1881      INTEGER , DIMENSION(2)   ::   ilocs
1882      INTEGER :: ierror
1883      REAL(wp) ::   zmin   ! local minimum
1884      REAL(wp), DIMENSION(2,1) ::   zain, zaout
1885      !!-----------------------------------------------------------------------
1886      !
1887      zmin  = MINVAL( ptab(:,:) , mask= pmask == 1.e0 )
1888      ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 )
1889      !
1890      ki = ilocs(1) + nimpp - 1
1891      kj = ilocs(2) + njmpp - 1
1892      !
1893      zain(1,:)=zmin
1894      zain(2,:)=ki+10000.*kj
1895      !
1896      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
1897      !
1898      pmin = zaout(1,1)
1899      kj = INT(zaout(2,1)/10000.)
1900      ki = INT(zaout(2,1) - 10000.*kj )
1901      !
1902   END SUBROUTINE mpp_minloc2d
1903
1904
1905   SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj ,kk)
1906      !!------------------------------------------------------------------------
1907      !!             ***  routine mpp_minloc  ***
1908      !!
1909      !! ** Purpose :   Compute the global minimum of an array ptab
1910      !!              and also give its global position
1911      !!
1912      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
1913      !!
1914      !!--------------------------------------------------------------------------
1915      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab         ! Local 2D array
1916      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask        ! Local mask
1917      REAL(wp)                         , INTENT(  out) ::   pmin         ! Global minimum of ptab
1918      INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of minimum in global frame
1919      !!
1920      INTEGER  ::   ierror
1921      REAL(wp) ::   zmin     ! local minimum
1922      INTEGER , DIMENSION(3)   ::   ilocs
1923      REAL(wp), DIMENSION(2,1) ::   zain, zaout
1924      !!-----------------------------------------------------------------------
1925      !
1926      zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
1927      ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
1928      !
1929      ki = ilocs(1) + nimpp - 1
1930      kj = ilocs(2) + njmpp - 1
1931      kk = ilocs(3)
1932      !
1933      zain(1,:)=zmin
1934      zain(2,:)=ki+10000.*kj+100000000.*kk
1935      !
1936      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
1937      !
1938      pmin = zaout(1,1)
1939      kk   = INT( zaout(2,1) / 100000000. )
1940      kj   = INT( zaout(2,1) - kk * 100000000. ) / 10000
1941      ki   = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
1942      !
1943   END SUBROUTINE mpp_minloc3d
1944
1945
1946   SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
1947      !!------------------------------------------------------------------------
1948      !!             ***  routine mpp_maxloc  ***
1949      !!
1950      !! ** Purpose :   Compute the global maximum of an array ptab
1951      !!              and also give its global position
1952      !!
1953      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
1954      !!
1955      !!--------------------------------------------------------------------------
1956      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   ptab     ! Local 2D array
1957      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask    ! Local mask
1958      REAL(wp)                     , INTENT(  out) ::   pmax     ! Global maximum of ptab
1959      INTEGER                      , INTENT(  out) ::   ki, kj   ! index of maximum in global frame
1960      !!
1961      INTEGER  :: ierror
1962      INTEGER, DIMENSION (2)   ::   ilocs
1963      REAL(wp) :: zmax   ! local maximum
1964      REAL(wp), DIMENSION(2,1) ::   zain, zaout
1965      !!-----------------------------------------------------------------------
1966      !
1967      zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 )
1968      ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 )
1969      !
1970      ki = ilocs(1) + nimpp - 1
1971      kj = ilocs(2) + njmpp - 1
1972      !
1973      zain(1,:) = zmax
1974      zain(2,:) = ki + 10000. * kj
1975      !
1976      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
1977      !
1978      pmax = zaout(1,1)
1979      kj   = INT( zaout(2,1) / 10000.     )
1980      ki   = INT( zaout(2,1) - 10000.* kj )
1981      !
1982   END SUBROUTINE mpp_maxloc2d
1983
1984
1985   SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
1986      !!------------------------------------------------------------------------
1987      !!             ***  routine mpp_maxloc  ***
1988      !!
1989      !! ** Purpose :  Compute the global maximum of an array ptab
1990      !!              and also give its global position
1991      !!
1992      !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
1993      !!
1994      !!--------------------------------------------------------------------------
1995      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab         ! Local 2D array
1996      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask        ! Local mask
1997      REAL(wp)                         , INTENT(  out) ::   pmax         ! Global maximum of ptab
1998      INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of maximum in global frame
1999      !!
2000      REAL(wp) :: zmax   ! local maximum
2001      REAL(wp), DIMENSION(2,1) ::   zain, zaout
2002      INTEGER , DIMENSION(3)   ::   ilocs
2003      INTEGER :: ierror
2004      !!-----------------------------------------------------------------------
2005      !
2006      zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
2007      ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
2008      !
2009      ki = ilocs(1) + nimpp - 1
2010      kj = ilocs(2) + njmpp - 1
2011      kk = ilocs(3)
2012      !
2013      zain(1,:)=zmax
2014      zain(2,:)=ki+10000.*kj+100000000.*kk
2015      !
2016      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
2017      !
2018      pmax = zaout(1,1)
2019      kk   = INT( zaout(2,1) / 100000000. )
2020      kj   = INT( zaout(2,1) - kk * 100000000. ) / 10000
2021      ki   = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
2022      !
2023   END SUBROUTINE mpp_maxloc3d
2024
2025
2026   SUBROUTINE mppsync()
2027      !!----------------------------------------------------------------------
2028      !!                  ***  routine mppsync  ***
2029      !!
2030      !! ** Purpose :   Massively parallel processors, synchroneous
2031      !!
2032      !!-----------------------------------------------------------------------
2033      INTEGER :: ierror
2034      !!-----------------------------------------------------------------------
2035      !
2036      CALL mpi_barrier( mpi_comm_opa, ierror )
2037      !
2038   END SUBROUTINE mppsync
2039
2040
2041   SUBROUTINE mppstop
2042      !!----------------------------------------------------------------------
2043      !!                  ***  routine mppstop  ***
2044      !!
2045      !! ** purpose :   Stop massively parallel processors method
2046      !!
2047      !!----------------------------------------------------------------------
2048      INTEGER ::   info
2049      !!----------------------------------------------------------------------
2050      !
2051      CALL mppsync
2052      CALL mpi_finalize( info )
2053      !
2054   END SUBROUTINE mppstop
2055
2056
2057   SUBROUTINE mpp_comm_free( kcom )
2058      !!----------------------------------------------------------------------
2059      !!----------------------------------------------------------------------
2060      INTEGER, INTENT(in) ::   kcom
2061      !!
2062      INTEGER :: ierr
2063      !!----------------------------------------------------------------------
2064      !
2065      CALL MPI_COMM_FREE(kcom, ierr)
2066      !
2067   END SUBROUTINE mpp_comm_free
2068
2069
2070   SUBROUTINE mpp_ini_ice( pindic, kumout )
2071      !!----------------------------------------------------------------------
2072      !!               ***  routine mpp_ini_ice  ***
2073      !!
2074      !! ** Purpose :   Initialize special communicator for ice areas
2075      !!      condition together with global variables needed in the ddmpp folding
2076      !!
2077      !! ** Method  : - Look for ice processors in ice routines
2078      !!              - Put their number in nrank_ice
2079      !!              - Create groups for the world processors and the ice processors
2080      !!              - Create a communicator for ice processors
2081      !!
2082      !! ** output
2083      !!      njmppmax = njmpp for northern procs
2084      !!      ndim_rank_ice = number of processors with ice
2085      !!      nrank_ice (ndim_rank_ice) = ice processors
2086      !!      ngrp_iworld = group ID for the world processors
2087      !!      ngrp_ice = group ID for the ice processors
2088      !!      ncomm_ice = communicator for the ice procs.
2089      !!      n_ice_root = number (in the world) of proc 0 in the ice comm.
2090      !!
2091      !!----------------------------------------------------------------------
2092      INTEGER, INTENT(in) ::   pindic
2093      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical unit
2094      !!
2095      INTEGER :: jjproc
2096      INTEGER :: ii, ierr
2097      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kice
2098      INTEGER, ALLOCATABLE, DIMENSION(:) ::   zwork
2099      !!----------------------------------------------------------------------
2100      !
2101      ! Since this is just an init routine and these arrays are of length jpnij
2102      ! then don't use wrk_nemo module - just allocate and deallocate.
2103      ALLOCATE( kice(jpnij), zwork(jpnij), STAT=ierr )
2104      IF( ierr /= 0 ) THEN
2105         WRITE(kumout, cform_err)
2106         WRITE(kumout,*) 'mpp_ini_ice : failed to allocate 2, 1D arrays (jpnij in length)'
2107         CALL mppstop
2108      ENDIF
2109
2110      ! Look for how many procs with sea-ice
2111      !
2112      kice = 0
2113      DO jjproc = 1, jpnij
2114         IF( jjproc == narea .AND. pindic .GT. 0 )   kice(jjproc) = 1
2115      END DO
2116      !
2117      zwork = 0
2118      CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_opa, ierr )
2119      ndim_rank_ice = SUM( zwork )
2120
2121      ! Allocate the right size to nrank_north
2122      IF( ALLOCATED ( nrank_ice ) )   DEALLOCATE( nrank_ice )
2123      ALLOCATE( nrank_ice(ndim_rank_ice) )
2124      !
2125      ii = 0
2126      nrank_ice = 0
2127      DO jjproc = 1, jpnij
2128         IF( zwork(jjproc) == 1) THEN
2129            ii = ii + 1
2130            nrank_ice(ii) = jjproc -1
2131         ENDIF
2132      END DO
2133
2134      ! Create the world group
2135      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_iworld, ierr )
2136
2137      ! Create the ice group from the world group
2138      CALL MPI_GROUP_INCL( ngrp_iworld, ndim_rank_ice, nrank_ice, ngrp_ice, ierr )
2139
2140      ! Create the ice communicator , ie the pool of procs with sea-ice
2141      CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_ice, ncomm_ice, ierr )
2142
2143      ! Find proc number in the world of proc 0 in the north
2144      ! The following line seems to be useless, we just comment & keep it as reminder
2145      ! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_iworld,n_ice_root,ierr)
2146      !
2147      CALL MPI_GROUP_FREE(ngrp_ice, ierr)
2148      CALL MPI_GROUP_FREE(ngrp_iworld, ierr)
2149
2150      DEALLOCATE(kice, zwork)
2151      !
2152   END SUBROUTINE mpp_ini_ice
2153
2154
2155   SUBROUTINE mpp_ini_znl( kumout )
2156      !!----------------------------------------------------------------------
2157      !!               ***  routine mpp_ini_znl  ***
2158      !!
2159      !! ** Purpose :   Initialize special communicator for computing zonal sum
2160      !!
2161      !! ** Method  : - Look for processors in the same row
2162      !!              - Put their number in nrank_znl
2163      !!              - Create group for the znl processors
2164      !!              - Create a communicator for znl processors
2165      !!              - Determine if processor should write znl files
2166      !!
2167      !! ** output
2168      !!      ndim_rank_znl = number of processors on the same row
2169      !!      ngrp_znl = group ID for the znl processors
2170      !!      ncomm_znl = communicator for the ice procs.
2171      !!      n_znl_root = number (in the world) of proc 0 in the ice comm.
2172      !!
2173      !!----------------------------------------------------------------------
2174      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical units
2175      !
2176      INTEGER :: jproc      ! dummy loop integer
2177      INTEGER :: ierr, ii   ! local integer
2178      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kwork
2179      !!----------------------------------------------------------------------
2180      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world     : ', ngrp_world
2181      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
2182      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_opa   : ', mpi_comm_opa
2183      !
2184      ALLOCATE( kwork(jpnij), STAT=ierr )
2185      IF( ierr /= 0 ) THEN
2186         WRITE(kumout, cform_err)
2187         WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij'
2188         CALL mppstop
2189      ENDIF
2190
2191      IF( jpnj == 1 ) THEN
2192         ngrp_znl  = ngrp_world
2193         ncomm_znl = mpi_comm_opa
2194      ELSE
2195         !
2196         CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_opa, ierr )
2197         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
2198         !-$$        CALL flush(numout)
2199         !
2200         ! Count number of processors on the same row
2201         ndim_rank_znl = 0
2202         DO jproc=1,jpnij
2203            IF ( kwork(jproc) == njmpp ) THEN
2204               ndim_rank_znl = ndim_rank_znl + 1
2205            ENDIF
2206         END DO
2207         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
2208         !-$$        CALL flush(numout)
2209         ! Allocate the right size to nrank_znl
2210         IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
2211         ALLOCATE(nrank_znl(ndim_rank_znl))
2212         ii = 0
2213         nrank_znl (:) = 0
2214         DO jproc=1,jpnij
2215            IF ( kwork(jproc) == njmpp) THEN
2216               ii = ii + 1
2217               nrank_znl(ii) = jproc -1
2218            ENDIF
2219         END DO
2220         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
2221         !-$$        CALL flush(numout)
2222
2223         ! Create the opa group
2224         CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_opa,ierr)
2225         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
2226         !-$$        CALL flush(numout)
2227
2228         ! Create the znl group from the opa group
2229         CALL MPI_GROUP_INCL  ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
2230         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
2231         !-$$        CALL flush(numout)
2232
2233         ! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
2234         CALL MPI_COMM_CREATE ( mpi_comm_opa, ngrp_znl, ncomm_znl, ierr )
2235         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
2236         !-$$        CALL flush(numout)
2237         !
2238      END IF
2239
2240      ! Determines if processor if the first (starting from i=1) on the row
2241      IF ( jpni == 1 ) THEN
2242         l_znl_root = .TRUE.
2243      ELSE
2244         l_znl_root = .FALSE.
2245         kwork (1) = nimpp
2246         CALL mpp_min ( kwork(1), kcom = ncomm_znl)
2247         IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
2248      END IF
2249
2250      DEALLOCATE(kwork)
2251
2252   END SUBROUTINE mpp_ini_znl
2253
2254
2255   SUBROUTINE mpp_ini_north
2256      !!----------------------------------------------------------------------
2257      !!               ***  routine mpp_ini_north  ***
2258      !!
2259      !! ** Purpose :   Initialize special communicator for north folding
2260      !!      condition together with global variables needed in the mpp folding
2261      !!
2262      !! ** Method  : - Look for northern processors
2263      !!              - Put their number in nrank_north
2264      !!              - Create groups for the world processors and the north processors
2265      !!              - Create a communicator for northern processors
2266      !!
2267      !! ** output
2268      !!      njmppmax = njmpp for northern procs
2269      !!      ndim_rank_north = number of processors in the northern line
2270      !!      nrank_north (ndim_rank_north) = number  of the northern procs.
2271      !!      ngrp_world = group ID for the world processors
2272      !!      ngrp_north = group ID for the northern processors
2273      !!      ncomm_north = communicator for the northern procs.
2274      !!      north_root = number (in the world) of proc 0 in the northern comm.
2275      !!
2276      !!----------------------------------------------------------------------
2277      INTEGER ::   ierr
2278      INTEGER ::   jjproc
2279      INTEGER ::   ii, ji
2280      !!----------------------------------------------------------------------
2281      !
2282      njmppmax = MAXVAL( njmppt )
2283      !
2284      ! Look for how many procs on the northern boundary
2285      ndim_rank_north = 0
2286      DO jjproc = 1, jpnij
2287         IF( njmppt(jjproc) == njmppmax )   ndim_rank_north = ndim_rank_north + 1
2288      END DO
2289      !
2290      ! Allocate the right size to nrank_north
2291      IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
2292      ALLOCATE( nrank_north(ndim_rank_north) )
2293
2294      ! Fill the nrank_north array with proc. number of northern procs.
2295      ! Note : the rank start at 0 in MPI
2296      ii = 0
2297      DO ji = 1, jpnij
2298         IF ( njmppt(ji) == njmppmax   ) THEN
2299            ii=ii+1
2300            nrank_north(ii)=ji-1
2301         END IF
2302      END DO
2303      !
2304      ! create the world group
2305      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
2306      !
2307      ! Create the North group from the world group
2308      CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
2309      !
2310      ! Create the North communicator , ie the pool of procs in the north group
2311      CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_north, ncomm_north, ierr )
2312      !
2313   END SUBROUTINE mpp_ini_north
2314
2315
2316   SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )
2317      !!---------------------------------------------------------------------
2318      !!                   ***  routine mpp_lbc_north_3d  ***
2319      !!
2320      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2321      !!              in mpp configuration in case of jpn1 > 1
2322      !!
2323      !! ** Method  :   North fold condition and mpp with more than one proc
2324      !!              in i-direction require a specific treatment. We gather
2325      !!              the 4 northern lines of the global domain on 1 processor
2326      !!              and apply lbc north-fold on this sub array. Then we
2327      !!              scatter the north fold array back to the processors.
2328      !!
2329      !!----------------------------------------------------------------------
2330      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d      ! 3D array on which the b.c. is applied
2331      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
2332      !                                                              !   = T ,  U , V , F or W  gridpoints
2333      REAL(wp)                        , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
2334      !!                                                             ! =  1. , the sign is kept
2335      INTEGER ::   ji, jj, jr, jk
2336      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2337      INTEGER ::   ijpj, ijpjm1, ij, iproc
2338      INTEGER, DIMENSION (jpmaxngh)          ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather
2339      INTEGER                                ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
2340      INTEGER, DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
2341      !                                                              ! Workspace for message transfers avoiding mpi_allgather
2342      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab
2343      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk     
2344      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio
2345      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr
2346
2347      INTEGER :: istatus(mpi_status_size)
2348      INTEGER :: iflag
2349      !!----------------------------------------------------------------------
2350      !
2351      ALLOCATE( ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk), zfoldwk(jpi,4,jpk), znorthgloio(jpi,4,jpk,jpni) )
2352      ALLOCATE( ztabl(jpi,4,jpk), ztabr(jpi*jpmaxngh, 4, jpk) ) 
2353
2354      ijpj   = 4
2355      ijpjm1 = 3
2356      !
2357      znorthloc(:,:,:) = 0
2358      DO jk = 1, jpk
2359         DO jj = nlcj - ijpj +1, nlcj          ! put in xnorthloc the last 4 jlines of pt3d
2360            ij = jj - nlcj + ijpj
2361            znorthloc(:,ij,jk) = pt3d(:,jj,jk)
2362         END DO
2363      END DO
2364      !
2365      !                                     ! Build in procs of ncomm_north the znorthgloio
2366      itaille = jpi * jpk * ijpj
2367
2368      IF ( l_north_nogather ) THEN
2369         !
2370        ztabr(:,:,:) = 0
2371        ztabl(:,:,:) = 0
2372
2373        DO jk = 1, jpk
2374           DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array
2375              ij = jj - nlcj + ijpj
2376              DO ji = nfsloop, nfeloop
2377                 ztabl(ji,ij,jk) = pt3d(ji,jj,jk)
2378              END DO
2379           END DO
2380        END DO
2381
2382         DO jr = 1,nsndto
2383            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2384              CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )
2385            ENDIF
2386         END DO
2387         DO jr = 1,nsndto
2388            iproc = nfipproc(isendto(jr),jpnj)
2389            IF(iproc .ne. -1) THEN
2390               ilei = nleit (iproc+1)
2391               ildi = nldit (iproc+1)
2392               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
2393            ENDIF
2394            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN
2395              CALL mpprecv(5, zfoldwk, itaille, iproc)
2396              DO jk = 1, jpk
2397                 DO jj = 1, ijpj
2398                    DO ji = ildi, ilei
2399                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)
2400                    END DO
2401                 END DO
2402              END DO
2403           ELSE IF (iproc .eq. (narea-1)) THEN
2404              DO jk = 1, jpk
2405                 DO jj = 1, ijpj
2406                    DO ji = ildi, ilei
2407                       ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk)
2408                    END DO
2409                 END DO
2410              END DO
2411           ENDIF
2412         END DO
2413         IF (l_isend) THEN
2414            DO jr = 1,nsndto
2415               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2416                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
2417               ENDIF   
2418            END DO
2419         ENDIF
2420         CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition
2421         DO jk = 1, jpk
2422            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d
2423               ij = jj - nlcj + ijpj
2424               DO ji= 1, nlci
2425                  pt3d(ji,jj,jk) = ztabl(ji,ij,jk)
2426               END DO
2427            END DO
2428         END DO
2429         !
2430
2431      ELSE
2432         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                &
2433            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2434         !
2435         ztab(:,:,:) = 0.e0
2436         DO jr = 1, ndim_rank_north         ! recover the global north array
2437            iproc = nrank_north(jr) + 1
2438            ildi  = nldit (iproc)
2439            ilei  = nleit (iproc)
2440            iilb  = nimppt(iproc)
2441            DO jk = 1, jpk
2442               DO jj = 1, ijpj
2443                  DO ji = ildi, ilei
2444                    ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)
2445                  END DO
2446               END DO
2447            END DO
2448         END DO
2449         CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
2450         !
2451         DO jk = 1, jpk
2452            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d
2453               ij = jj - nlcj + ijpj
2454               DO ji= 1, nlci
2455                  pt3d(ji,jj,jk) = ztab(ji+nimpp-1,ij,jk)
2456               END DO
2457            END DO
2458         END DO
2459         !
2460      ENDIF
2461      !
2462      ! The ztab array has been either:
2463      !  a. Fully populated by the mpi_allgather operation or
2464      !  b. Had the active points for this domain and northern neighbours populated
2465      !     by peer to peer exchanges
2466      ! Either way the array may be folded by lbc_nfd and the result for the span of
2467      ! this domain will be identical.
2468      !
2469      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
2470      DEALLOCATE( ztabl, ztabr ) 
2471      !
2472   END SUBROUTINE mpp_lbc_north_3d
2473
2474
2475   SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn)
2476      !!---------------------------------------------------------------------
2477      !!                   ***  routine mpp_lbc_north_2d  ***
2478      !!
2479      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2480      !!              in mpp configuration in case of jpn1 > 1 (for 2d array )
2481      !!
2482      !! ** Method  :   North fold condition and mpp with more than one proc
2483      !!              in i-direction require a specific treatment. We gather
2484      !!              the 4 northern lines of the global domain on 1 processor
2485      !!              and apply lbc north-fold on this sub array. Then we
2486      !!              scatter the north fold array back to the processors.
2487      !!
2488      !!----------------------------------------------------------------------
2489      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 2D array on which the b.c. is applied
2490      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points
2491      !                                                          !   = T ,  U , V , F or W  gridpoints
2492      REAL(wp)                    , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
2493      !!                                                             ! =  1. , the sign is kept
2494      INTEGER ::   ji, jj, jr
2495      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2496      INTEGER ::   ijpj, ijpjm1, ij, iproc
2497      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather
2498      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
2499      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
2500      !                                                              ! Workspace for message transfers avoiding mpi_allgather
2501      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: ztab
2502      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk     
2503      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE   :: znorthgloio
2504      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: ztabl, ztabr
2505      INTEGER :: istatus(mpi_status_size)
2506      INTEGER :: iflag
2507      !!----------------------------------------------------------------------
2508      !
2509      ALLOCATE( ztab(jpiglo,4), znorthloc(jpi,4), zfoldwk(jpi,4), znorthgloio(jpi,4,jpni) )
2510      ALLOCATE( ztabl(jpi,4), ztabr(jpi*jpmaxngh, 4) ) 
2511      !
2512      ijpj   = 4
2513      ijpjm1 = 3
2514      !
2515      DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d
2516         ij = jj - nlcj + ijpj
2517         znorthloc(:,ij) = pt2d(:,jj)
2518      END DO
2519
2520      !                                     ! Build in procs of ncomm_north the znorthgloio
2521      itaille = jpi * ijpj
2522      IF ( l_north_nogather ) THEN
2523         !
2524         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified
2525         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange
2526         !
2527         ztabr(:,:) = 0
2528         ztabl(:,:) = 0
2529
2530         DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array
2531            ij = jj - nlcj + ijpj
2532              DO ji = nfsloop, nfeloop
2533               ztabl(ji,ij) = pt2d(ji,jj)
2534            END DO
2535         END DO
2536
2537         DO jr = 1,nsndto
2538            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2539               CALL mppsend(5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr))
2540            ENDIF
2541         END DO
2542         DO jr = 1,nsndto
2543            iproc = nfipproc(isendto(jr),jpnj)
2544            IF(iproc .ne. -1) THEN
2545               ilei = nleit (iproc+1)
2546               ildi = nldit (iproc+1)
2547               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
2548            ENDIF
2549            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN
2550              CALL mpprecv(5, zfoldwk, itaille, iproc)
2551              DO jj = 1, ijpj
2552                 DO ji = ildi, ilei
2553                    ztabr(iilb+ji,jj) = zfoldwk(ji,jj)
2554                 END DO
2555              END DO
2556            ELSE IF (iproc .eq. (narea-1)) THEN
2557              DO jj = 1, ijpj
2558                 DO ji = ildi, ilei
2559                    ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj)
2560                 END DO
2561              END DO
2562            ENDIF
2563         END DO
2564         IF (l_isend) THEN
2565            DO jr = 1,nsndto
2566               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2567                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
2568               ENDIF
2569            END DO
2570         ENDIF
2571         CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition
2572         !
2573         DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
2574            ij = jj - nlcj + ijpj
2575            DO ji = 1, nlci
2576               pt2d(ji,jj) = ztabl(ji,ij)
2577            END DO
2578         END DO
2579         !
2580      ELSE
2581         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,        &
2582            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2583         !
2584         ztab(:,:) = 0.e0
2585         DO jr = 1, ndim_rank_north            ! recover the global north array
2586            iproc = nrank_north(jr) + 1
2587            ildi = nldit (iproc)
2588            ilei = nleit (iproc)
2589            iilb = nimppt(iproc)
2590            DO jj = 1, ijpj
2591               DO ji = ildi, ilei
2592                  ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)
2593               END DO
2594            END DO
2595         END DO
2596         CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
2597         !
2598         DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
2599            ij = jj - nlcj + ijpj
2600            DO ji = 1, nlci
2601               pt2d(ji,jj) = ztab(ji+nimpp-1,ij)
2602            END DO
2603         END DO
2604         !
2605      ENDIF
2606      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
2607      DEALLOCATE( ztabl, ztabr ) 
2608      !
2609   END SUBROUTINE mpp_lbc_north_2d
2610
2611   SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields)
2612      !!---------------------------------------------------------------------
2613      !!                   ***  routine mpp_lbc_north_2d  ***
2614      !!
2615      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2616      !!              in mpp configuration in case of jpn1 > 1
2617      !!              (for multiple 2d arrays )
2618      !!
2619      !! ** Method  :   North fold condition and mpp with more than one proc
2620      !!              in i-direction require a specific treatment. We gather
2621      !!              the 4 northern lines of the global domain on 1 processor
2622      !!              and apply lbc north-fold on this sub array. Then we
2623      !!              scatter the north fold array back to the processors.
2624      !!
2625      !!----------------------------------------------------------------------
2626      INTEGER ,  INTENT (in   ) ::   num_fields  ! number of variables contained in pt2d
2627      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array
2628      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points
2629      !                                                          !   = T ,  U , V , F or W  gridpoints
2630      REAL(wp), DIMENSION(:), INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
2631      !!                                                             ! =  1. , the sign is kept
2632      INTEGER ::   ji, jj, jr, jk
2633      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2634      INTEGER ::   ijpj, ijpjm1, ij, iproc
2635      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather
2636      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
2637      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
2638      !                                                              ! Workspace for message transfers avoiding mpi_allgather
2639      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab
2640      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk
2641      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio
2642      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr
2643      INTEGER :: istatus(mpi_status_size)
2644      INTEGER :: iflag
2645      !!----------------------------------------------------------------------
2646      !
2647      ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields), znorthgloio(jpi,4,num_fields,jpni) )   ! expanded to 3 dimensions
2648      ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) )
2649      !
2650      ijpj   = 4
2651      ijpjm1 = 3
2652      !
2653     
2654      DO jk = 1, num_fields
2655         DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable)
2656            ij = jj - nlcj + ijpj
2657            znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj)
2658         END DO
2659      END DO
2660      !                                     ! Build in procs of ncomm_north the znorthgloio
2661      itaille = jpi * ijpj
2662                                                                 
2663      IF ( l_north_nogather ) THEN
2664         !
2665         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified
2666         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange
2667         !
2668         ztabr(:,:,:) = 0
2669         ztabl(:,:,:) = 0
2670
2671         DO jk = 1, num_fields
2672            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array
2673               ij = jj - nlcj + ijpj
2674               DO ji = nfsloop, nfeloop
2675                  ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj)
2676               END DO
2677            END DO
2678         END DO
2679
2680         DO jr = 1,nsndto
2681            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2682               CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times
2683            ENDIF
2684         END DO
2685         DO jr = 1,nsndto
2686            iproc = nfipproc(isendto(jr),jpnj)
2687            IF(iproc .ne. -1) THEN
2688               ilei = nleit (iproc+1)
2689               ildi = nldit (iproc+1)
2690               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
2691            ENDIF
2692            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN
2693              CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times
2694              DO jk = 1 , num_fields
2695                 DO jj = 1, ijpj
2696                    DO ji = ildi, ilei
2697                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)       ! Modified to 3D
2698                    END DO
2699                 END DO
2700              END DO
2701            ELSE IF (iproc .eq. (narea-1)) THEN
2702              DO jk = 1, num_fields
2703                 DO jj = 1, ijpj
2704                    DO ji = ildi, ilei
2705                          ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj)       ! Modified to 3D
2706                    END DO
2707                 END DO
2708              END DO
2709            ENDIF
2710         END DO
2711         IF (l_isend) THEN
2712            DO jr = 1,nsndto
2713               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2714                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
2715               ENDIF
2716            END DO
2717         ENDIF
2718         !
2719         DO ji = 1, num_fields     ! Loop to manage 3D variables
2720            CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition
2721         END DO
2722         !
2723         DO jk = 1, num_fields
2724            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
2725               ij = jj - nlcj + ijpj
2726               DO ji = 1, nlci
2727                  pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk)       ! Modified to 3D
2728               END DO
2729            END DO
2730         END DO
2731         
2732         !
2733      ELSE
2734         !
2735         CALL MPI_ALLGATHER( znorthloc  , itaille*num_fields, MPI_DOUBLE_PRECISION,        &
2736            &                znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2737         !
2738         ztab(:,:,:) = 0.e0
2739         DO jk = 1, num_fields
2740            DO jr = 1, ndim_rank_north            ! recover the global north array
2741               iproc = nrank_north(jr) + 1
2742               ildi = nldit (iproc)
2743               ilei = nleit (iproc)
2744               iilb = nimppt(iproc)
2745               DO jj = 1, ijpj
2746                  DO ji = ildi, ilei
2747                     ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)
2748                  END DO
2749               END DO
2750            END DO
2751         END DO
2752         
2753         DO ji = 1, num_fields
2754            CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition
2755         END DO
2756         !
2757         DO jk = 1, num_fields
2758            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
2759               ij = jj - nlcj + ijpj
2760               DO ji = 1, nlci
2761                  pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk)
2762               END DO
2763            END DO
2764         END DO
2765         !
2766         !
2767      ENDIF
2768      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
2769      DEALLOCATE( ztabl, ztabr )
2770      !
2771   END SUBROUTINE mpp_lbc_north_2d_multiple
2772
2773   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)
2774      !!---------------------------------------------------------------------
2775      !!                   ***  routine mpp_lbc_north_2d  ***
2776      !!
2777      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2778      !!              in mpp configuration in case of jpn1 > 1 and for 2d
2779      !!              array with outer extra halo
2780      !!
2781      !! ** Method  :   North fold condition and mpp with more than one proc
2782      !!              in i-direction require a specific treatment. We gather
2783      !!              the 4+2*jpr2dj northern lines of the global domain on 1
2784      !!              processor and apply lbc north-fold on this sub array.
2785      !!              Then we scatter the north fold array back to the processors.
2786      !!
2787      !!----------------------------------------------------------------------
2788      REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
2789      CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points
2790      !                                                                                         !   = T ,  U , V , F or W -points
2791      REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! = -1. the sign change across the
2792      !!                                                                                        ! north fold, =  1. otherwise
2793      INTEGER ::   ji, jj, jr
2794      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2795      INTEGER ::   ijpj, ij, iproc
2796      !
2797      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e
2798      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e
2799
2800      !!----------------------------------------------------------------------
2801      !
2802      ALLOCATE( ztab_e(jpiglo,4+2*jpr2dj), znorthloc_e(jpi,4+2*jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) )
2803
2804      !
2805      ijpj=4
2806      ztab_e(:,:) = 0.e0
2807
2808      ij=0
2809      ! put in znorthloc_e the last 4 jlines of pt2d
2810      DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
2811         ij = ij + 1
2812         DO ji = 1, jpi
2813            znorthloc_e(ji,ij)=pt2d(ji,jj)
2814         END DO
2815      END DO
2816      !
2817      itaille = jpi * ( ijpj + 2 * jpr2dj )
2818      CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    &
2819         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2820      !
2821      DO jr = 1, ndim_rank_north            ! recover the global north array
2822         iproc = nrank_north(jr) + 1
2823         ildi = nldit (iproc)
2824         ilei = nleit (iproc)
2825         iilb = nimppt(iproc)
2826         DO jj = 1, ijpj+2*jpr2dj
2827            DO ji = ildi, ilei
2828               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
2829            END DO
2830         END DO
2831      END DO
2832
2833
2834      ! 2. North-Fold boundary conditions
2835      ! ----------------------------------
2836      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )
2837
2838      ij = jpr2dj
2839      !! Scatter back to pt2d
2840      DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj
2841      ij  = ij +1
2842         DO ji= 1, nlci
2843            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
2844         END DO
2845      END DO
2846      !
2847      DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
2848      !
2849   END SUBROUTINE mpp_lbc_north_e
2850
2851      SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy )
2852      !!----------------------------------------------------------------------
2853      !!                  ***  routine mpp_lnk_bdy_3d  ***
2854      !!
2855      !! ** Purpose :   Message passing management
2856      !!
2857      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries
2858      !!      between processors following neighboring subdomains.
2859      !!            domain parameters
2860      !!                    nlci   : first dimension of the local subdomain
2861      !!                    nlcj   : second dimension of the local subdomain
2862      !!                    nbondi_bdy : mark for "east-west local boundary"
2863      !!                    nbondj_bdy : mark for "north-south local boundary"
2864      !!                    noea   : number for local neighboring processors
2865      !!                    nowe   : number for local neighboring processors
2866      !!                    noso   : number for local neighboring processors
2867      !!                    nono   : number for local neighboring processors
2868      !!
2869      !! ** Action  :   ptab with update value at its periphery
2870      !!
2871      !!----------------------------------------------------------------------
2872
2873      USE lbcnfd          ! north fold
2874
2875      INCLUDE 'mpif.h'
2876
2877      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
2878      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
2879      !                                                             ! = T , U , V , F , W points
2880      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
2881      !                                                             ! =  1. , the sign is kept
2882      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set
2883      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices
2884      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
2885      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
2886      REAL(wp) ::   zland
2887      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
2888      !
2889      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north
2890      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east
2891
2892      !!----------------------------------------------------------------------
2893     
2894      ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   &
2895         &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  )
2896
2897      zland = 0.e0
2898
2899      ! 1. standard boundary treatment
2900      ! ------------------------------
2901     
2902      !                                   ! East-West boundaries
2903      !                                        !* Cyclic east-west
2904
2905      IF( nbondi == 2) THEN
2906        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN
2907          ptab( 1 ,:,:) = ptab(jpim1,:,:)
2908          ptab(jpi,:,:) = ptab(  2  ,:,:)
2909        ELSE
2910          IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point
2911          ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north
2912        ENDIF
2913      ELSEIF(nbondi == -1) THEN
2914        IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point
2915      ELSEIF(nbondi == 1) THEN
2916        ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north
2917      ENDIF                                     !* closed
2918
2919      IF (nbondj == 2 .OR. nbondj == -1) THEN
2920        IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point
2921      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
2922        ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north
2923      ENDIF
2924     
2925      !
2926
2927      ! 2. East and west directions exchange
2928      ! ------------------------------------
2929      ! we play with the neigbours AND the row number because of the periodicity
2930      !
2931      SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions
2932      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
2933         iihom = nlci-nreci
2934         DO jl = 1, jpreci
2935            zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
2936            zt3we(:,jl,:,1) = ptab(iihom +jl,:,:)
2937         END DO
2938      END SELECT
2939      !
2940      !                           ! Migrations
2941      imigr = jpreci * jpj * jpk
2942      !
2943      SELECT CASE ( nbondi_bdy(ib_bdy) )
2944      CASE ( -1 )
2945         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 )
2946      CASE ( 0 )
2947         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
2948         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 )
2949      CASE ( 1 )
2950         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
2951      END SELECT
2952      !
2953      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
2954      CASE ( -1 )
2955         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
2956      CASE ( 0 )
2957         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
2958         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
2959      CASE ( 1 )
2960         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
2961      END SELECT
2962      !
2963      SELECT CASE ( nbondi_bdy(ib_bdy) )
2964      CASE ( -1 )
2965         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2966      CASE ( 0 )
2967         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2968         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
2969      CASE ( 1 )
2970         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2971      END SELECT
2972      !
2973      !                           ! Write Dirichlet lateral conditions
2974      iihom = nlci-jpreci
2975      !
2976      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
2977      CASE ( -1 )
2978         DO jl = 1, jpreci
2979            ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
2980         END DO
2981      CASE ( 0 )
2982         DO jl = 1, jpreci
2983            ptab(jl      ,:,:) = zt3we(:,jl,:,2)
2984            ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
2985         END DO
2986      CASE ( 1 )
2987         DO jl = 1, jpreci
2988            ptab(jl      ,:,:) = zt3we(:,jl,:,2)
2989         END DO
2990      END SELECT
2991
2992
2993      ! 3. North and south directions
2994      ! -----------------------------
2995      ! always closed : we play only with the neigbours
2996      !
2997      IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions
2998         ijhom = nlcj-nrecj
2999         DO jl = 1, jprecj
3000            zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
3001            zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
3002         END DO
3003      ENDIF
3004      !
3005      !                           ! Migrations
3006      imigr = jprecj * jpi * jpk
3007      !
3008      SELECT CASE ( nbondj_bdy(ib_bdy) )
3009      CASE ( -1 )
3010         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 )
3011      CASE ( 0 )
3012         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
3013         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 )
3014      CASE ( 1 )
3015         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
3016      END SELECT
3017      !
3018      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3019      CASE ( -1 )
3020         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
3021      CASE ( 0 )
3022         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
3023         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
3024      CASE ( 1 )
3025         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
3026      END SELECT
3027      !
3028      SELECT CASE ( nbondj_bdy(ib_bdy) )
3029      CASE ( -1 )
3030         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3031      CASE ( 0 )
3032         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3033         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
3034      CASE ( 1 )
3035         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3036      END SELECT
3037      !
3038      !                           ! Write Dirichlet lateral conditions
3039      ijhom = nlcj-jprecj
3040      !
3041      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3042      CASE ( -1 )
3043         DO jl = 1, jprecj
3044            ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
3045         END DO
3046      CASE ( 0 )
3047         DO jl = 1, jprecj
3048            ptab(:,jl      ,:) = zt3sn(:,jl,:,2)
3049            ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
3050         END DO
3051      CASE ( 1 )
3052         DO jl = 1, jprecj
3053            ptab(:,jl,:) = zt3sn(:,jl,:,2)
3054         END DO
3055      END SELECT
3056
3057
3058      ! 4. north fold treatment
3059      ! -----------------------
3060      !
3061      IF( npolj /= 0) THEN
3062         !
3063         SELECT CASE ( jpni )
3064         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
3065         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
3066         END SELECT
3067         !
3068      ENDIF
3069      !
3070      DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we  )
3071      !
3072   END SUBROUTINE mpp_lnk_bdy_3d
3073
3074      SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy )
3075      !!----------------------------------------------------------------------
3076      !!                  ***  routine mpp_lnk_bdy_2d  ***
3077      !!
3078      !! ** Purpose :   Message passing management
3079      !!
3080      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries
3081      !!      between processors following neighboring subdomains.
3082      !!            domain parameters
3083      !!                    nlci   : first dimension of the local subdomain
3084      !!                    nlcj   : second dimension of the local subdomain
3085      !!                    nbondi_bdy : mark for "east-west local boundary"
3086      !!                    nbondj_bdy : mark for "north-south local boundary"
3087      !!                    noea   : number for local neighboring processors
3088      !!                    nowe   : number for local neighboring processors
3089      !!                    noso   : number for local neighboring processors
3090      !!                    nono   : number for local neighboring processors
3091      !!
3092      !! ** Action  :   ptab with update value at its periphery
3093      !!
3094      !!----------------------------------------------------------------------
3095
3096      USE lbcnfd          ! north fold
3097
3098      INCLUDE 'mpif.h'
3099
3100      REAL(wp), DIMENSION(jpi,jpj)    , INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
3101      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
3102      !                                                             ! = T , U , V , F , W points
3103      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
3104      !                                                             ! =  1. , the sign is kept
3105      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set
3106      INTEGER  ::   ji, jj, jl             ! dummy loop indices
3107      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
3108      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
3109      REAL(wp) ::   zland
3110      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
3111      !
3112      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north
3113      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east
3114
3115      !!----------------------------------------------------------------------
3116
3117      ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  &
3118         &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   )
3119
3120      zland = 0.e0
3121
3122      ! 1. standard boundary treatment
3123      ! ------------------------------
3124     
3125      !                                   ! East-West boundaries
3126      !                                        !* Cyclic east-west
3127
3128      IF( nbondi == 2) THEN
3129        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN
3130          ptab( 1 ,:) = ptab(jpim1,:)
3131          ptab(jpi,:) = ptab(  2  ,:)
3132        ELSE
3133          IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point
3134          ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north
3135        ENDIF
3136      ELSEIF(nbondi == -1) THEN
3137        IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point
3138      ELSEIF(nbondi == 1) THEN
3139        ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north
3140      ENDIF                                     !* closed
3141
3142      IF (nbondj == 2 .OR. nbondj == -1) THEN
3143        IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj) = zland       ! south except F-point
3144      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
3145        ptab(:,nlcj-jprecj+1:jpj) = zland       ! north
3146      ENDIF
3147     
3148      !
3149
3150      ! 2. East and west directions exchange
3151      ! ------------------------------------
3152      ! we play with the neigbours AND the row number because of the periodicity
3153      !
3154      SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions
3155      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
3156         iihom = nlci-nreci
3157         DO jl = 1, jpreci
3158            zt2ew(:,jl,1) = ptab(jpreci+jl,:)
3159            zt2we(:,jl,1) = ptab(iihom +jl,:)
3160         END DO
3161      END SELECT
3162      !
3163      !                           ! Migrations
3164      imigr = jpreci * jpj
3165      !
3166      SELECT CASE ( nbondi_bdy(ib_bdy) )
3167      CASE ( -1 )
3168         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )
3169      CASE ( 0 )
3170         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
3171         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )
3172      CASE ( 1 )
3173         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
3174      END SELECT
3175      !
3176      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3177      CASE ( -1 )
3178         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
3179      CASE ( 0 )
3180         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
3181         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
3182      CASE ( 1 )
3183         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
3184      END SELECT
3185      !
3186      SELECT CASE ( nbondi_bdy(ib_bdy) )
3187      CASE ( -1 )
3188         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3189      CASE ( 0 )
3190         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3191         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
3192      CASE ( 1 )
3193         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3194      END SELECT
3195      !
3196      !                           ! Write Dirichlet lateral conditions
3197      iihom = nlci-jpreci
3198      !
3199      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3200      CASE ( -1 )
3201         DO jl = 1, jpreci
3202            ptab(iihom+jl,:) = zt2ew(:,jl,2)
3203         END DO
3204      CASE ( 0 )
3205         DO jl = 1, jpreci
3206            ptab(jl      ,:) = zt2we(:,jl,2)
3207            ptab(iihom+jl,:) = zt2ew(:,jl,2)
3208         END DO
3209      CASE ( 1 )
3210         DO jl = 1, jpreci
3211            ptab(jl      ,:) = zt2we(:,jl,2)
3212         END DO
3213      END SELECT
3214
3215
3216      ! 3. North and south directions
3217      ! -----------------------------
3218      ! always closed : we play only with the neigbours
3219      !
3220      IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions
3221         ijhom = nlcj-nrecj
3222         DO jl = 1, jprecj
3223            zt2sn(:,jl,1) = ptab(:,ijhom +jl)
3224            zt2ns(:,jl,1) = ptab(:,jprecj+jl)
3225         END DO
3226      ENDIF
3227      !
3228      !                           ! Migrations
3229      imigr = jprecj * jpi
3230      !
3231      SELECT CASE ( nbondj_bdy(ib_bdy) )
3232      CASE ( -1 )
3233         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )
3234      CASE ( 0 )
3235         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
3236         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )
3237      CASE ( 1 )
3238         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
3239      END SELECT
3240      !
3241      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3242      CASE ( -1 )
3243         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
3244      CASE ( 0 )
3245         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
3246         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
3247      CASE ( 1 )
3248         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
3249      END SELECT
3250      !
3251      SELECT CASE ( nbondj_bdy(ib_bdy) )
3252      CASE ( -1 )
3253         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3254      CASE ( 0 )
3255         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3256         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
3257      CASE ( 1 )
3258         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3259      END SELECT
3260      !
3261      !                           ! Write Dirichlet lateral conditions
3262      ijhom = nlcj-jprecj
3263      !
3264      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3265      CASE ( -1 )
3266         DO jl = 1, jprecj
3267            ptab(:,ijhom+jl) = zt2ns(:,jl,2)
3268         END DO
3269      CASE ( 0 )
3270         DO jl = 1, jprecj
3271            ptab(:,jl      ) = zt2sn(:,jl,2)
3272            ptab(:,ijhom+jl) = zt2ns(:,jl,2)
3273         END DO
3274      CASE ( 1 )
3275         DO jl = 1, jprecj
3276            ptab(:,jl) = zt2sn(:,jl,2)
3277         END DO
3278      END SELECT
3279
3280
3281      ! 4. north fold treatment
3282      ! -----------------------
3283      !
3284      IF( npolj /= 0) THEN
3285         !
3286         SELECT CASE ( jpni )
3287         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
3288         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
3289         END SELECT
3290         !
3291      ENDIF
3292      !
3293      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we  )
3294      !
3295   END SUBROUTINE mpp_lnk_bdy_2d
3296
3297   SUBROUTINE mpi_init_opa( ldtxt, ksft, code )
3298      !!---------------------------------------------------------------------
3299      !!                   ***  routine mpp_init.opa  ***
3300      !!
3301      !! ** Purpose :: export and attach a MPI buffer for bsend
3302      !!
3303      !! ** Method  :: define buffer size in namelist, if 0 no buffer attachment
3304      !!            but classical mpi_init
3305      !!
3306      !! History :: 01/11 :: IDRIS initial version for IBM only
3307      !!            08/04 :: R. Benshila, generalisation
3308      !!---------------------------------------------------------------------
3309      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt
3310      INTEGER                      , INTENT(inout) ::   ksft
3311      INTEGER                      , INTENT(  out) ::   code
3312      INTEGER                                      ::   ierr, ji
3313      LOGICAL                                      ::   mpi_was_called
3314      !!---------------------------------------------------------------------
3315      !
3316      CALL mpi_initialized( mpi_was_called, code )      ! MPI initialization
3317      IF ( code /= MPI_SUCCESS ) THEN
3318         DO ji = 1, SIZE(ldtxt)
3319            IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
3320         END DO
3321         WRITE(*, cform_err)
3322         WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized'
3323         CALL mpi_abort( mpi_comm_world, code, ierr )
3324      ENDIF
3325      !
3326      IF( .NOT. mpi_was_called ) THEN
3327         CALL mpi_init( code )
3328         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code )
3329         IF ( code /= MPI_SUCCESS ) THEN
3330            DO ji = 1, SIZE(ldtxt)
3331               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
3332            END DO
3333            WRITE(*, cform_err)
3334            WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
3335            CALL mpi_abort( mpi_comm_world, code, ierr )
3336         ENDIF
3337      ENDIF
3338      !
3339      IF( nn_buffer > 0 ) THEN
3340         WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of  : ', nn_buffer   ;   ksft = ksft + 1
3341         ! Buffer allocation and attachment
3342         ALLOCATE( tampon(nn_buffer), stat = ierr )
3343         IF( ierr /= 0 ) THEN
3344            DO ji = 1, SIZE(ldtxt)
3345               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
3346            END DO
3347            WRITE(*, cform_err)
3348            WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr
3349            CALL mpi_abort( mpi_comm_world, code, ierr )
3350         END IF
3351         CALL mpi_buffer_attach( tampon, nn_buffer, code )
3352      ENDIF
3353      !
3354   END SUBROUTINE mpi_init_opa
3355
3356   SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype)
3357      !!---------------------------------------------------------------------
3358      !!   Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
3359      !!
3360      !!   Modification of original codes written by David H. Bailey
3361      !!   This subroutine computes yddb(i) = ydda(i)+yddb(i)
3362      !!---------------------------------------------------------------------
3363      INTEGER, INTENT(in)                         :: ilen, itype
3364      COMPLEX(wp), DIMENSION(ilen), INTENT(in)     :: ydda
3365      COMPLEX(wp), DIMENSION(ilen), INTENT(inout)  :: yddb
3366      !
3367      REAL(wp) :: zerr, zt1, zt2    ! local work variables
3368      INTEGER :: ji, ztmp           ! local scalar
3369
3370      ztmp = itype   ! avoid compilation warning
3371
3372      DO ji=1,ilen
3373      ! Compute ydda + yddb using Knuth's trick.
3374         zt1  = real(ydda(ji)) + real(yddb(ji))
3375         zerr = zt1 - real(ydda(ji))
3376         zt2  = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
3377                + aimag(ydda(ji)) + aimag(yddb(ji))
3378
3379         ! The result is zt1 + zt2, after normalization.
3380         yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
3381      END DO
3382
3383   END SUBROUTINE DDPDD_MPI
3384
3385   SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj)
3386      !!---------------------------------------------------------------------
3387      !!                   ***  routine mpp_lbc_north_icb  ***
3388      !!
3389      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
3390      !!              in mpp configuration in case of jpn1 > 1 and for 2d
3391      !!              array with outer extra halo
3392      !!
3393      !! ** Method  :   North fold condition and mpp with more than one proc
3394      !!              in i-direction require a specific treatment. We gather
3395      !!              the 4+2*jpr2dj northern lines of the global domain on 1
3396      !!              processor and apply lbc north-fold on this sub array.
3397      !!              Then we scatter the north fold array back to the processors.
3398      !!              This version accounts for an extra halo with icebergs.
3399      !!
3400      !!----------------------------------------------------------------------
3401      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo
3402      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points
3403      !                                                     !   = T ,  U , V , F or W -points
3404      REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the
3405      !!                                                    ! north fold, =  1. otherwise
3406      INTEGER, OPTIONAL       , INTENT(in   ) ::   pr2dj
3407      INTEGER ::   ji, jj, jr
3408      INTEGER ::   ierr, itaille, ildi, ilei, iilb
3409      INTEGER ::   ijpj, ij, iproc, ipr2dj
3410      !
3411      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e
3412      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e
3413
3414      !!----------------------------------------------------------------------
3415      !
3416      ijpj=4
3417      IF( PRESENT(pr2dj) ) THEN           ! use of additional halos
3418         ipr2dj = pr2dj
3419      ELSE
3420         ipr2dj = 0
3421      ENDIF
3422      ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpi,4+2*ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) )
3423
3424      !
3425      ztab_e(:,:) = 0.e0
3426
3427      ij=0
3428      ! put in znorthloc_e the last 4 jlines of pt2d
3429      DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj
3430         ij = ij + 1
3431         DO ji = 1, jpi
3432            znorthloc_e(ji,ij)=pt2d(ji,jj)
3433         END DO
3434      END DO
3435      !
3436      itaille = jpi * ( ijpj + 2 * ipr2dj )
3437      CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    &
3438         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
3439      !
3440      DO jr = 1, ndim_rank_north            ! recover the global north array
3441         iproc = nrank_north(jr) + 1
3442         ildi = nldit (iproc)
3443         ilei = nleit (iproc)
3444         iilb = nimppt(iproc)
3445         DO jj = 1, ijpj+2*ipr2dj
3446            DO ji = ildi, ilei
3447               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
3448            END DO
3449         END DO
3450      END DO
3451
3452
3453      ! 2. North-Fold boundary conditions
3454      ! ----------------------------------
3455      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj )
3456
3457      ij = ipr2dj
3458      !! Scatter back to pt2d
3459      DO jj = nlcj - ijpj + 1 , nlcj +ipr2dj
3460      ij  = ij +1
3461         DO ji= 1, nlci
3462            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
3463         END DO
3464      END DO
3465      !
3466      DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
3467      !
3468   END SUBROUTINE mpp_lbc_north_icb
3469
3470   SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj )
3471      !!----------------------------------------------------------------------
3472      !!                  ***  routine mpp_lnk_2d_icb  ***
3473      !!
3474      !! ** Purpose :   Message passing manadgement for 2d array (with extra halo and icebergs)
3475      !!
3476      !! ** Method  :   Use mppsend and mpprecv function for passing mask
3477      !!      between processors following neighboring subdomains.
3478      !!            domain parameters
3479      !!                    nlci   : first dimension of the local subdomain
3480      !!                    nlcj   : second dimension of the local subdomain
3481      !!                    jpri   : number of rows for extra outer halo
3482      !!                    jprj   : number of columns for extra outer halo
3483      !!                    nbondi : mark for "east-west local boundary"
3484      !!                    nbondj : mark for "north-south local boundary"
3485      !!                    noea   : number for local neighboring processors
3486      !!                    nowe   : number for local neighboring processors
3487      !!                    noso   : number for local neighboring processors
3488      !!                    nono   : number for local neighboring processors
3489      !!
3490      !!----------------------------------------------------------------------
3491      INTEGER                                             , INTENT(in   ) ::   jpri
3492      INTEGER                                             , INTENT(in   ) ::   jprj
3493      REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
3494      CHARACTER(len=1)                                    , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points
3495      !                                                                                 ! = T , U , V , F , W and I points
3496      REAL(wp)                                            , INTENT(in   ) ::   psgn     ! =-1 the sign change across the
3497      !!                                                                                ! north boundary, =  1. otherwise
3498      INTEGER  ::   jl   ! dummy loop indices
3499      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
3500      INTEGER  ::   ipreci, iprecj             ! temporary integers
3501      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
3502      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
3503      !!
3504      REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns
3505      REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn
3506      REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe
3507      REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew
3508      !!----------------------------------------------------------------------
3509
3510      ipreci = jpreci + jpri      ! take into account outer extra 2D overlap area
3511      iprecj = jprecj + jprj
3512
3513
3514      ! 1. standard boundary treatment
3515      ! ------------------------------
3516      ! Order matters Here !!!!
3517      !
3518      !                                      ! East-West boundaries
3519      !                                           !* Cyclic east-west
3520      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
3521         pt2d(1-jpri:     1    ,:) = pt2d(jpim1-jpri:  jpim1 ,:)       ! east
3522         pt2d(   jpi  :jpi+jpri,:) = pt2d(     2      :2+jpri,:)       ! west
3523         !
3524      ELSE                                        !* closed
3525         IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0.e0    ! south except at F-point
3526                                      pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0    ! north
3527      ENDIF
3528      !
3529
3530      ! north fold treatment
3531      ! -----------------------
3532      IF( npolj /= 0 ) THEN
3533         !
3534         SELECT CASE ( jpni )
3535         CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )
3536         CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj)  , cd_type, psgn , pr2dj=jprj  )
3537         END SELECT
3538         !
3539      ENDIF
3540
3541      ! 2. East and west directions exchange
3542      ! ------------------------------------
3543      ! we play with the neigbours AND the row number because of the periodicity
3544      !
3545      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
3546      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
3547         iihom = nlci-nreci-jpri
3548         DO jl = 1, ipreci
3549            r2dew(:,jl,1) = pt2d(jpreci+jl,:)
3550            r2dwe(:,jl,1) = pt2d(iihom +jl,:)
3551         END DO
3552      END SELECT
3553      !
3554      !                           ! Migrations
3555      imigr = ipreci * ( jpj + 2*jprj)
3556      !
3557      SELECT CASE ( nbondi )
3558      CASE ( -1 )
3559         CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 )
3560         CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
3561         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3562      CASE ( 0 )
3563         CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
3564         CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 )
3565         CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
3566         CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
3567         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3568         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
3569      CASE ( 1 )
3570         CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
3571         CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
3572         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3573      END SELECT
3574      !
3575      !                           ! Write Dirichlet lateral conditions
3576      iihom = nlci - jpreci
3577      !
3578      SELECT CASE ( nbondi )
3579      CASE ( -1 )
3580         DO jl = 1, ipreci
3581            pt2d(iihom+jl,:) = r2dew(:,jl,2)
3582         END DO
3583      CASE ( 0 )
3584         DO jl = 1, ipreci
3585            pt2d(jl-jpri,:) = r2dwe(:,jl,2)
3586            pt2d( iihom+jl,:) = r2dew(:,jl,2)
3587         END DO
3588      CASE ( 1 )
3589         DO jl = 1, ipreci
3590            pt2d(jl-jpri,:) = r2dwe(:,jl,2)
3591         END DO
3592      END SELECT
3593
3594
3595      ! 3. North and south directions
3596      ! -----------------------------
3597      ! always closed : we play only with the neigbours
3598      !
3599      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
3600         ijhom = nlcj-nrecj-jprj
3601         DO jl = 1, iprecj
3602            r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
3603            r2dns(:,jl,1) = pt2d(:,jprecj+jl)
3604         END DO
3605      ENDIF
3606      !
3607      !                           ! Migrations
3608      imigr = iprecj * ( jpi + 2*jpri )
3609      !
3610      SELECT CASE ( nbondj )
3611      CASE ( -1 )
3612         CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 )
3613         CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
3614         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3615      CASE ( 0 )
3616         CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
3617         CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 )
3618         CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
3619         CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
3620         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3621         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
3622      CASE ( 1 )
3623         CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
3624         CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
3625         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3626      END SELECT
3627      !
3628      !                           ! Write Dirichlet lateral conditions
3629      ijhom = nlcj - jprecj
3630      !
3631      SELECT CASE ( nbondj )
3632      CASE ( -1 )
3633         DO jl = 1, iprecj
3634            pt2d(:,ijhom+jl) = r2dns(:,jl,2)
3635         END DO
3636      CASE ( 0 )
3637         DO jl = 1, iprecj
3638            pt2d(:,jl-jprj) = r2dsn(:,jl,2)
3639            pt2d(:,ijhom+jl ) = r2dns(:,jl,2)
3640         END DO
3641      CASE ( 1 )
3642         DO jl = 1, iprecj
3643            pt2d(:,jl-jprj) = r2dsn(:,jl,2)
3644         END DO
3645      END SELECT
3646
3647   END SUBROUTINE mpp_lnk_2d_icb
3648#else
3649   !!----------------------------------------------------------------------
3650   !!   Default case:            Dummy module        share memory computing
3651   !!----------------------------------------------------------------------
3652   USE in_out_manager
3653
3654   INTERFACE mpp_sum
3655      MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i, mppsum_realdd, mppsum_a_realdd
3656   END INTERFACE
3657   INTERFACE mpp_max
3658      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
3659   END INTERFACE
3660   INTERFACE mpp_min
3661      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
3662   END INTERFACE
3663   INTERFACE mpp_minloc
3664      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
3665   END INTERFACE
3666   INTERFACE mpp_maxloc
3667      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
3668   END INTERFACE
3669
3670   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag
3671   LOGICAL, PUBLIC            ::   ln_nnogather          !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used)
3672   INTEGER :: ncomm_ice
3673   INTEGER, PUBLIC            ::   mpi_comm_opa          ! opa local communicator
3674   !!----------------------------------------------------------------------
3675CONTAINS
3676
3677   INTEGER FUNCTION lib_mpp_alloc(kumout)          ! Dummy function
3678      INTEGER, INTENT(in) ::   kumout
3679      lib_mpp_alloc = 0
3680   END FUNCTION lib_mpp_alloc
3681
3682   FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg,  kumond , kstop, localComm ) RESULT (function_value)
3683      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm
3684      CHARACTER(len=*),DIMENSION(:) ::   ldtxt
3685      CHARACTER(len=*) ::   ldname
3686      INTEGER ::   kumnam_ref, knumnam_cfg , kumond , kstop
3687      IF( PRESENT( localComm ) ) mpi_comm_opa = localComm
3688      function_value = 0
3689      IF( .FALSE. )   ldtxt(:) = 'never done'
3690      CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )
3691   END FUNCTION mynode
3692
3693   SUBROUTINE mppsync                       ! Dummy routine
3694   END SUBROUTINE mppsync
3695
3696   SUBROUTINE mpp_sum_as( parr, kdim, kcom )      ! Dummy routine
3697      REAL   , DIMENSION(:) :: parr
3698      INTEGER               :: kdim
3699      INTEGER, OPTIONAL     :: kcom
3700      WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
3701   END SUBROUTINE mpp_sum_as
3702
3703   SUBROUTINE mpp_sum_a2s( parr, kdim, kcom )      ! Dummy routine
3704      REAL   , DIMENSION(:,:) :: parr
3705      INTEGER               :: kdim
3706      INTEGER, OPTIONAL     :: kcom
3707      WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
3708   END SUBROUTINE mpp_sum_a2s
3709
3710   SUBROUTINE mpp_sum_ai( karr, kdim, kcom )      ! Dummy routine
3711      INTEGER, DIMENSION(:) :: karr
3712      INTEGER               :: kdim
3713      INTEGER, OPTIONAL     :: kcom
3714      WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
3715   END SUBROUTINE mpp_sum_ai
3716
3717   SUBROUTINE mpp_sum_s( psca, kcom )            ! Dummy routine
3718      REAL                  :: psca
3719      INTEGER, OPTIONAL     :: kcom
3720      WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
3721   END SUBROUTINE mpp_sum_s
3722
3723   SUBROUTINE mpp_sum_i( kint, kcom )            ! Dummy routine
3724      integer               :: kint
3725      INTEGER, OPTIONAL     :: kcom
3726      WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
3727   END SUBROUTINE mpp_sum_i
3728
3729   SUBROUTINE mppsum_realdd( ytab, kcom )
3730      COMPLEX(wp), INTENT(inout)         :: ytab    ! input scalar
3731      INTEGER , INTENT( in  ), OPTIONAL :: kcom
3732      WRITE(*,*) 'mppsum_realdd: You should not have seen this print! error?', ytab
3733   END SUBROUTINE mppsum_realdd
3734
3735   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
3736      INTEGER , INTENT( in )                        ::   kdim      ! size of ytab
3737      COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) ::   ytab      ! input array
3738      INTEGER , INTENT( in  ), OPTIONAL :: kcom
3739      WRITE(*,*) 'mppsum_a_realdd: You should not have seen this print! error?', kdim, ytab(1), kcom
3740   END SUBROUTINE mppsum_a_realdd
3741
3742   SUBROUTINE mppmax_a_real( parr, kdim, kcom )
3743      REAL   , DIMENSION(:) :: parr
3744      INTEGER               :: kdim
3745      INTEGER, OPTIONAL     :: kcom
3746      WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
3747   END SUBROUTINE mppmax_a_real
3748
3749   SUBROUTINE mppmax_real( psca, kcom )
3750      REAL                  :: psca
3751      INTEGER, OPTIONAL     :: kcom
3752      WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca, kcom
3753   END SUBROUTINE mppmax_real
3754
3755   SUBROUTINE mppmin_a_real( parr, kdim, kcom )
3756      REAL   , DIMENSION(:) :: parr
3757      INTEGER               :: kdim
3758      INTEGER, OPTIONAL     :: kcom
3759      WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
3760   END SUBROUTINE mppmin_a_real
3761
3762   SUBROUTINE mppmin_real( psca, kcom )
3763      REAL                  :: psca
3764      INTEGER, OPTIONAL     :: kcom
3765      WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca, kcom
3766   END SUBROUTINE mppmin_real
3767
3768   SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
3769      INTEGER, DIMENSION(:) :: karr
3770      INTEGER               :: kdim
3771      INTEGER, OPTIONAL     :: kcom
3772      WRITE(*,*) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
3773   END SUBROUTINE mppmax_a_int
3774
3775   SUBROUTINE mppmax_int( kint, kcom)
3776      INTEGER               :: kint
3777      INTEGER, OPTIONAL     :: kcom
3778      WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint, kcom
3779   END SUBROUTINE mppmax_int
3780
3781   SUBROUTINE mppmin_a_int( karr, kdim, kcom )
3782      INTEGER, DIMENSION(:) :: karr
3783      INTEGER               :: kdim
3784      INTEGER, OPTIONAL     :: kcom
3785      WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
3786   END SUBROUTINE mppmin_a_int
3787
3788   SUBROUTINE mppmin_int( kint, kcom )
3789      INTEGER               :: kint
3790      INTEGER, OPTIONAL     :: kcom
3791      WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom
3792   END SUBROUTINE mppmin_int
3793
3794   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj )
3795      REAL                   :: pmin
3796      REAL , DIMENSION (:,:) :: ptab, pmask
3797      INTEGER :: ki, kj
3798      WRITE(*,*) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1)
3799   END SUBROUTINE mpp_minloc2d
3800
3801   SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk )
3802      REAL                     :: pmin
3803      REAL , DIMENSION (:,:,:) :: ptab, pmask
3804      INTEGER :: ki, kj, kk
3805      WRITE(*,*) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
3806   END SUBROUTINE mpp_minloc3d
3807
3808   SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
3809      REAL                   :: pmax
3810      REAL , DIMENSION (:,:) :: ptab, pmask
3811      INTEGER :: ki, kj
3812      WRITE(*,*) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1)
3813   END SUBROUTINE mpp_maxloc2d
3814
3815   SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
3816      REAL                     :: pmax
3817      REAL , DIMENSION (:,:,:) :: ptab, pmask
3818      INTEGER :: ki, kj, kk
3819      WRITE(*,*) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
3820   END SUBROUTINE mpp_maxloc3d
3821
3822   SUBROUTINE mppstop
3823      STOP      ! non MPP case, just stop the run
3824   END SUBROUTINE mppstop
3825
3826   SUBROUTINE mpp_ini_ice( kcom, knum )
3827      INTEGER :: kcom, knum
3828      WRITE(*,*) 'mpp_ini_ice: You should not have seen this print! error?', kcom, knum
3829   END SUBROUTINE mpp_ini_ice
3830
3831   SUBROUTINE mpp_ini_znl( knum )
3832      INTEGER :: knum
3833      WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum
3834   END SUBROUTINE mpp_ini_znl
3835
3836   SUBROUTINE mpp_comm_free( kcom )
3837      INTEGER :: kcom
3838      WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom
3839   END SUBROUTINE mpp_comm_free
3840#endif
3841
3842   !!----------------------------------------------------------------------
3843   !!   All cases:         ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam   routines
3844   !!----------------------------------------------------------------------
3845
3846   SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 ,   &
3847      &                 cd6, cd7, cd8, cd9, cd10 )
3848      !!----------------------------------------------------------------------
3849      !!                  ***  ROUTINE  stop_opa  ***
3850      !!
3851      !! ** Purpose :   print in ocean.outpput file a error message and
3852      !!                increment the error number (nstop) by one.
3853      !!----------------------------------------------------------------------
3854      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5
3855      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10
3856      !!----------------------------------------------------------------------
3857      !
3858      nstop = nstop + 1
3859      IF(lwp) THEN
3860         WRITE(numout,cform_err)
3861         IF( PRESENT(cd1 ) )   WRITE(numout,*) cd1
3862         IF( PRESENT(cd2 ) )   WRITE(numout,*) cd2
3863         IF( PRESENT(cd3 ) )   WRITE(numout,*) cd3
3864         IF( PRESENT(cd4 ) )   WRITE(numout,*) cd4
3865         IF( PRESENT(cd5 ) )   WRITE(numout,*) cd5
3866         IF( PRESENT(cd6 ) )   WRITE(numout,*) cd6
3867         IF( PRESENT(cd7 ) )   WRITE(numout,*) cd7
3868         IF( PRESENT(cd8 ) )   WRITE(numout,*) cd8
3869         IF( PRESENT(cd9 ) )   WRITE(numout,*) cd9
3870         IF( PRESENT(cd10) )   WRITE(numout,*) cd10
3871      ENDIF
3872                               CALL FLUSH(numout    )
3873      IF( numstp     /= -1 )   CALL FLUSH(numstp    )
3874      IF( numsol     /= -1 )   CALL FLUSH(numsol    )
3875      IF( numevo_ice /= -1 )   CALL FLUSH(numevo_ice)
3876      !
3877      IF( cd1 == 'STOP' ) THEN
3878         IF(lwp) WRITE(numout,*)  'huge E-R-R-O-R : immediate stop'
3879         CALL mppstop()
3880      ENDIF
3881      !
3882   END SUBROUTINE ctl_stop
3883
3884
3885   SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5,   &
3886      &                 cd6, cd7, cd8, cd9, cd10 )
3887      !!----------------------------------------------------------------------
3888      !!                  ***  ROUTINE  stop_warn  ***
3889      !!
3890      !! ** Purpose :   print in ocean.outpput file a error message and
3891      !!                increment the warning number (nwarn) by one.
3892      !!----------------------------------------------------------------------
3893      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5
3894      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10
3895      !!----------------------------------------------------------------------
3896      !
3897      nwarn = nwarn + 1
3898      IF(lwp) THEN
3899         WRITE(numout,cform_war)
3900         IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
3901         IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
3902         IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
3903         IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
3904         IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
3905         IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
3906         IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
3907         IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
3908         IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
3909         IF( PRESENT(cd10) ) WRITE(numout,*) cd10
3910      ENDIF
3911      CALL FLUSH(numout)
3912      !
3913   END SUBROUTINE ctl_warn
3914
3915
3916   SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea )
3917      !!----------------------------------------------------------------------
3918      !!                  ***  ROUTINE ctl_opn  ***
3919      !!
3920      !! ** Purpose :   Open file and check if required file is available.
3921      !!
3922      !! ** Method  :   Fortan open
3923      !!----------------------------------------------------------------------
3924      INTEGER          , INTENT(  out) ::   knum      ! logical unit to open
3925      CHARACTER(len=*) , INTENT(in   ) ::   cdfile    ! file name to open
3926      CHARACTER(len=*) , INTENT(in   ) ::   cdstat    ! disposition specifier
3927      CHARACTER(len=*) , INTENT(in   ) ::   cdform    ! formatting specifier
3928      CHARACTER(len=*) , INTENT(in   ) ::   cdacce    ! access specifier
3929      INTEGER          , INTENT(in   ) ::   klengh    ! record length
3930      INTEGER          , INTENT(in   ) ::   kout      ! number of logical units for write
3931      LOGICAL          , INTENT(in   ) ::   ldwp      ! boolean term for print
3932      INTEGER, OPTIONAL, INTENT(in   ) ::   karea     ! proc number
3933      !!
3934      CHARACTER(len=80) ::   clfile
3935      INTEGER           ::   iost
3936      !!----------------------------------------------------------------------
3937
3938      ! adapt filename
3939      ! ----------------
3940      clfile = TRIM(cdfile)
3941      IF( PRESENT( karea ) ) THEN
3942         IF( karea > 1 )   WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1
3943      ENDIF
3944#if defined key_agrif
3945      IF( .NOT. Agrif_Root() )   clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile)
3946      knum=Agrif_Get_Unit()
3947#else
3948      knum=get_unit()
3949#endif
3950
3951      iost=0
3952      IF( cdacce(1:6) == 'DIRECT' )  THEN
3953         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh, ERR=100, IOSTAT=iost )
3954      ELSE
3955         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat             , ERR=100, IOSTAT=iost )
3956      ENDIF
3957      IF( iost == 0 ) THEN
3958         IF(ldwp) THEN
3959            WRITE(kout,*) '     file   : ', clfile,' open ok'
3960            WRITE(kout,*) '     unit   = ', knum
3961            WRITE(kout,*) '     status = ', cdstat
3962            WRITE(kout,*) '     form   = ', cdform
3963            WRITE(kout,*) '     access = ', cdacce
3964            WRITE(kout,*)
3965         ENDIF
3966      ENDIF
3967100   CONTINUE
3968      IF( iost /= 0 ) THEN
3969         IF(ldwp) THEN
3970            WRITE(kout,*)
3971            WRITE(kout,*) ' ===>>>> : bad opening file: ', clfile
3972            WRITE(kout,*) ' =======   ===  '
3973            WRITE(kout,*) '           unit   = ', knum
3974            WRITE(kout,*) '           status = ', cdstat
3975            WRITE(kout,*) '           form   = ', cdform
3976            WRITE(kout,*) '           access = ', cdacce
3977            WRITE(kout,*) '           iostat = ', iost
3978            WRITE(kout,*) '           we stop. verify the file '
3979            WRITE(kout,*)
3980         ENDIF
3981         STOP 'ctl_opn bad opening'
3982      ENDIF
3983
3984   END SUBROUTINE ctl_opn
3985
3986   SUBROUTINE ctl_nam ( kios, cdnam, ldwp )
3987      !!----------------------------------------------------------------------
3988      !!                  ***  ROUTINE ctl_nam  ***
3989      !!
3990      !! ** Purpose :   Informations when error while reading a namelist
3991      !!
3992      !! ** Method  :   Fortan open
3993      !!----------------------------------------------------------------------
3994      INTEGER          , INTENT(inout) ::   kios      ! IO status after reading the namelist
3995      CHARACTER(len=*) , INTENT(in   ) ::   cdnam     ! group name of namelist for which error occurs
3996      CHARACTER(len=4)                 ::   clios     ! string to convert iostat in character for print
3997      LOGICAL          , INTENT(in   ) ::   ldwp      ! boolean term for print
3998      !!----------------------------------------------------------------------
3999
4000      !
4001      ! ----------------
4002      WRITE (clios, '(I4.0)') kios
4003      IF( kios < 0 ) THEN         
4004         CALL ctl_warn( 'W A R N I N G:  end of record or file while reading namelist ' &
4005 &           // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
4006      ENDIF
4007
4008      IF( kios > 0 ) THEN
4009         CALL ctl_stop( 'E R R O R :   misspelled variable in namelist ' &
4010 &           // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
4011      ENDIF
4012      kios = 0
4013      RETURN
4014     
4015   END SUBROUTINE ctl_nam
4016
4017   INTEGER FUNCTION get_unit()
4018      !!----------------------------------------------------------------------
4019      !!                  ***  FUNCTION  get_unit  ***
4020      !!
4021      !! ** Purpose :   return the index of an unused logical unit
4022      !!----------------------------------------------------------------------
4023      LOGICAL :: llopn
4024      !!----------------------------------------------------------------------
4025      !
4026      get_unit = 15   ! choose a unit that is big enough then it is not already used in NEMO
4027      llopn = .TRUE.
4028      DO WHILE( (get_unit < 998) .AND. llopn )
4029         get_unit = get_unit + 1
4030         INQUIRE( unit = get_unit, opened = llopn )
4031      END DO
4032      IF( (get_unit == 999) .AND. llopn ) THEN
4033         CALL ctl_stop(<