source: branches/2017/dev_r7832_HPC08_lbclnk_3rd_dim/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 7897

Last change on this file since 7897 was 7897, checked in by gm, 3 years ago

#1880: (HPC-08) 3D lbc_lnk with any 3rd dim + regroup global comm in stpctl.F90

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