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

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

#1880: (HPC-08) minor corrections

  • Property svn:keywords set to Id
File size: 187.1 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      ELSEIF ( 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 pt2d 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 pt2d 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 pt2d 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      REAL(wp), DIMENSION(kdim), INTENT(inout) ::   ptab
1992      INTEGER                  , INTENT(in   ) ::   kdim
1993      INTEGER , OPTIONAL       , INTENT(in   ) ::   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      REAL(wp), DIMENSION(kdim) ::  zwork
2044      !!----------------------------------------------------------------------
2045      !
2046      localcomm = mpi_comm_opa
2047      IF( PRESENT(kcom) )   localcomm = kcom
2048      !
2049      CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror )
2050      pt1d(:) = zwork(:)
2051      !
2052   END SUBROUTINE mppmax_real_multiple
2053
2054
2055   SUBROUTINE mppmin_a_real( ptab, kdim, kcom )
2056      !!----------------------------------------------------------------------
2057      !!                 ***  routine mppmin_a_real  ***
2058      !!
2059      !! ** Purpose :   Minimum of REAL, array case
2060      !!
2061      !!-----------------------------------------------------------------------
2062      INTEGER , INTENT(in   )                  ::   kdim
2063      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab
2064      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom
2065      !!
2066      INTEGER :: ierror, localcomm
2067      REAL(wp), DIMENSION(kdim) ::   zwork
2068      !!-----------------------------------------------------------------------
2069      !
2070      localcomm = mpi_comm_opa
2071      IF( PRESENT(kcom) ) localcomm = kcom
2072      !
2073      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror )
2074      ptab(:) = zwork(:)
2075      !
2076   END SUBROUTINE mppmin_a_real
2077
2078
2079   SUBROUTINE mppmin_real( ptab, kcom )
2080      !!----------------------------------------------------------------------
2081      !!                  ***  routine mppmin_real  ***
2082      !!
2083      !! ** Purpose :   minimum of REAL, scalar case
2084      !!
2085      !!-----------------------------------------------------------------------
2086      REAL(wp), INTENT(inout)           ::   ptab        !
2087      INTEGER , INTENT(in   ), OPTIONAL :: kcom
2088      !!
2089      INTEGER  ::   ierror
2090      REAL(wp) ::   zwork
2091      INTEGER :: localcomm
2092      !!-----------------------------------------------------------------------
2093      !
2094      localcomm = mpi_comm_opa
2095      IF( PRESENT(kcom) )   localcomm = kcom
2096      !
2097      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror )
2098      ptab = zwork
2099      !
2100   END SUBROUTINE mppmin_real
2101
2102
2103   SUBROUTINE mppsum_a_real( ptab, kdim, kcom )
2104      !!----------------------------------------------------------------------
2105      !!                  ***  routine mppsum_a_real  ***
2106      !!
2107      !! ** Purpose :   global sum, REAL ARRAY argument case
2108      !!
2109      !!-----------------------------------------------------------------------
2110      INTEGER , INTENT( in )                     ::   kdim      ! size of ptab
2111      REAL(wp), DIMENSION(kdim), INTENT( inout ) ::   ptab      ! input array
2112      INTEGER , INTENT( in ), OPTIONAL           :: kcom
2113      !!
2114      INTEGER                   ::   ierror    ! temporary integer
2115      INTEGER                   ::   localcomm
2116      REAL(wp), DIMENSION(kdim) ::   zwork     ! temporary workspace
2117      !!-----------------------------------------------------------------------
2118      !
2119      localcomm = mpi_comm_opa
2120      IF( PRESENT(kcom) )   localcomm = kcom
2121      !
2122      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror )
2123      ptab(:) = zwork(:)
2124      !
2125   END SUBROUTINE mppsum_a_real
2126
2127
2128   SUBROUTINE mppsum_real( ptab, kcom )
2129      !!----------------------------------------------------------------------
2130      !!                  ***  routine mppsum_real  ***
2131      !!
2132      !! ** Purpose :   global sum, SCALAR argument case
2133      !!
2134      !!-----------------------------------------------------------------------
2135      REAL(wp), INTENT(inout)           ::   ptab   ! input scalar
2136      INTEGER , INTENT(in   ), OPTIONAL ::   kcom
2137      !!
2138      INTEGER  ::   ierror, localcomm
2139      REAL(wp) ::   zwork
2140      !!-----------------------------------------------------------------------
2141      !
2142      localcomm = mpi_comm_opa
2143      IF( PRESENT(kcom) ) localcomm = kcom
2144      !
2145      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror )
2146      ptab = zwork
2147      !
2148   END SUBROUTINE mppsum_real
2149
2150
2151   SUBROUTINE mppsum_realdd( ytab, kcom )
2152      !!----------------------------------------------------------------------
2153      !!                  ***  routine mppsum_realdd ***
2154      !!
2155      !! ** Purpose :   global sum in Massively Parallel Processing
2156      !!                SCALAR argument case for double-double precision
2157      !!
2158      !!-----------------------------------------------------------------------
2159      COMPLEX(wp), INTENT(inout)           ::   ytab    ! input scalar
2160      INTEGER    , INTENT(in   ), OPTIONAL ::   kcom
2161      !
2162      INTEGER     ::   ierror
2163      INTEGER     ::   localcomm
2164      COMPLEX(wp) ::   zwork
2165      !!-----------------------------------------------------------------------
2166      !
2167      localcomm = mpi_comm_opa
2168      IF( PRESENT(kcom) )   localcomm = kcom
2169      !
2170      ! reduce local sums into global sum
2171      CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror )
2172      ytab = zwork
2173      !
2174   END SUBROUTINE mppsum_realdd
2175
2176
2177   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
2178      !!----------------------------------------------------------------------
2179      !!                  ***  routine mppsum_a_realdd  ***
2180      !!
2181      !! ** Purpose :   global sum in Massively Parallel Processing
2182      !!                COMPLEX ARRAY case for double-double precision
2183      !!
2184      !!-----------------------------------------------------------------------
2185      INTEGER                     , INTENT(in   ) ::   kdim   ! size of ytab
2186      COMPLEX(wp), DIMENSION(kdim), INTENT(inout) ::   ytab   ! input array
2187      INTEGER    , OPTIONAL       , INTENT(in   ) ::   kcom
2188      !
2189      INTEGER:: ierror, localcomm    ! local integer
2190      COMPLEX(wp), DIMENSION(kdim) :: zwork     ! temporary workspace
2191      !!-----------------------------------------------------------------------
2192      !
2193      localcomm = mpi_comm_opa
2194      IF( PRESENT(kcom) )   localcomm = kcom
2195      !
2196      CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror )
2197      ytab(:) = zwork(:)
2198      !
2199   END SUBROUTINE mppsum_a_realdd
2200
2201
2202   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj )
2203      !!------------------------------------------------------------------------
2204      !!             ***  routine mpp_minloc  ***
2205      !!
2206      !! ** Purpose :   Compute the global minimum of an array ptab
2207      !!              and also give its global position
2208      !!
2209      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
2210      !!
2211      !!--------------------------------------------------------------------------
2212      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   ptab    ! Local 2D array
2213      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask   ! Local mask
2214      REAL(wp)                     , INTENT(  out) ::   pmin    ! Global minimum of ptab
2215      INTEGER                      , INTENT(  out) ::   ki, kj  ! index of minimum in global frame
2216      !
2217      INTEGER :: ierror
2218      INTEGER , DIMENSION(2)   ::   ilocs
2219      REAL(wp) ::   zmin   ! local minimum
2220      REAL(wp), DIMENSION(2,1) ::   zain, zaout
2221      !!-----------------------------------------------------------------------
2222      !
2223      zmin  = MINVAL( ptab(:,:) , mask= pmask == 1._wp )
2224      ilocs = MINLOC( ptab(:,:) , mask= pmask == 1._wp )
2225      !
2226      ki = ilocs(1) + nimpp - 1
2227      kj = ilocs(2) + njmpp - 1
2228      !
2229      zain(1,:)=zmin
2230      zain(2,:)=ki+10000.*kj
2231      !
2232      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
2233      !
2234      pmin = zaout(1,1)
2235      kj = INT(zaout(2,1)/10000.)
2236      ki = INT(zaout(2,1) - 10000.*kj )
2237      !
2238   END SUBROUTINE mpp_minloc2d
2239
2240
2241   SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj ,kk)
2242      !!------------------------------------------------------------------------
2243      !!             ***  routine mpp_minloc  ***
2244      !!
2245      !! ** Purpose :   Compute the global minimum of an array ptab
2246      !!              and also give its global position
2247      !!
2248      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
2249      !!
2250      !!--------------------------------------------------------------------------
2251      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   ptab         ! Local 2D array
2252      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pmask        ! Local mask
2253      REAL(wp)                  , INTENT(  out) ::   pmin         ! Global minimum of ptab
2254      INTEGER                   , INTENT(  out) ::   ki, kj, kk   ! index of minimum in global frame
2255      !
2256      INTEGER  ::   ierror
2257      REAL(wp) ::   zmin     ! local minimum
2258      INTEGER , DIMENSION(3)   ::   ilocs
2259      REAL(wp), DIMENSION(2,1) ::   zain, zaout
2260      !!-----------------------------------------------------------------------
2261      !
2262      zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1._wp )
2263      ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1._wp )
2264      !
2265      ki = ilocs(1) + nimpp - 1
2266      kj = ilocs(2) + njmpp - 1
2267      kk = ilocs(3)
2268      !
2269      zain(1,:) = zmin
2270      zain(2,:) = ki + 10000.*kj + 100000000.*kk
2271      !
2272      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
2273      !
2274      pmin = zaout(1,1)
2275      kk   = INT( zaout(2,1) / 100000000. )
2276      kj   = INT( zaout(2,1) - kk * 100000000. ) / 10000
2277      ki   = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
2278      !
2279   END SUBROUTINE mpp_minloc3d
2280
2281
2282   SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
2283      !!------------------------------------------------------------------------
2284      !!             ***  routine mpp_maxloc  ***
2285      !!
2286      !! ** Purpose :   Compute the global maximum of an array ptab
2287      !!              and also give its global position
2288      !!
2289      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
2290      !!
2291      !!--------------------------------------------------------------------------
2292      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   ptab     ! Local 2D array
2293      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask    ! Local mask
2294      REAL(wp)                     , INTENT(  out) ::   pmax     ! Global maximum of ptab
2295      INTEGER                      , INTENT(  out) ::   ki, kj   ! index of maximum in global frame
2296      !!
2297      INTEGER  :: ierror
2298      INTEGER, DIMENSION (2)   ::   ilocs
2299      REAL(wp) :: zmax   ! local maximum
2300      REAL(wp), DIMENSION(2,1) ::   zain, zaout
2301      !!-----------------------------------------------------------------------
2302      !
2303      zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1._wp )
2304      ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1._wp )
2305      !
2306      ki = ilocs(1) + nimpp - 1
2307      kj = ilocs(2) + njmpp - 1
2308      !
2309      zain(1,:) = zmax
2310      zain(2,:) = ki + 10000. * kj
2311      !
2312      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
2313      !
2314      pmax = zaout(1,1)
2315      kj   = INT( zaout(2,1) / 10000.     )
2316      ki   = INT( zaout(2,1) - 10000.* kj )
2317      !
2318   END SUBROUTINE mpp_maxloc2d
2319
2320
2321   SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
2322      !!------------------------------------------------------------------------
2323      !!             ***  routine mpp_maxloc  ***
2324      !!
2325      !! ** Purpose :  Compute the global maximum of an array ptab
2326      !!              and also give its global position
2327      !!
2328      !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
2329      !!
2330      !!--------------------------------------------------------------------------
2331      REAL(wp), DIMENSION (:,:,:), INTENT(in   ) ::   ptab         ! Local 2D array
2332      REAL(wp), DIMENSION (:,:,:), INTENT(in   ) ::   pmask        ! Local mask
2333      REAL(wp)                   , INTENT(  out) ::   pmax         ! Global maximum of ptab
2334      INTEGER                    , INTENT(  out) ::   ki, kj, kk   ! index of maximum in global frame
2335      !
2336      INTEGER  ::   ierror   ! local integer
2337      REAL(wp) ::   zmax     ! local maximum
2338      REAL(wp), DIMENSION(2,1) ::   zain, zaout
2339      INTEGER , DIMENSION(3)   ::   ilocs
2340      !!-----------------------------------------------------------------------
2341      !
2342      zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1._wp )
2343      ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1._wp )
2344      !
2345      ki = ilocs(1) + nimpp - 1
2346      kj = ilocs(2) + njmpp - 1
2347      kk = ilocs(3)
2348      !
2349      zain(1,:) = zmax
2350      zain(2,:) = ki + 10000.*kj + 100000000.*kk
2351      !
2352      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
2353      !
2354      pmax = zaout(1,1)
2355      kk   = INT( zaout(2,1) / 100000000. )
2356      kj   = INT( zaout(2,1) - kk * 100000000. ) / 10000
2357      ki   = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
2358      !
2359   END SUBROUTINE mpp_maxloc3d
2360
2361
2362   SUBROUTINE mppsync()
2363      !!----------------------------------------------------------------------
2364      !!                  ***  routine mppsync  ***
2365      !!
2366      !! ** Purpose :   Massively parallel processors, synchroneous
2367      !!
2368      !!-----------------------------------------------------------------------
2369      INTEGER :: ierror
2370      !!-----------------------------------------------------------------------
2371      !
2372      CALL mpi_barrier( mpi_comm_opa, ierror )
2373      !
2374   END SUBROUTINE mppsync
2375
2376
2377   SUBROUTINE mppstop
2378      !!----------------------------------------------------------------------
2379      !!                  ***  routine mppstop  ***
2380      !!
2381      !! ** purpose :   Stop massively parallel processors method
2382      !!
2383      !!----------------------------------------------------------------------
2384      INTEGER ::   info
2385      !!----------------------------------------------------------------------
2386      !
2387      CALL mppsync
2388      CALL mpi_finalize( info )
2389      !
2390   END SUBROUTINE mppstop
2391
2392
2393   SUBROUTINE mpp_comm_free( kcom )
2394      !!----------------------------------------------------------------------
2395      INTEGER, INTENT(in) ::   kcom
2396      !!
2397      INTEGER :: ierr
2398      !!----------------------------------------------------------------------
2399      !
2400      CALL MPI_COMM_FREE(kcom, ierr)
2401      !
2402   END SUBROUTINE mpp_comm_free
2403
2404
2405   SUBROUTINE mpp_ini_ice( pindic, kumout )
2406      !!----------------------------------------------------------------------
2407      !!               ***  routine mpp_ini_ice  ***
2408      !!
2409      !! ** Purpose :   Initialize special communicator for ice areas
2410      !!      condition together with global variables needed in the ddmpp folding
2411      !!
2412      !! ** Method  : - Look for ice processors in ice routines
2413      !!              - Put their number in nrank_ice
2414      !!              - Create groups for the world processors and the ice processors
2415      !!              - Create a communicator for ice processors
2416      !!
2417      !! ** output
2418      !!      njmppmax = njmpp for northern procs
2419      !!      ndim_rank_ice = number of processors with ice
2420      !!      nrank_ice (ndim_rank_ice) = ice processors
2421      !!      ngrp_iworld = group ID for the world processors
2422      !!      ngrp_ice = group ID for the ice processors
2423      !!      ncomm_ice = communicator for the ice procs.
2424      !!      n_ice_root = number (in the world) of proc 0 in the ice comm.
2425      !!
2426      !!----------------------------------------------------------------------
2427      INTEGER, INTENT(in) ::   pindic
2428      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical unit
2429      !!
2430      INTEGER :: jjproc
2431      INTEGER :: ii, ierr
2432      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kice
2433      INTEGER, ALLOCATABLE, DIMENSION(:) ::   zwork
2434      !!----------------------------------------------------------------------
2435      !
2436      ! Since this is just an init routine and these arrays are of length jpnij
2437      ! then don't use wrk_nemo module - just allocate and deallocate.
2438      ALLOCATE( kice(jpnij), zwork(jpnij), STAT=ierr )
2439      IF( ierr /= 0 ) THEN
2440         WRITE(kumout, cform_err)
2441         WRITE(kumout,*) 'mpp_ini_ice : failed to allocate 2, 1D arrays (jpnij in length)'
2442         CALL mppstop
2443      ENDIF
2444
2445      ! Look for how many procs with sea-ice
2446      !
2447      kice = 0
2448      DO jjproc = 1, jpnij
2449         IF( jjproc == narea .AND. pindic .GT. 0 )   kice(jjproc) = 1
2450      END DO
2451      !
2452      zwork = 0
2453      CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_opa, ierr )
2454      ndim_rank_ice = SUM( zwork )
2455
2456      ! Allocate the right size to nrank_north
2457      IF( ALLOCATED ( nrank_ice ) )   DEALLOCATE( nrank_ice )
2458      ALLOCATE( nrank_ice(ndim_rank_ice) )
2459      !
2460      ii = 0
2461      nrank_ice = 0
2462      DO jjproc = 1, jpnij
2463         IF( zwork(jjproc) == 1) THEN
2464            ii = ii + 1
2465            nrank_ice(ii) = jjproc -1
2466         ENDIF
2467      END DO
2468
2469      ! Create the world group
2470      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_iworld, ierr )
2471
2472      ! Create the ice group from the world group
2473      CALL MPI_GROUP_INCL( ngrp_iworld, ndim_rank_ice, nrank_ice, ngrp_ice, ierr )
2474
2475      ! Create the ice communicator , ie the pool of procs with sea-ice
2476      CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_ice, ncomm_ice, ierr )
2477
2478      ! Find proc number in the world of proc 0 in the north
2479      ! The following line seems to be useless, we just comment & keep it as reminder
2480      ! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_iworld,n_ice_root,ierr)
2481      !
2482      CALL MPI_GROUP_FREE(ngrp_ice, ierr)
2483      CALL MPI_GROUP_FREE(ngrp_iworld, ierr)
2484
2485      DEALLOCATE(kice, zwork)
2486      !
2487   END SUBROUTINE mpp_ini_ice
2488
2489
2490   SUBROUTINE mpp_ini_znl( kumout )
2491      !!----------------------------------------------------------------------
2492      !!               ***  routine mpp_ini_znl  ***
2493      !!
2494      !! ** Purpose :   Initialize special communicator for computing zonal sum
2495      !!
2496      !! ** Method  : - Look for processors in the same row
2497      !!              - Put their number in nrank_znl
2498      !!              - Create group for the znl processors
2499      !!              - Create a communicator for znl processors
2500      !!              - Determine if processor should write znl files
2501      !!
2502      !! ** output
2503      !!      ndim_rank_znl = number of processors on the same row
2504      !!      ngrp_znl = group ID for the znl processors
2505      !!      ncomm_znl = communicator for the ice procs.
2506      !!      n_znl_root = number (in the world) of proc 0 in the ice comm.
2507      !!
2508      !!----------------------------------------------------------------------
2509      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical units
2510      !
2511      INTEGER :: jproc      ! dummy loop integer
2512      INTEGER :: ierr, ii   ! local integer
2513      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kwork
2514      !!----------------------------------------------------------------------
2515      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world     : ', ngrp_world
2516      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
2517      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_opa   : ', mpi_comm_opa
2518      !
2519      ALLOCATE( kwork(jpnij), STAT=ierr )
2520      IF( ierr /= 0 ) THEN
2521         WRITE(kumout, cform_err)
2522         WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij'
2523         CALL mppstop
2524      ENDIF
2525
2526      IF( jpnj == 1 ) THEN
2527         ngrp_znl  = ngrp_world
2528         ncomm_znl = mpi_comm_opa
2529      ELSE
2530         !
2531         CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_opa, ierr )
2532         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
2533         !-$$        CALL flush(numout)
2534         !
2535         ! Count number of processors on the same row
2536         ndim_rank_znl = 0
2537         DO jproc=1,jpnij
2538            IF ( kwork(jproc) == njmpp ) THEN
2539               ndim_rank_znl = ndim_rank_znl + 1
2540            ENDIF
2541         END DO
2542         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
2543         !-$$        CALL flush(numout)
2544         ! Allocate the right size to nrank_znl
2545         IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
2546         ALLOCATE(nrank_znl(ndim_rank_znl))
2547         ii = 0
2548         nrank_znl (:) = 0
2549         DO jproc=1,jpnij
2550            IF ( kwork(jproc) == njmpp) THEN
2551               ii = ii + 1
2552               nrank_znl(ii) = jproc -1
2553            ENDIF
2554         END DO
2555         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
2556         !-$$        CALL flush(numout)
2557
2558         ! Create the opa group
2559         CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_opa,ierr)
2560         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
2561         !-$$        CALL flush(numout)
2562
2563         ! Create the znl group from the opa group
2564         CALL MPI_GROUP_INCL  ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
2565         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
2566         !-$$        CALL flush(numout)
2567
2568         ! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
2569         CALL MPI_COMM_CREATE ( mpi_comm_opa, ngrp_znl, ncomm_znl, ierr )
2570         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
2571         !-$$        CALL flush(numout)
2572         !
2573      END IF
2574
2575      ! Determines if processor if the first (starting from i=1) on the row
2576      IF ( jpni == 1 ) THEN
2577         l_znl_root = .TRUE.
2578      ELSE
2579         l_znl_root = .FALSE.
2580         kwork (1) = nimpp
2581         CALL mpp_min ( kwork(1), kcom = ncomm_znl)
2582         IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
2583      END IF
2584
2585      DEALLOCATE(kwork)
2586
2587   END SUBROUTINE mpp_ini_znl
2588
2589
2590   SUBROUTINE mpp_ini_north
2591      !!----------------------------------------------------------------------
2592      !!               ***  routine mpp_ini_north  ***
2593      !!
2594      !! ** Purpose :   Initialize special communicator for north folding
2595      !!      condition together with global variables needed in the mpp folding
2596      !!
2597      !! ** Method  : - Look for northern processors
2598      !!              - Put their number in nrank_north
2599      !!              - Create groups for the world processors and the north processors
2600      !!              - Create a communicator for northern processors
2601      !!
2602      !! ** output
2603      !!      njmppmax = njmpp for northern procs
2604      !!      ndim_rank_north = number of processors in the northern line
2605      !!      nrank_north (ndim_rank_north) = number  of the northern procs.
2606      !!      ngrp_world = group ID for the world processors
2607      !!      ngrp_north = group ID for the northern processors
2608      !!      ncomm_north = communicator for the northern procs.
2609      !!      north_root = number (in the world) of proc 0 in the northern comm.
2610      !!
2611      !!----------------------------------------------------------------------
2612      INTEGER ::   ierr
2613      INTEGER ::   jjproc
2614      INTEGER ::   ii, ji
2615      !!----------------------------------------------------------------------
2616      !
2617      njmppmax = MAXVAL( njmppt )
2618      !
2619      ! Look for how many procs on the northern boundary
2620      ndim_rank_north = 0
2621      DO jjproc = 1, jpnij
2622         IF( njmppt(jjproc) == njmppmax )   ndim_rank_north = ndim_rank_north + 1
2623      END DO
2624      !
2625      ! Allocate the right size to nrank_north
2626      IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
2627      ALLOCATE( nrank_north(ndim_rank_north) )
2628
2629      ! Fill the nrank_north array with proc. number of northern procs.
2630      ! Note : the rank start at 0 in MPI
2631      ii = 0
2632      DO ji = 1, jpnij
2633         IF ( njmppt(ji) == njmppmax   ) THEN
2634            ii=ii+1
2635            nrank_north(ii)=ji-1
2636         END IF
2637      END DO
2638      !
2639      ! create the world group
2640      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
2641      !
2642      ! Create the North group from the world group
2643      CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
2644      !
2645      ! Create the North communicator , ie the pool of procs in the north group
2646      CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_north, ncomm_north, ierr )
2647      !
2648   END SUBROUTINE mpp_ini_north
2649
2650
2651   SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )
2652      !!---------------------------------------------------------------------
2653      !!                   ***  routine mpp_lbc_north_3d  ***
2654      !!
2655      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2656      !!              in mpp configuration in case of jpn1 > 1
2657      !!
2658      !! ** Method  :   North fold condition and mpp with more than one proc
2659      !!              in i-direction require a specific treatment. We gather
2660      !!              the 4 northern lines of the global domain on 1 processor
2661      !!              and apply lbc north-fold on this sub array. Then we
2662      !!              scatter the north fold array back to the processors.
2663      !!----------------------------------------------------------------------
2664      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the b.c. is applied
2665      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
2666      REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across the north fold
2667      !
2668      INTEGER ::   ji, jj, jr, jk
2669      INTEGER ::   ipk                  ! 3rd dimension of the input array
2670      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2671      INTEGER ::   ijpj, ijpjm1, ij, iproc
2672      INTEGER, DIMENSION (jpmaxngh)          ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather
2673      INTEGER                                ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
2674      INTEGER, DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
2675      !                                                              ! Workspace for message transfers avoiding mpi_allgather
2676      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab
2677      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk     
2678      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio
2679      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr
2680
2681      INTEGER :: istatus(mpi_status_size)
2682      INTEGER :: iflag
2683      !!----------------------------------------------------------------------
2684      !
2685      ipk = SIZE( pt3d, 3 )
2686      !
2687      ALLOCATE( ztab (jpiglo,4,ipk), znorthloc(jpi,4,ipk), zfoldwk(jpi,4,ipk), znorthgloio(jpi,4,ipk,jpni) )
2688      ALLOCATE( ztabl(jpi   ,4,ipk), ztabr(jpi*jpmaxngh,4,ipk)   ) 
2689
2690      ijpj   = 4
2691      ijpjm1 = 3
2692      !
2693      znorthloc(:,:,:) = 0._wp
2694      DO jk = 1, ipk
2695         DO jj = nlcj - ijpj +1, nlcj          ! put in xnorthloc the last 4 jlines of pt3d
2696            ij = jj - nlcj + ijpj
2697            znorthloc(:,ij,jk) = pt3d(:,jj,jk)
2698         END DO
2699      END DO
2700      !
2701      !                                     ! Build in procs of ncomm_north the znorthgloio
2702      itaille = jpi * ipk * ijpj
2703
2704      IF ( l_north_nogather ) THEN
2705         !
2706        ztabr(:,:,:) = 0._wp
2707        ztabl(:,:,:) = 0._wp
2708
2709        DO jk = 1, ipk
2710           DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array
2711              ij = jj - nlcj + ijpj
2712              DO ji = nfsloop, nfeloop
2713                 ztabl(ji,ij,jk) = pt3d(ji,jj,jk)
2714              END DO
2715           END DO
2716        END DO
2717
2718         DO jr = 1,nsndto
2719            IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
2720              CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )
2721            ENDIF
2722         END DO
2723         DO jr = 1,nsndto
2724            iproc = nfipproc(isendto(jr),jpnj)
2725            IF(iproc /= -1) THEN
2726               ilei = nleit (iproc+1)
2727               ildi = nldit (iproc+1)
2728               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
2729            ENDIF
2730            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN
2731              CALL mpprecv(5, zfoldwk, itaille, iproc)
2732              DO jk = 1, ipk
2733                 DO jj = 1, ijpj
2734                    DO ji = ildi, ilei
2735                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)
2736                    END DO
2737                 END DO
2738              END DO
2739           ELSE IF( iproc == narea-1 ) THEN
2740              DO jk = 1, ipk
2741                 DO jj = 1, ijpj
2742                    DO ji = ildi, ilei
2743                       ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk)
2744                    END DO
2745                 END DO
2746              END DO
2747           ENDIF
2748         END DO
2749         IF (l_isend) THEN
2750            DO jr = 1,nsndto
2751               IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
2752                  CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err )
2753               ENDIF   
2754            END DO
2755         ENDIF
2756         CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition
2757         DO jk = 1, ipk
2758            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d
2759               ij = jj - nlcj + ijpj
2760               DO ji= 1, nlci
2761                  pt3d(ji,jj,jk) = ztabl(ji,ij,jk)
2762               END DO
2763            END DO
2764         END DO
2765         !
2766      ELSE
2767         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                &
2768            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2769         !
2770         ztab(:,:,:) = 0._wp
2771         DO jr = 1, ndim_rank_north         ! recover the global north array
2772            iproc = nrank_north(jr) + 1
2773            ildi  = nldit (iproc)
2774            ilei  = nleit (iproc)
2775            iilb  = nimppt(iproc)
2776            DO jk = 1, ipk
2777               DO jj = 1, ijpj
2778                  DO ji = ildi, ilei
2779                    ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)
2780                  END DO
2781               END DO
2782            END DO
2783         END DO
2784         CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
2785         !
2786         DO jk = 1, ipk
2787            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d
2788               ij = jj - nlcj + ijpj
2789               DO ji= 1, nlci
2790                  pt3d(ji,jj,jk) = ztab(ji+nimpp-1,ij,jk)
2791               END DO
2792            END DO
2793         END DO
2794         !
2795      ENDIF
2796      !
2797      ! The ztab array has been either:
2798      !  a. Fully populated by the mpi_allgather operation or
2799      !  b. Had the active points for this domain and northern neighbours populated
2800      !     by peer to peer exchanges
2801      ! Either way the array may be folded by lbc_nfd and the result for the span of
2802      ! this domain will be identical.
2803      !
2804      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
2805      DEALLOCATE( ztabl, ztabr ) 
2806      !
2807   END SUBROUTINE mpp_lbc_north_3d
2808
2809
2810   SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn)
2811      !!---------------------------------------------------------------------
2812      !!                   ***  routine mpp_lbc_north_2d  ***
2813      !!
2814      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2815      !!              in mpp configuration in case of jpn1 > 1 (for 2d array )
2816      !!
2817      !! ** Method  :   North fold condition and mpp with more than one proc
2818      !!              in i-direction require a specific treatment. We gather
2819      !!              the 4 northern lines of the global domain on 1 processor
2820      !!              and apply lbc north-fold on this sub array. Then we
2821      !!              scatter the north fold array back to the processors.
2822      !!
2823      !!----------------------------------------------------------------------
2824      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 2D array on which the b.c. is applied
2825      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points
2826      !                                                          !   = T ,  U , V , F or W  gridpoints
2827      REAL(wp)                    , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
2828      !!                                                             ! =  1. , the sign is kept
2829      INTEGER ::   ji, jj, jr
2830      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2831      INTEGER ::   ijpj, ijpjm1, ij, iproc
2832      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather
2833      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
2834      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
2835      !                                                              ! Workspace for message transfers avoiding mpi_allgather
2836      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: ztab
2837      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk     
2838      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE   :: znorthgloio
2839      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: ztabl, ztabr
2840      INTEGER :: istatus(mpi_status_size)
2841      INTEGER :: iflag
2842      !!----------------------------------------------------------------------
2843      !
2844      ALLOCATE( ztab(jpiglo,4), znorthloc(jpi,4), zfoldwk(jpi,4), znorthgloio(jpi,4,jpni) )
2845      ALLOCATE( ztabl(jpi,4), ztabr(jpi*jpmaxngh, 4) ) 
2846      !
2847      ijpj   = 4
2848      ijpjm1 = 3
2849      !
2850      DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d
2851         ij = jj - nlcj + ijpj
2852         znorthloc(:,ij) = pt2d(:,jj)
2853      END DO
2854
2855      !                                     ! Build in procs of ncomm_north the znorthgloio
2856      itaille = jpi * ijpj
2857      IF ( l_north_nogather ) THEN
2858         !
2859         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified
2860         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange
2861         !
2862         ztabr(:,:) = 0
2863         ztabl(:,:) = 0
2864
2865         DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array
2866            ij = jj - nlcj + ijpj
2867              DO ji = nfsloop, nfeloop
2868               ztabl(ji,ij) = pt2d(ji,jj)
2869            END DO
2870         END DO
2871
2872         DO jr = 1,nsndto
2873            IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
2874               CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )
2875            ENDIF
2876         END DO
2877         DO jr = 1,nsndto
2878            iproc = nfipproc(isendto(jr),jpnj)
2879            IF( iproc /= -1 ) THEN
2880               ilei = nleit (iproc+1)
2881               ildi = nldit (iproc+1)
2882               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
2883            ENDIF
2884            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN
2885              CALL mpprecv(5, zfoldwk, itaille, iproc)
2886              DO jj = 1, ijpj
2887                 DO ji = ildi, ilei
2888                    ztabr(iilb+ji,jj) = zfoldwk(ji,jj)
2889                 END DO
2890              END DO
2891            ELSEIF( iproc == narea-1 ) THEN
2892              DO jj = 1, ijpj
2893                 DO ji = ildi, ilei
2894                    ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj)
2895                 END DO
2896              END DO
2897            ENDIF
2898         END DO
2899         IF(l_isend) THEN
2900            DO jr = 1,nsndto
2901               IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
2902                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
2903               ENDIF
2904            END DO
2905         ENDIF
2906         CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition
2907         !
2908         DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
2909            ij = jj - nlcj + ijpj
2910            DO ji = 1, nlci
2911               pt2d(ji,jj) = ztabl(ji,ij)
2912            END DO
2913         END DO
2914         !
2915      ELSE
2916         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,        &
2917            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2918         !
2919         ztab(:,:) = 0._wp
2920         DO jr = 1, ndim_rank_north            ! recover the global north array
2921            iproc = nrank_north(jr) + 1
2922            ildi = nldit (iproc)
2923            ilei = nleit (iproc)
2924            iilb = nimppt(iproc)
2925            DO jj = 1, ijpj
2926               DO ji = ildi, ilei
2927                  ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)
2928               END DO
2929            END DO
2930         END DO
2931         CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
2932         !
2933         DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
2934            ij = jj - nlcj + ijpj
2935            DO ji = 1, nlci
2936               pt2d(ji,jj) = ztab(ji+nimpp-1,ij)
2937            END DO
2938         END DO
2939         !
2940      ENDIF
2941      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
2942      DEALLOCATE( ztabl, ztabr ) 
2943      !
2944   END SUBROUTINE mpp_lbc_north_2d
2945
2946
2947   SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, kfld )
2948      !!---------------------------------------------------------------------
2949      !!                   ***  routine mpp_lbc_north_2d  ***
2950      !!
2951      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2952      !!              in mpp configuration in case of jpn1 > 1
2953      !!              (for multiple 2d arrays )
2954      !!
2955      !! ** Method  :   North fold condition and mpp with more than one proc
2956      !!              in i-direction require a specific treatment. We gather
2957      !!              the 4 northern lines of the global domain on 1 processor
2958      !!              and apply lbc north-fold on this sub array. Then we
2959      !!              scatter the north fold array back to the processors.
2960      !!
2961      !!----------------------------------------------------------------------
2962      TYPE( arrayptr ), DIMENSION(:), INTENT(inout) ::   pt2d_array   ! pointer array of 2D fields
2963      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type      ! nature of pt2d grid-points
2964      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn         ! sign used across the north fold
2965      INTEGER                       , INTENT(in   ) ::   kfld         ! number of variables contained in pt2d
2966      !
2967      INTEGER ::   ji, jj, jr, jk
2968      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2969      INTEGER ::   ijpj, ijpjm1, ij, iproc, iflag
2970      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf   ! for mpi_isend when avoiding mpi_allgather
2971      INTEGER                            ::   ml_err      ! for mpi_isend when avoiding mpi_allgather
2972      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat     ! for mpi_isend when avoiding mpi_allgather
2973      !                                                   ! Workspace for message transfers avoiding mpi_allgather
2974      INTEGER :: istatus(mpi_status_size)
2975      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab
2976      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk
2977      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio
2978      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr
2979      !!----------------------------------------------------------------------
2980      !
2981      ALLOCATE( ztab(jpiglo,4,kfld), znorthloc  (jpi,4,kfld),        &
2982         &      zfoldwk(jpi,4,kfld), znorthgloio(jpi,4,kfld,jpni),   &
2983         &      ztabl  (jpi,4,kfld), ztabr(jpi*jpmaxngh, 4,kfld)   )
2984      !
2985      ijpj   = 4
2986      ijpjm1 = 3
2987      !
2988     
2989      DO jk = 1, kfld
2990         DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable)
2991            ij = jj - nlcj + ijpj
2992            znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj)
2993         END DO
2994      END DO
2995      !                                     ! Build in procs of ncomm_north the znorthgloio
2996      itaille = jpi * ijpj
2997                                                                 
2998      IF ( l_north_nogather ) THEN
2999         !
3000         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified
3001         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange
3002         !
3003         ztabr(:,:,:) = 0._wp
3004         ztabl(:,:,:) = 0._wp
3005
3006         DO jk = 1, kfld
3007            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array
3008               ij = jj - nlcj + ijpj
3009               DO ji = nfsloop, nfeloop
3010                  ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj)
3011               END DO
3012            END DO
3013         END DO
3014
3015         DO jr = 1, nsndto
3016            IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
3017               CALL mppsend(5, znorthloc, itaille*kfld, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "kfld" times
3018            ENDIF
3019         END DO
3020         DO jr = 1, nsndto
3021            iproc = nfipproc(isendto(jr),jpnj)
3022            IF( iproc /= -1 ) THEN
3023               ilei = nleit (iproc+1)
3024               ildi = nldit (iproc+1)
3025               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
3026            ENDIF
3027            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN
3028              CALL mpprecv(5, zfoldwk, itaille*kfld, iproc) ! Buffer expanded "kfld" times
3029              DO jk = 1 , kfld
3030                 DO jj = 1, ijpj
3031                    DO ji = ildi, ilei
3032                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)       ! Modified to 3D
3033                    END DO
3034                 END DO
3035              END DO
3036            ELSEIF ( iproc == narea-1 ) THEN
3037              DO jk = 1, kfld
3038                 DO jj = 1, ijpj
3039                    DO ji = ildi, ilei
3040                          ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj)       ! Modified to 3D
3041                    END DO
3042                 END DO
3043              END DO
3044            ENDIF
3045         END DO
3046         IF( l_isend ) THEN
3047            DO jr = 1, nsndto
3048               IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
3049                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
3050               ENDIF
3051            END DO
3052         ENDIF
3053         !
3054         DO ji = 1, kfld     ! Loop to manage 3D variables
3055            CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition
3056         END DO
3057         !
3058         DO jk = 1, kfld
3059            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
3060               ij = jj - nlcj + ijpj
3061               DO ji = 1, nlci
3062                  pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk)       ! Modified to 3D
3063               END DO
3064            END DO
3065         END DO
3066         
3067         !
3068      ELSE
3069         !
3070         CALL MPI_ALLGATHER( znorthloc  , itaille*kfld, MPI_DOUBLE_PRECISION,        &
3071            &                znorthgloio, itaille*kfld, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
3072         !
3073         ztab(:,:,:) = 0._wp
3074         DO jk = 1, kfld
3075            DO jr = 1, ndim_rank_north            ! recover the global north array
3076               iproc = nrank_north(jr) + 1
3077               ildi = nldit (iproc)
3078               ilei = nleit (iproc)
3079               iilb = nimppt(iproc)
3080               DO jj = 1, ijpj
3081                  DO ji = ildi, ilei
3082                     ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)
3083                  END DO
3084               END DO
3085            END DO
3086         END DO
3087         
3088         DO ji = 1, kfld
3089            CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition
3090         END DO
3091         !
3092         DO jk = 1, kfld
3093            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
3094               ij = jj - nlcj + ijpj
3095               DO ji = 1, nlci
3096                  pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk)
3097               END DO
3098            END DO
3099         END DO
3100         !
3101         !
3102      ENDIF
3103      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
3104      DEALLOCATE( ztabl, ztabr )
3105      !
3106   END SUBROUTINE mpp_lbc_north_2d_multiple
3107
3108
3109   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)
3110      !!---------------------------------------------------------------------
3111      !!                   ***  routine mpp_lbc_north_2d  ***
3112      !!
3113      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
3114      !!              in mpp configuration in case of jpn1 > 1 and for 2d
3115      !!              array with outer extra halo
3116      !!
3117      !! ** Method  :   North fold condition and mpp with more than one proc
3118      !!              in i-direction require a specific treatment. We gather
3119      !!              the 4+2*jpr2dj northern lines of the global domain on 1
3120      !!              processor and apply lbc north-fold on this sub array.
3121      !!              Then we scatter the north fold array back to the processors.
3122      !!
3123      !!----------------------------------------------------------------------
3124      REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
3125      CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points
3126      REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! sign used across the north fold
3127      !
3128      INTEGER ::   ji, jj, jr
3129      INTEGER ::   ierr, itaille, ildi, ilei, iilb
3130      INTEGER ::   ijpj, ij, iproc
3131      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e
3132      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e
3133      !!----------------------------------------------------------------------
3134      !
3135      ALLOCATE( ztab_e(jpiglo,4+2*jpr2dj), znorthloc_e(jpi,4+2*jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) )
3136      !
3137      ijpj=4
3138      ztab_e(:,:) = 0._wp
3139
3140      ij = 0
3141      ! put in znorthloc_e the last 4 jlines of pt2d
3142      DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
3143         ij = ij + 1
3144         DO ji = 1, jpi
3145            znorthloc_e(ji,ij) = pt2d(ji,jj)
3146         END DO
3147      END DO
3148      !
3149      itaille = jpi * ( ijpj + 2 * jpr2dj )
3150      CALL MPI_ALLGATHER( znorthloc_e(1,1)    , itaille, MPI_DOUBLE_PRECISION,    &
3151         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
3152      !
3153      DO jr = 1, ndim_rank_north            ! recover the global north array
3154         iproc = nrank_north(jr) + 1
3155         ildi  = nldit (iproc)
3156         ilei  = nleit (iproc)
3157         iilb  = nimppt(iproc)
3158         DO jj = 1, ijpj+2*jpr2dj
3159            DO ji = ildi, ilei
3160               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
3161            END DO
3162         END DO
3163      END DO
3164
3165      ! 2. North-Fold boundary conditions
3166      ! ----------------------------------
3167      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )
3168
3169      ij = jpr2dj
3170      !! Scatter back to pt2d
3171      DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj
3172      ij  = ij +1
3173         DO ji= 1, nlci
3174            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
3175         END DO
3176      END DO
3177      !
3178      DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
3179      !
3180   END SUBROUTINE mpp_lbc_north_e
3181
3182
3183   SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy )
3184      !!----------------------------------------------------------------------
3185      !!                  ***  routine mpp_lnk_bdy_3d  ***
3186      !!
3187      !! ** Purpose :   Message passing management
3188      !!
3189      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries
3190      !!      between processors following neighboring subdomains.
3191      !!            domain parameters
3192      !!                    nlci   : first dimension of the local subdomain
3193      !!                    nlcj   : second dimension of the local subdomain
3194      !!                    nbondi_bdy : mark for "east-west local boundary"
3195      !!                    nbondj_bdy : mark for "north-south local boundary"
3196      !!                    noea   : number for local neighboring processors
3197      !!                    nowe   : number for local neighboring processors
3198      !!                    noso   : number for local neighboring processors
3199      !!                    nono   : number for local neighboring processors
3200      !!
3201      !! ** Action  :   ptab with update value at its periphery
3202      !!
3203      !!----------------------------------------------------------------------
3204      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
3205      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type  ! nature of ptab grid point
3206      REAL(wp)                  , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary
3207      INTEGER                   , INTENT(in   ) ::   ib_bdy   ! BDY boundary set
3208      !
3209      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices
3210      INTEGER  ::   ipk                        ! 3rd dimension of the input array
3211      INTEGER  ::   imigr, iihom, ijhom        ! local integers
3212      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
3213      REAL(wp) ::   zland                      ! local scalar
3214      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
3215      !
3216      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north
3217      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east
3218      !!----------------------------------------------------------------------
3219      !
3220      ipk = SIZE( ptab, 3 )
3221      !     
3222      ALLOCATE( zt3ns(jpi,jprecj,ipk,2), zt3sn(jpi,jprecj,ipk,2),   &
3223         &      zt3ew(jpj,jpreci,ipk,2), zt3we(jpj,jpreci,ipk,2)  )
3224
3225      zland = 0._wp
3226
3227      ! 1. standard boundary treatment
3228      ! ------------------------------
3229      !                                   ! East-West boundaries
3230      !                                        !* Cyclic
3231      IF( nbondi == 2) THEN
3232         IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN
3233            ptab( 1 ,:,:) = ptab(jpim1,:,:)
3234            ptab(jpi,:,:) = ptab(  2  ,:,:)
3235         ELSE
3236            IF( .NOT. cd_type == 'F' )   ptab(1:jpreci,:,:) = zland    ! south except F-point
3237            ptab(nlci-jpreci+1:jpi,:,:) = zland    ! north
3238         ENDIF
3239      ELSEIF(nbondi == -1) THEN
3240         IF( .NOT. cd_type == 'F' )   ptab(1:jpreci,:,:) = zland       ! south except F-point
3241      ELSEIF(nbondi == 1) THEN
3242         ptab(nlci-jpreci+1:jpi,:,:) = zland    ! north
3243      ENDIF                                     !* closed
3244
3245      IF (nbondj == 2 .OR. nbondj == -1) THEN
3246        IF( .NOT. cd_type == 'F' )   ptab(:,1:jprecj,:) = zland       ! south except F-point
3247      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
3248        ptab(:,nlcj-jprecj+1:jpj,:) = zland       ! north
3249      ENDIF
3250      !
3251      ! 2. East and west directions exchange
3252      ! ------------------------------------
3253      ! we play with the neigbours AND the row number because of the periodicity
3254      !
3255      SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions
3256      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
3257         iihom = nlci-nreci
3258         DO jl = 1, jpreci
3259            zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
3260            zt3we(:,jl,:,1) = ptab(iihom +jl,:,:)
3261         END DO
3262      END SELECT
3263      !
3264      !                           ! Migrations
3265      imigr = jpreci * jpj * ipk
3266      !
3267      SELECT CASE ( nbondi_bdy(ib_bdy) )
3268      CASE ( -1 )
3269         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 )
3270      CASE ( 0 )
3271         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
3272         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 )
3273      CASE ( 1 )
3274         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
3275      END SELECT
3276      !
3277      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3278      CASE ( -1 )
3279         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
3280      CASE ( 0 )
3281         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
3282         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
3283      CASE ( 1 )
3284         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
3285      END SELECT
3286      !
3287      SELECT CASE ( nbondi_bdy(ib_bdy) )
3288      CASE ( -1 )
3289         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3290      CASE ( 0 )
3291         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3292         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
3293      CASE ( 1 )
3294         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3295      END SELECT
3296      !
3297      !                           ! Write Dirichlet lateral conditions
3298      iihom = nlci-jpreci
3299      !
3300      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3301      CASE ( -1 )
3302         DO jl = 1, jpreci
3303            ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
3304         END DO
3305      CASE ( 0 )
3306         DO jl = 1, jpreci
3307            ptab(      jl,:,:) = zt3we(:,jl,:,2)
3308            ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
3309         END DO
3310      CASE ( 1 )
3311         DO jl = 1, jpreci
3312            ptab(      jl,:,:) = zt3we(:,jl,:,2)
3313         END DO
3314      END SELECT
3315
3316      ! 3. North and south directions
3317      ! -----------------------------
3318      ! always closed : we play only with the neigbours
3319      !
3320      IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions
3321         ijhom = nlcj-nrecj
3322         DO jl = 1, jprecj
3323            zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
3324            zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
3325         END DO
3326      ENDIF
3327      !
3328      !                           ! Migrations
3329      imigr = jprecj * jpi * ipk
3330      !
3331      SELECT CASE ( nbondj_bdy(ib_bdy) )
3332      CASE ( -1 )
3333         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 )
3334      CASE ( 0 )
3335         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
3336         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 )
3337      CASE ( 1 )
3338         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
3339      END SELECT
3340      !
3341      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3342      CASE ( -1 )
3343         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
3344      CASE ( 0 )
3345         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
3346         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
3347      CASE ( 1 )
3348         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
3349      END SELECT
3350      !
3351      SELECT CASE ( nbondj_bdy(ib_bdy) )
3352      CASE ( -1 )
3353         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3354      CASE ( 0 )
3355         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3356         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
3357      CASE ( 1 )
3358         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3359      END SELECT
3360      !
3361      !                           ! Write Dirichlet lateral conditions
3362      ijhom = nlcj-jprecj
3363      !
3364      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3365      CASE ( -1 )
3366         DO jl = 1, jprecj
3367            ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
3368         END DO
3369      CASE ( 0 )
3370         DO jl = 1, jprecj
3371            ptab(:,jl      ,:) = zt3sn(:,jl,:,2)
3372            ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
3373         END DO
3374      CASE ( 1 )
3375         DO jl = 1, jprecj
3376            ptab(:,jl,:) = zt3sn(:,jl,:,2)
3377         END DO
3378      END SELECT
3379
3380      ! 4. north fold treatment
3381      ! -----------------------
3382      !
3383      IF( npolj /= 0) THEN
3384         !
3385         SELECT CASE ( jpni )
3386         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
3387         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
3388         END SELECT
3389         !
3390      ENDIF
3391      !
3392      DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we  )
3393      !
3394   END SUBROUTINE mpp_lnk_bdy_3d
3395
3396
3397   SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy )
3398      !!----------------------------------------------------------------------
3399      !!                  ***  routine mpp_lnk_bdy_2d  ***
3400      !!
3401      !! ** Purpose :   Message passing management
3402      !!
3403      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries
3404      !!      between processors following neighboring subdomains.
3405      !!            domain parameters
3406      !!                    nlci   : first dimension of the local subdomain
3407      !!                    nlcj   : second dimension of the local subdomain
3408      !!                    nbondi_bdy : mark for "east-west local boundary"
3409      !!                    nbondj_bdy : mark for "north-south local boundary"
3410      !!                    noea   : number for local neighboring processors
3411      !!                    nowe   : number for local neighboring processors
3412      !!                    noso   : number for local neighboring processors
3413      !!                    nono   : number for local neighboring processors
3414      !!
3415      !! ** Action  :   ptab with update value at its periphery
3416      !!
3417      !!----------------------------------------------------------------------
3418      REAL(wp), DIMENSION(jpi,jpj)    , INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
3419      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points
3420      REAL(wp)                        , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary
3421      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set
3422      !
3423      INTEGER  ::   ji, jj, jl                 ! dummy loop indices
3424      INTEGER  ::   imigr, iihom, ijhom        ! local integers
3425      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
3426      REAL(wp) ::   zland
3427      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
3428      !
3429      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north
3430      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east
3431      !!----------------------------------------------------------------------
3432
3433      ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  &
3434         &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   )
3435
3436      zland = 0._wp
3437
3438      ! 1. standard boundary treatment
3439      ! ------------------------------
3440      !                                   ! East-West boundaries
3441      !                                         !* Cyclic
3442      IF( nbondi == 2 ) THEN
3443         IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN
3444            ptab( 1 ,:) = ptab(jpim1,:)
3445            ptab(jpi,:) = ptab(  2  ,:)
3446         ELSE
3447            IF(.NOT.cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point
3448                                       ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north
3449         ENDIF
3450      ELSEIF(nbondi == -1) THEN
3451         IF(.NOT.cd_type == 'F' )      ptab(     1       :jpreci,:) = zland    ! south except F-point
3452      ELSEIF(nbondi == 1) THEN
3453                                       ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north
3454      ENDIF
3455      !                                      !* closed
3456      IF( nbondj == 2 .OR. nbondj == -1 ) THEN
3457         IF( .NOT.cd_type == 'F' )    ptab(:,     1       :jprecj) = zland    ! south except F-point
3458      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
3459                                      ptab(:,nlcj-jprecj+1:jpj   ) = zland    ! north
3460      ENDIF
3461      !
3462      ! 2. East and west directions exchange
3463      ! ------------------------------------
3464      ! we play with the neigbours AND the row number because of the periodicity
3465      !
3466      SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions
3467      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
3468         iihom = nlci-nreci
3469         DO jl = 1, jpreci
3470            zt2ew(:,jl,1) = ptab(jpreci+jl,:)
3471            zt2we(:,jl,1) = ptab(iihom +jl,:)
3472         END DO
3473      END SELECT
3474      !
3475      !                           ! Migrations
3476      imigr = jpreci * jpj
3477      !
3478      SELECT CASE ( nbondi_bdy(ib_bdy) )
3479      CASE ( -1 )
3480         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )
3481      CASE ( 0 )
3482         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
3483         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )
3484      CASE ( 1 )
3485         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
3486      END SELECT
3487      !
3488      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3489      CASE ( -1 )
3490         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
3491      CASE ( 0 )
3492         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
3493         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
3494      CASE ( 1 )
3495         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
3496      END SELECT
3497      !
3498      SELECT CASE ( nbondi_bdy(ib_bdy) )
3499      CASE ( -1 )
3500         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
3501      CASE ( 0 )
3502         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
3503         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err )
3504      CASE ( 1 )
3505         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
3506      END SELECT
3507      !
3508      !                           ! Write Dirichlet lateral conditions
3509      iihom = nlci-jpreci
3510      !
3511      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3512      CASE ( -1 )
3513         DO jl = 1, jpreci
3514            ptab(iihom+jl,:) = zt2ew(:,jl,2)
3515         END DO
3516      CASE ( 0 )
3517         DO jl = 1, jpreci
3518            ptab(jl      ,:) = zt2we(:,jl,2)
3519            ptab(iihom+jl,:) = zt2ew(:,jl,2)
3520         END DO
3521      CASE ( 1 )
3522         DO jl = 1, jpreci
3523            ptab(jl      ,:) = zt2we(:,jl,2)
3524         END DO
3525      END SELECT
3526
3527
3528      ! 3. North and south directions
3529      ! -----------------------------
3530      ! always closed : we play only with the neigbours
3531      !
3532      IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions
3533         ijhom = nlcj-nrecj
3534         DO jl = 1, jprecj
3535            zt2sn(:,jl,1) = ptab(:,ijhom +jl)
3536            zt2ns(:,jl,1) = ptab(:,jprecj+jl)
3537         END DO
3538      ENDIF
3539      !
3540      !                           ! Migrations
3541      imigr = jprecj * jpi
3542      !
3543      SELECT CASE ( nbondj_bdy(ib_bdy) )
3544      CASE ( -1 )
3545         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )
3546      CASE ( 0 )
3547         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
3548         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )
3549      CASE ( 1 )
3550         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
3551      END SELECT
3552      !
3553      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3554      CASE ( -1 )
3555         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
3556      CASE ( 0 )
3557         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
3558         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
3559      CASE ( 1 )
3560         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
3561      END SELECT
3562      !
3563      SELECT CASE ( nbondj_bdy(ib_bdy) )
3564      CASE ( -1 )
3565         IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
3566      CASE ( 0 )
3567         IF(l_isend) CALL mpi_wait (ml_req1, ml_stat, ml_err )
3568         IF(l_isend) CALL mpi_wait( ml_req2, ml_stat, ml_err )
3569      CASE ( 1 )
3570         IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
3571      END SELECT
3572      !
3573      !                           ! Write Dirichlet lateral conditions
3574      ijhom = nlcj-jprecj
3575      !
3576      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3577      CASE ( -1 )
3578         DO jl = 1, jprecj
3579            ptab(:,ijhom+jl) = zt2ns(:,jl,2)
3580         END DO
3581      CASE ( 0 )
3582         DO jl = 1, jprecj
3583            ptab(:,jl      ) = zt2sn(:,jl,2)
3584            ptab(:,ijhom+jl) = zt2ns(:,jl,2)
3585         END DO
3586      CASE ( 1 )
3587         DO jl = 1, jprecj
3588            ptab(:,jl) = zt2sn(:,jl,2)
3589         END DO
3590      END SELECT
3591
3592      ! 4. north fold treatment
3593      ! -----------------------
3594      !
3595      IF( npolj /= 0) THEN
3596         !
3597         SELECT CASE ( jpni )
3598         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
3599         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
3600         END SELECT
3601         !
3602      ENDIF
3603      !
3604      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we  )
3605      !
3606   END SUBROUTINE mpp_lnk_bdy_2d
3607
3608
3609   SUBROUTINE mpi_init_opa( ldtxt, ksft, code )
3610      !!---------------------------------------------------------------------
3611      !!                   ***  routine mpp_init.opa  ***
3612      !!
3613      !! ** Purpose :: export and attach a MPI buffer for bsend
3614      !!
3615      !! ** Method  :: define buffer size in namelist, if 0 no buffer attachment
3616      !!            but classical mpi_init
3617      !!
3618      !! History :: 01/11 :: IDRIS initial version for IBM only
3619      !!            08/04 :: R. Benshila, generalisation
3620      !!---------------------------------------------------------------------
3621      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt
3622      INTEGER                      , INTENT(inout) ::   ksft
3623      INTEGER                      , INTENT(  out) ::   code
3624      INTEGER                                      ::   ierr, ji
3625      LOGICAL                                      ::   mpi_was_called
3626      !!---------------------------------------------------------------------
3627      !
3628      CALL mpi_initialized( mpi_was_called, code )      ! MPI initialization
3629      IF ( code /= MPI_SUCCESS ) THEN
3630         DO ji = 1, SIZE(ldtxt)
3631            IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
3632         END DO
3633         WRITE(*, cform_err)
3634         WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized'
3635         CALL mpi_abort( mpi_comm_world, code, ierr )
3636      ENDIF
3637      !
3638      IF( .NOT. mpi_was_called ) THEN
3639         CALL mpi_init( code )
3640         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code )
3641         IF ( code /= MPI_SUCCESS ) THEN
3642            DO ji = 1, SIZE(ldtxt)
3643               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
3644            END DO
3645            WRITE(*, cform_err)
3646            WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
3647            CALL mpi_abort( mpi_comm_world, code, ierr )
3648         ENDIF
3649      ENDIF
3650      !
3651      IF( nn_buffer > 0 ) THEN
3652         WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of  : ', nn_buffer   ;   ksft = ksft + 1
3653         ! Buffer allocation and attachment
3654         ALLOCATE( tampon(nn_buffer), stat = ierr )
3655         IF( ierr /= 0 ) THEN
3656            DO ji = 1, SIZE(ldtxt)
3657               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
3658            END DO
3659            WRITE(*, cform_err)
3660            WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr
3661            CALL mpi_abort( mpi_comm_world, code, ierr )
3662         END IF
3663         CALL mpi_buffer_attach( tampon, nn_buffer, code )
3664      ENDIF
3665      !
3666   END SUBROUTINE mpi_init_opa
3667
3668   SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype)
3669      !!---------------------------------------------------------------------
3670      !!   Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
3671      !!
3672      !!   Modification of original codes written by David H. Bailey
3673      !!   This subroutine computes yddb(i) = ydda(i)+yddb(i)
3674      !!---------------------------------------------------------------------
3675      INTEGER                     , INTENT(in)    ::   ilen, itype
3676      COMPLEX(wp), DIMENSION(ilen), INTENT(in)    ::   ydda
3677      COMPLEX(wp), DIMENSION(ilen), INTENT(inout) ::   yddb
3678      !
3679      REAL(wp) :: zerr, zt1, zt2    ! local work variables
3680      INTEGER  :: ji, ztmp           ! local scalar
3681      !!---------------------------------------------------------------------
3682
3683      ztmp = itype   ! avoid compilation warning
3684
3685      DO ji=1,ilen
3686      ! Compute ydda + yddb using Knuth's trick.
3687         zt1  = real(ydda(ji)) + real(yddb(ji))
3688         zerr = zt1 - real(ydda(ji))
3689         zt2  = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
3690                + aimag(ydda(ji)) + aimag(yddb(ji))
3691
3692         ! The result is zt1 + zt2, after normalization.
3693         yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
3694      END DO
3695
3696   END SUBROUTINE DDPDD_MPI
3697
3698
3699   SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj)
3700      !!---------------------------------------------------------------------
3701      !!                   ***  routine mpp_lbc_north_icb  ***
3702      !!
3703      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
3704      !!              in mpp configuration in case of jpn1 > 1 and for 2d
3705      !!              array with outer extra halo
3706      !!
3707      !! ** Method  :   North fold condition and mpp with more than one proc
3708      !!              in i-direction require a specific treatment. We gather
3709      !!              the 4+2*jpr2dj northern lines of the global domain on 1
3710      !!              processor and apply lbc north-fold on this sub array.
3711      !!              Then we scatter the north fold array back to the processors.
3712      !!              This version accounts for an extra halo with icebergs.
3713      !!
3714      !!----------------------------------------------------------------------
3715      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo
3716      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points
3717      !                                                     !   = T ,  U , V , F or W -points
3718      REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the
3719      !!                                                    ! north fold, =  1. otherwise
3720      INTEGER, OPTIONAL       , INTENT(in   ) ::   pr2dj
3721      !
3722      INTEGER ::   ji, jj, jr
3723      INTEGER ::   ierr, itaille, ildi, ilei, iilb
3724      INTEGER ::   ijpj, ij, iproc, ipr2dj
3725      !
3726      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e
3727      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e
3728      !!----------------------------------------------------------------------
3729      !
3730      ijpj=4
3731      IF( PRESENT(pr2dj) ) THEN           ! use of additional halos
3732         ipr2dj = pr2dj
3733      ELSE
3734         ipr2dj = 0
3735      ENDIF
3736      ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpi,4+2*ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) )
3737      !
3738      ztab_e(:,:) = 0._wp
3739      !
3740      ij = 0
3741      ! put in znorthloc_e the last 4 jlines of pt2d
3742      DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj
3743         ij = ij + 1
3744         DO ji = 1, jpi
3745            znorthloc_e(ji,ij)=pt2d(ji,jj)
3746         END DO
3747      END DO
3748      !
3749      itaille = jpi * ( ijpj + 2 * ipr2dj )
3750      CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    &
3751         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
3752      !
3753      DO jr = 1, ndim_rank_north            ! recover the global north array
3754         iproc = nrank_north(jr) + 1
3755         ildi = nldit (iproc)
3756         ilei = nleit (iproc)
3757         iilb = nimppt(iproc)
3758         DO jj = 1, ijpj+2*ipr2dj
3759            DO ji = ildi, ilei
3760               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
3761            END DO
3762         END DO
3763      END DO
3764
3765
3766      ! 2. North-Fold boundary conditions
3767      ! ----------------------------------
3768      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj )
3769
3770      ij = ipr2dj
3771      !! Scatter back to pt2d
3772      DO jj = nlcj - ijpj + 1 , nlcj +ipr2dj
3773      ij  = ij +1
3774         DO ji= 1, nlci
3775            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
3776         END DO
3777      END DO
3778      !
3779      DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
3780      !
3781   END SUBROUTINE mpp_lbc_north_icb
3782
3783
3784   SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj )
3785      !!----------------------------------------------------------------------
3786      !!                  ***  routine mpp_lnk_2d_icb  ***
3787      !!
3788      !! ** Purpose :   Message passing manadgement for 2d array (with extra halo and icebergs)
3789      !!
3790      !! ** Method  :   Use mppsend and mpprecv function for passing mask
3791      !!      between processors following neighboring subdomains.
3792      !!            domain parameters
3793      !!                    nlci   : first dimension of the local subdomain
3794      !!                    nlcj   : second dimension of the local subdomain
3795      !!                    jpri   : number of rows for extra outer halo
3796      !!                    jprj   : number of columns for extra outer halo
3797      !!                    nbondi : mark for "east-west local boundary"
3798      !!                    nbondj : mark for "north-south local boundary"
3799      !!                    noea   : number for local neighboring processors
3800      !!                    nowe   : number for local neighboring processors
3801      !!                    noso   : number for local neighboring processors
3802      !!                    nono   : number for local neighboring processors
3803      !!----------------------------------------------------------------------
3804      REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
3805      CHARACTER(len=1)                                    , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points
3806      REAL(wp)                                            , INTENT(in   ) ::   psgn     ! sign used across the north fold
3807      INTEGER                                             , INTENT(in   ) ::   jpri
3808      INTEGER                                             , INTENT(in   ) ::   jprj
3809      !
3810      INTEGER  ::   jl   ! dummy loop indices
3811      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
3812      INTEGER  ::   ipreci, iprecj             ! temporary integers
3813      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
3814      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
3815      !!
3816      REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns
3817      REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn
3818      REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe
3819      REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew
3820      !!----------------------------------------------------------------------
3821
3822      ipreci = jpreci + jpri      ! take into account outer extra 2D overlap area
3823      iprecj = jprecj + jprj
3824
3825
3826      ! 1. standard boundary treatment
3827      ! ------------------------------
3828      ! Order matters Here !!!!
3829      !
3830      !                                      ! East-West boundaries
3831      !                                           !* Cyclic east-west
3832      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
3833         pt2d(1-jpri:     1    ,:) = pt2d(jpim1-jpri:  jpim1 ,:)       ! east
3834         pt2d(   jpi  :jpi+jpri,:) = pt2d(     2      :2+jpri,:)       ! west
3835         !
3836      ELSE                                        !* closed
3837         IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0._wp    ! south except at F-point
3838                                      pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp    ! north
3839      ENDIF
3840      !
3841
3842      ! north fold treatment
3843      ! -----------------------
3844      IF( npolj /= 0 ) THEN
3845         !
3846         SELECT CASE ( jpni )
3847         CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )
3848         CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj)  , cd_type, psgn , pr2dj=jprj  )
3849         END SELECT
3850         !
3851      ENDIF
3852
3853      ! 2. East and west directions exchange
3854      ! ------------------------------------
3855      ! we play with the neigbours AND the row number because of the periodicity
3856      !
3857      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
3858      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
3859         iihom = nlci-nreci-jpri
3860         DO jl = 1, ipreci
3861            r2dew(:,jl,1) = pt2d(jpreci+jl,:)
3862            r2dwe(:,jl,1) = pt2d(iihom +jl,:)
3863         END DO
3864      END SELECT
3865      !
3866      !                           ! Migrations
3867      imigr = ipreci * ( jpj + 2*jprj)
3868      !
3869      SELECT CASE ( nbondi )
3870      CASE ( -1 )
3871         CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 )
3872         CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
3873         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3874      CASE ( 0 )
3875         CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
3876         CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 )
3877         CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
3878         CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
3879         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3880         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
3881      CASE ( 1 )
3882         CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
3883         CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
3884         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3885      END SELECT
3886      !
3887      !                           ! Write Dirichlet lateral conditions
3888      iihom = nlci - jpreci
3889      !
3890      SELECT CASE ( nbondi )
3891      CASE ( -1 )
3892         DO jl = 1, ipreci
3893            pt2d(iihom+jl,:) = r2dew(:,jl,2)
3894         END DO
3895      CASE ( 0 )
3896         DO jl = 1, ipreci
3897            pt2d(jl-jpri,:) = r2dwe(:,jl,2)
3898            pt2d( iihom+jl,:) = r2dew(:,jl,2)
3899         END DO
3900      CASE ( 1 )
3901         DO jl = 1, ipreci
3902            pt2d(jl-jpri,:) = r2dwe(:,jl,2)
3903         END DO
3904      END SELECT
3905
3906
3907      ! 3. North and south directions
3908      ! -----------------------------
3909      ! always closed : we play only with the neigbours
3910      !
3911      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
3912         ijhom = nlcj-nrecj-jprj
3913         DO jl = 1, iprecj
3914            r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
3915            r2dns(:,jl,1) = pt2d(:,jprecj+jl)
3916         END DO
3917      ENDIF
3918      !
3919      !                           ! Migrations
3920      imigr = iprecj * ( jpi + 2*jpri )
3921      !
3922      SELECT CASE ( nbondj )
3923      CASE ( -1 )
3924         CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 )
3925         CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
3926         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3927      CASE ( 0 )
3928         CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
3929         CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 )
3930         CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
3931         CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
3932         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3933         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
3934      CASE ( 1 )
3935         CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
3936         CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
3937         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3938      END SELECT
3939      !
3940      !                           ! Write Dirichlet lateral conditions
3941      ijhom = nlcj - jprecj
3942      !
3943      SELECT CASE ( nbondj )
3944      CASE ( -1 )
3945         DO jl = 1, iprecj
3946            pt2d(:,ijhom+jl) = r2dns(:,jl,2)
3947         END DO
3948