source: NEMO/branches/UKMO/r8395_coupling_sequence/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 10764

Last change on this file since 10764 was 10764, checked in by jcastill, 23 months ago

Minimal set of changes for coupling order

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