New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
lib_mpp.F90 in branches/2017/dev_rev8689_LIM3_RST/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

source: branches/2017/dev_rev8689_LIM3_RST/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 8722

Last change on this file since 8722 was 8722, checked in by andmirek, 6 years ago

#1976 changes in variable name and indentation

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