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.
Changeset 8882 for branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 – NEMO

Ignore:
Timestamp:
2017-12-01T18:44:09+01:00 (6 years ago)
Author:
flavoni
Message:

dev_CNRS_2017 branch: merged dev_r7881_ENHANCE09_RK3 with trunk r8864

File:
1 edited

Legend:

Unmodified
Added
Removed

  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r7753 r8882  
    88   !!            8.0  !  1998  (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI 
    99   !!                 !  1998  (J.M. Molines) Open boundary conditions 
    10    !!   NEMO     1.0  !  2003  (J.-M. Molines, G. Madec)  F90, free form 
     10   !!   NEMO     1.0  !  2003  (J.M. Molines, G. Madec)  F90, free form 
    1111   !!                 !  2003  (J.M. Molines) add mpp_ini_north(_3d,_2d) 
    1212   !!             -   !  2004  (R. Bourdalle Badie)  isend option in mpi 
    … …  
    1919   !!            3.2  !  2009  (O. Marti)    add mpp_ini_znl 
    2020   !!            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  
     21   !!            3.5  !  2012  (S.Mocavero, I. Epicoco) Add mpp_lnk_bdy_3d/2d routines to optimize the BDY comm. 
     22   !!            3.5  !  2013  (C. Ethe, G. Madec)  message passing arrays as local variables  
    2523   !!            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'  
     24   !!            3.6  !  2015  (O. Tintó and M. Castrillo - BSC) Added '_multiple' case for 2D lbc and max 
     25   !!            4.0  !  2017  (G. Madec) automatique allocation of array argument (use any 3rd dimension) 
     26   !!             -   !  2017  (G. Madec) create generic.h90 files to generate all lbc and north fold routines 
    2727   !!---------------------------------------------------------------------- 
    2828 
    … …  
    4141   !!   mynode        : indentify the processor unit 
    4242   !!   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 
    4443   !!   mpp_lnk_e     : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e) 
    4544   !!   mpp_lnk_icb   : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 
    4645   !!   mpprecv       : 
    47    !!   mppsend       :   SUBROUTINE mpp_ini_znl 
     46   !!   mppsend       : 
    4847   !!   mppscatter    : 
    4948   !!   mppgather     : 
    … …  
    5655   !!   mppstop       : 
    5756   !!   mpp_ini_north : initialisation of north fold 
    58    !!   mpp_lbc_north : north fold processors gathering 
     57!!gm   !!   mpp_lbc_north : north fold processors gathering 
    5958   !!   mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo 
    6059   !!   mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs 
    … …  
    6766   IMPLICIT NONE 
    6867   PRIVATE 
    69     
     68 
     69   INTERFACE mpp_nfd 
     70      MODULE PROCEDURE   mpp_nfd_2d      , mpp_nfd_3d      , mpp_nfd_4d 
     71      MODULE PROCEDURE   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 
     72   END INTERFACE 
     73 
     74   ! Interface associated to the mpp_lnk_... routines is defined in lbclnk 
     75   PUBLIC   mpp_lnk_2d      , mpp_lnk_3d      , mpp_lnk_4d 
     76   PUBLIC   mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr 
     77   PUBLIC   mpp_lnk_2d_e 
     78   ! 
     79!!gm  this should be useless 
     80   PUBLIC   mpp_nfd_2d    , mpp_nfd_3d    , mpp_nfd_4d 
     81   PUBLIC   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 
     82!!gm end 
     83   ! 
    7084   PUBLIC   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 
    7185   PUBLIC   mynode, mppstop, mppsync, mpp_comm_free 
    72    PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 
     86   PUBLIC   mpp_ini_north, mpp_lbc_north_e 
     87!!gm   PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 
     88   PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
    7389   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
    7490   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 
     91!!gm   PUBLIC   mpp_lnk_2d_9  
     92!!gm   PUBLIC   mpp_lnk_sum_3d, mpp_lnk_sum_2d 
    7893   PUBLIC   mppscatter, mppgather 
    7994   PUBLIC   mpp_ini_ice, mpp_ini_znl 
    … …  
    8196   PUBLIC   mppsend, mpprecv                          ! needed by TAM and ICB routines 
    8297   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
    83    PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
    8498   PUBLIC   mpprank 
    85  
    86    TYPE arrayptr 
    87       REAL , DIMENSION (:,:),  POINTER :: pt2d 
    88    END TYPE arrayptr 
    89    PUBLIC   arrayptr 
    9099    
    91100   !! * Interfaces 
    … …  
    101110   INTERFACE mpp_sum 
    102111      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real,   & 
    103                        mppsum_realdd, mppsum_a_realdd 
     112         &             mppsum_realdd, mppsum_a_realdd 
    104113   END INTERFACE 
    105    INTERFACE mpp_lbc_north 
    106       MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 
    107    END INTERFACE 
     114!!gm   INTERFACE mpp_lbc_north 
     115!!gm      MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 
     116!!gm   END INTERFACE 
    108117   INTERFACE mpp_minloc 
    109118      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 
    … …  
    112121      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
    113122   END INTERFACE 
    114  
    115123   INTERFACE mpp_max_multiple 
    116124      MODULE PROCEDURE mppmax_real_multiple 
    … …  
    137145 
    138146   ! 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 
     147   INTEGER, PUBLIC ::   ncomm_ice       !: communicator made by the processors with sea-ice (public so that it can be freed in icethd) 
     148   INTEGER         ::   ngrp_iworld     !  group ID for the world processors (for rheology) 
     149   INTEGER         ::   ngrp_ice        !  group ID for the ice processors (for rheology) 
     150   INTEGER         ::   ndim_rank_ice   !  number of 'ice' processors 
     151   INTEGER         ::   n_ice_root      !  number (in the comm_ice) of proc 0 in the ice comm 
    144152   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_ice     ! dimension ndim_rank_ice 
    145153 
    146154   ! variables used for zonal integration 
    147155   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 
     156   LOGICAL, PUBLIC ::   l_znl_root      !: True on the 'left'most processor on the same row 
     157   INTEGER         ::   ngrp_znl        ! group ID for the znl processors 
     158   INTEGER         ::   ndim_rank_znl   ! number of processors on the same zonal average 
    151159   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_znl  ! dimension ndim_rank_znl, number of the procs into the same znl domain 
    152160 
    153161   ! 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   INTEGER, PUBLIC ::   ngrp_world        !: group ID for the world processors 
     163   INTEGER, PUBLIC ::   ngrp_opa          !: group ID for the opa processors 
     164   INTEGER, PUBLIC ::   ngrp_north        !: group ID for the northern processors (to be fold) 
     165   INTEGER, PUBLIC ::   ncomm_north       !: communicator made by the processors belonging to ngrp_north 
     166   INTEGER, PUBLIC ::   ndim_rank_north   !: number of 'sea' processor in the northern line (can be /= jpni !) 
     167   INTEGER, PUBLIC ::   njmppmax          !: value of njmpp for the processors of the northern line 
     168   INTEGER, PUBLIC ::   north_root        !: number (in the comm_opa) of proc 0 in the northern comm 
     169   INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_north   !: dimension ndim_rank_north 
    162170 
    163171   ! 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) 
     172   CHARACTER(len=1), PUBLIC ::   cn_mpi_send        !: type od mpi send/recieve (S=standard, B=bsend, I=isend) 
     173   LOGICAL         , PUBLIC ::   l_isend = .FALSE.  !: isend use indicator (T if cn_mpi_send='I') 
     174   INTEGER         , PUBLIC ::   nn_buffer          !: size of the buffer in case of mpi_bsend 
     175 
     176   REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::   tampon   ! buffer in case of bsend 
     177 
     178   LOGICAL, PUBLIC ::   ln_nnogather                !: namelist control of northfold comms 
     179   LOGICAL, PUBLIC ::   l_north_nogather = .FALSE.  !: internal control of northfold comms 
     180 
     181   !!---------------------------------------------------------------------- 
     182   !! NEMO/OPA 4.0 , NEMO Consortium (2017) 
    175183   !! $Id$ 
    176184   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    178186CONTAINS 
    179187 
    180  
    181    FUNCTION mynode( ldtxt, ldname, kumnam_ref , kumnam_cfg , kumond , kstop, localComm ) 
     188   FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm ) 
    182189      !!---------------------------------------------------------------------- 
    183190      !!                  ***  routine mynode  *** 
    … …  
    204211      WRITE(ldtxt(ii),*) '~~~~~~ '                                                        ;   ii = ii + 1 
    205212      ! 
    206  
    207213      REWIND( kumnam_ref )              ! Namelist nammpp in reference namelist: mpi variables 
    208214      READ  ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901) 
    209215901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp ) 
    210  
     216      ! 
    211217      REWIND( kumnam_cfg )              ! Namelist nammpp in configuration namelist: mpi variables 
    212218      READ  ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 
    213219902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp ) 
    214  
     220      ! 
    215221      !                              ! control print 
    216222      WRITE(ldtxt(ii),*) '   Namelist nammpp'                                             ;   ii = ii + 1 
    217223      WRITE(ldtxt(ii),*) '      mpi send type          cn_mpi_send = ', cn_mpi_send       ;   ii = ii + 1 
    218224      WRITE(ldtxt(ii),*) '      size exported buffer   nn_buffer   = ', nn_buffer,' bytes';   ii = ii + 1 
    219  
     225      ! 
    220226#if defined key_agrif 
    221227      IF( .NOT. Agrif_Root() ) THEN 
    … …  
    225231      ENDIF 
    226232#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 
     233      ! 
     234      IF( jpnij < 1 ) THEN         ! If jpnij is not specified in namelist then we calculate it 
     235         jpnij = jpni * jpnj       ! this means there will be no land cutting out. 
     236      ENDIF 
     237 
     238      IF( jpni < 1 .OR. jpnj < 1  ) THEN 
    235239         WRITE(ldtxt(ii),*) '      jpni, jpnj and jpnij will be calculated automatically' ;   ii = ii + 1 
    236240      ELSE 
    … …  
    238242         WRITE(ldtxt(ii),*) '      processor grid extent in j         jpnj = ',jpnj       ;   ii = ii + 1 
    239243         WRITE(ldtxt(ii),*) '      number of local domains           jpnij = ',jpnij      ;   ii = ii + 1 
    240       END IF 
     244      ENDIF 
    241245 
    242246      WRITE(ldtxt(ii),*) '      avoid use of mpi_allgather at the north fold  ln_nnogather = ', ln_nnogather  ; ii = ii + 1 
    … …  
    268272            kstop = kstop + 1 
    269273         END SELECT 
    270       ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN 
     274         ! 
     275      ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN 
    271276         WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator '          ;   ii = ii + 1 
    272277         WRITE(ldtxt(ii),*) '          without calling MPI_Init before ! '                ;   ii = ii + 1 
    … …  
    309314 
    310315#if defined key_agrif 
    311       IF (Agrif_Root()) THEN 
     316      IF( Agrif_Root() ) THEN 
    312317         CALL Agrif_MPI_Init(mpi_comm_opa) 
    313318      ELSE 
    … …  
    329334   END FUNCTION mynode 
    330335 
    331  
    332    SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 
    333       !!---------------------------------------------------------------------- 
    334       !!                  ***  routine mpp_lnk_3d  *** 
    335       !! 
    336       !! ** Purpose :   Message passing manadgement 
    337       !! 
    338       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    339       !!      between processors following neighboring subdomains. 
    340       !!            domain parameters 
    341       !!                    nlci   : first dimension of the local subdomain 
    342       !!                    nlcj   : second dimension of the local subdomain 
    343       !!                    nbondi : mark for "east-west local boundary" 
    344       !!                    nbondj : mark for "north-south local boundary" 
    345       !!                    noea   : number for local neighboring processors 
    346       !!                    nowe   : number for local neighboring processors 
    347       !!                    noso   : number for local neighboring processors 
    348       !!                    nono   : number for local neighboring processors 
    349       !! 
    350       !! ** Action  :   ptab with update value at its periphery 
    351       !! 
    352       !!---------------------------------------------------------------------- 
    353       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
    354       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
    355       !                                                             ! = T , U , V , F , W points 
    356       REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    357       !                                                             ! =  1. , the sign is kept 
    358       CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    359       REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    360       ! 
    361       INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
    362       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    363       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    364       REAL(wp) ::   zland 
    365       INTEGER , DIMENSION(MPI_STATUS_SIZE)      ::   ml_stat        ! for key_mpi_isend 
    366       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north 
    367       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east 
    368       !!---------------------------------------------------------------------- 
    369        
    370       ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   & 
    371          &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  ) 
    372  
    373       ! 
    374       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    375       ELSE                         ;   zland = 0._wp     ! zero by default 
    376       ENDIF 
    377  
    378       ! 1. standard boundary treatment 
    379       ! ------------------------------ 
    380       IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
    381          ! 
    382          ! WARNING ptab is defined only between nld and nle 
    383          DO jk = 1, jpk 
    384             DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    385                ptab(nldi  :nlei  , jj          ,jk) = ptab(nldi:nlei,     nlej,jk) 
    386                ptab(1     :nldi-1, jj          ,jk) = ptab(nldi     ,     nlej,jk) 
    387                ptab(nlei+1:nlci  , jj          ,jk) = ptab(     nlei,     nlej,jk) 
    388             END DO 
    389             DO ji = nlci+1, jpi                 ! added column(s) (full) 
    390                ptab(ji           ,nldj  :nlej  ,jk) = ptab(     nlei,nldj:nlej,jk) 
    391                ptab(ji           ,1     :nldj-1,jk) = ptab(     nlei,nldj     ,jk) 
    392                ptab(ji           ,nlej+1:jpj   ,jk) = ptab(     nlei,     nlej,jk) 
    393             END DO 
    394          END DO 
    395          ! 
    396       ELSE                              ! standard close or cyclic treatment 
    397          ! 
    398          !                                   ! East-West boundaries 
    399          !                                        !* Cyclic east-west 
    400          IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    401             ptab( 1 ,:,:) = ptab(jpim1,:,:) 
    402             ptab(jpi,:,:) = ptab(  2  ,:,:) 
    403          ELSE                                     !* closed 
    404             IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
    405                                          ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
    406          ENDIF 
    407                                           ! North-south cyclic 
    408          IF ( nbondj == 2 .AND. jperio == 7 )    THEN !* cyclic north south only with no mpp split in latitude 
    409             ptab(:,1 , :) = ptab(:, jpjm1,:) 
    410             ptab(:,jpj,:) = ptab(:,     2,:) 
    411          ELSE   !                                   ! North-South boundaries (closed) 
    412             IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point 
    413                                          ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north 
    414          ENDIF 
    415          ! 
    416       ENDIF 
    417  
    418       ! 2. East and west directions exchange 
    419       ! ------------------------------------ 
    420       ! we play with the neigbours AND the row number because of the periodicity 
    421       ! 
    422       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    423       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    424          iihom = nlci-nreci 
    425          DO jl = 1, jpreci 
    426             zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 
    427             zt3we(:,jl,:,1) = ptab(iihom +jl,:,:) 
    428          END DO 
    429       END SELECT 
    430       ! 
    431       !                           ! Migrations 
    432       imigr = jpreci * jpj * jpk 
    433       ! 
    434       SELECT CASE ( nbondi ) 
    435       CASE ( -1 ) 
    436          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 
    437          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    438          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    439       CASE ( 0 ) 
    440          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    441          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 
    442          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    443          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    444          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    445          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    446       CASE ( 1 ) 
    447          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    448          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    449          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    450       END SELECT 
    451       ! 
    452       !                           ! Write Dirichlet lateral conditions 
    453       iihom = nlci-jpreci 
    454       ! 
    455       SELECT CASE ( nbondi ) 
    456       CASE ( -1 ) 
    457          DO jl = 1, jpreci 
    458             ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 
    459          END DO 
    460       CASE ( 0 ) 
    461          DO jl = 1, jpreci 
    462             ptab(jl      ,:,:) = zt3we(:,jl,:,2) 
    463             ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 
    464          END DO 
    465       CASE ( 1 ) 
    466          DO jl = 1, jpreci 
    467             ptab(jl      ,:,:) = zt3we(:,jl,:,2) 
    468          END DO 
    469       END SELECT 
    470  
    471       ! 3. North and south directions 
    472       ! ----------------------------- 
    473       ! always closed : we play only with the neigbours 
    474       ! 
    475       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    476          ijhom = nlcj-nrecj 
    477          DO jl = 1, jprecj 
    478             zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 
    479             zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 
    480          END DO 
    481       ENDIF 
    482       ! 
    483       !                           ! Migrations 
    484       imigr = jprecj * jpi * jpk 
    485       ! 
    486       SELECT CASE ( nbondj ) 
    487       CASE ( -1 ) 
    488          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 
    489          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    490          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    491       CASE ( 0 ) 
    492          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    493          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 
    494          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    495          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    496          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    497          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    498       CASE ( 1 ) 
    499          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    500          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    501          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    502       END SELECT 
    503       ! 
    504       !                           ! Write Dirichlet lateral conditions 
    505       ijhom = nlcj-jprecj 
    506       ! 
    507       SELECT CASE ( nbondj ) 
    508       CASE ( -1 ) 
    509          DO jl = 1, jprecj 
    510             ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 
    511          END DO 
    512       CASE ( 0 ) 
    513          DO jl = 1, jprecj 
    514             ptab(:,jl      ,:) = zt3sn(:,jl,:,2) 
    515             ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 
    516          END DO 
    517       CASE ( 1 ) 
    518          DO jl = 1, jprecj 
    519             ptab(:,jl,:) = zt3sn(:,jl,:,2) 
    520          END DO 
    521       END SELECT 
    522  
    523       ! 4. north fold treatment 
    524       ! ----------------------- 
    525       ! 
    526       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    527          ! 
    528          SELECT CASE ( jpni ) 
    529          CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
    530          CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
    531          END SELECT 
    532          ! 
    533       ENDIF 
    534       ! 
    535       DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) 
    536       ! 
    537    END SUBROUTINE mpp_lnk_3d 
    538  
    539  
    540    SUBROUTINE mpp_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields , cd_mpp, pval ) 
    541       !!---------------------------------------------------------------------- 
    542       !!                  ***  routine mpp_lnk_2d_multiple  *** 
    543       !! 
    544       !! ** Purpose :   Message passing management for multiple 2d arrays 
    545       !! 
    546       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    547       !!      between processors following neighboring subdomains. 
    548       !!            domain parameters 
    549       !!                    nlci   : first dimension of the local subdomain 
    550       !!                    nlcj   : second dimension of the local subdomain 
    551       !!                    nbondi : mark for "east-west local boundary" 
    552       !!                    nbondj : mark for "north-south local boundary" 
    553       !!                    noea   : number for local neighboring processors 
    554       !!                    nowe   : number for local neighboring processors 
    555       !!                    noso   : number for local neighboring processors 
    556       !!                    nono   : number for local neighboring processors 
    557       !!---------------------------------------------------------------------- 
    558       CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
    559       !                                                               ! = T , U , V , F , W and I points 
    560       REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
    561       !                                                               ! =  1. , the sign is kept 
    562       CHARACTER(len=3), OPTIONAL    , INTENT(in   ) ::   cd_mpp       ! fill the overlap area only 
    563       REAL(wp)        , OPTIONAL    , INTENT(in   ) ::   pval         ! background value (used at closed boundaries) 
    564       !! 
    565       INTEGER  ::   ji, jj, jl   ! dummy loop indices 
    566       INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
    567       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    568       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    569       INTEGER :: num_fields 
    570       TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
    571       REAL(wp) ::   zland 
    572       INTEGER , DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat       ! for key_mpi_isend 
    573       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
    574       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
    575  
    576       !!---------------------------------------------------------------------- 
    577       ! 
    578       ALLOCATE( zt2ns(jpi,jprecj,2*num_fields), zt2sn(jpi,jprecj,2*num_fields),  & 
    579          &      zt2ew(jpj,jpreci,2*num_fields), zt2we(jpj,jpreci,2*num_fields)   ) 
    580       ! 
    581       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    582       ELSE                         ;   zland = 0._wp     ! zero by default 
    583       ENDIF 
    584  
    585       ! 1. standard boundary treatment 
    586       ! ------------------------------ 
    587       ! 
    588       !First Array 
    589       DO ii = 1 , num_fields 
    590          IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
    591             ! 
    592             ! WARNING pt2d is defined only between nld and nle 
    593             DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    594                pt2d_array(ii)%pt2d(nldi  :nlei  , jj) = pt2d_array(ii)%pt2d(nldi:nlei, nlej) 
    595                pt2d_array(ii)%pt2d(1     :nldi-1, jj) = pt2d_array(ii)%pt2d(nldi     , nlej) 
    596                pt2d_array(ii)%pt2d(nlei+1:nlci  , jj) = pt2d_array(ii)%pt2d(     nlei, nlej)  
    597             END DO 
    598             DO ji = nlci+1, jpi                 ! added column(s) (full) 
    599                pt2d_array(ii)%pt2d(ji, nldj  :nlej  ) = pt2d_array(ii)%pt2d(nlei, nldj:nlej) 
    600                pt2d_array(ii)%pt2d(ji, 1     :nldj-1) = pt2d_array(ii)%pt2d(nlei, nldj     ) 
    601                pt2d_array(ii)%pt2d(ji, nlej+1:jpj   ) = pt2d_array(ii)%pt2d(nlei,      nlej) 
    602             END DO 
    603             ! 
    604          ELSE                              ! standard close or cyclic treatment 
    605             ! 
    606             !                                   ! East-West boundaries 
    607             IF( nbondi == 2 .AND.   &                ! Cyclic east-west 
    608                &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    609                pt2d_array(ii)%pt2d(  1  , : ) = pt2d_array(ii)%pt2d( jpim1, : )                                    ! west 
    610                pt2d_array(ii)%pt2d( jpi , : ) = pt2d_array(ii)%pt2d(   2  , : )                                    ! east 
    611             ELSE                                     ! closed 
    612                IF( .NOT. type_array(ii) == 'F' )   pt2d_array(ii)%pt2d(            1 : jpreci,:) = zland    ! south except F-point 
    613                                                    pt2d_array(ii)%pt2d(nlci-jpreci+1 : jpi   ,:) = zland    ! north 
    614             ENDIF 
    615                                                 ! Noth-South boundaries 
    616             IF ( nbondj == 2 .AND. jperio == 7 )    THEN !* cyclic north south 
    617                pt2d_array(ii)%pt2d(:, 1   ) =   pt2d_array(ii)%pt2d(:, jpjm1 ) 
    618                pt2d_array(ii)%pt2d(:, jpj ) =   pt2d_array(ii)%pt2d(:, 2 )           
    619             ELSE   !              
    620                !                                   ! North-South boundaries (closed) 
    621                IF( .NOT. type_array(ii) == 'F' )   pt2d_array(ii)%pt2d(:,             1:jprecj ) = zland    ! south except F-point 
    622                                                    pt2d_array(ii)%pt2d(:, nlcj-jprecj+1:jpj    ) = zland    ! north 
    623             ! 
    624             ENDIF 
    625           ENDIF 
    626       END DO 
    627  
    628       ! 2. East and west directions exchange 
    629       ! ------------------------------------ 
    630       ! we play with the neigbours AND the row number because of the periodicity 
    631       ! 
    632       DO ii = 1 , num_fields 
    633          SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    634          CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    635             iihom = nlci-nreci 
    636             DO jl = 1, jpreci 
    637                zt2ew( : , jl , ii ) = pt2d_array(ii)%pt2d( jpreci+jl , : ) 
    638                zt2we( : , jl , ii ) = pt2d_array(ii)%pt2d( iihom +jl , : ) 
    639             END DO 
    640          END SELECT 
    641       END DO 
    642       ! 
    643       !                           ! Migrations 
    644       imigr = jpreci * jpj 
    645       ! 
    646       SELECT CASE ( nbondi ) 
    647       CASE ( -1 ) 
    648          CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req1 ) 
    649          CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 
    650          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    651       CASE ( 0 ) 
    652          CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 
    653          CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req2 ) 
    654          CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 
    655          CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 
    656          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    657          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    658       CASE ( 1 ) 
    659          CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 
    660          CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 
    661          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    662       END SELECT 
    663       ! 
    664       !                           ! Write Dirichlet lateral conditions 
    665       iihom = nlci - jpreci 
    666       ! 
    667  
    668       DO ii = 1 , num_fields 
    669          SELECT CASE ( nbondi ) 
    670          CASE ( -1 ) 
    671             DO jl = 1, jpreci 
    672                pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 
    673             END DO 
    674          CASE ( 0 ) 
    675             DO jl = 1, jpreci 
    676                pt2d_array(ii)%pt2d( jl , : ) = zt2we(:,jl,num_fields+ii) 
    677                pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 
    678             END DO 
    679          CASE ( 1 ) 
    680             DO jl = 1, jpreci 
    681                pt2d_array(ii)%pt2d( jl , : )= zt2we(:,jl,num_fields+ii) 
    682             END DO 
    683          END SELECT 
    684       END DO 
    685        
    686       ! 3. North and south directions 
    687       ! ----------------------------- 
    688       ! always closed : we play only with the neigbours 
    689       ! 
    690       !First Array 
    691       DO ii = 1 , num_fields 
    692          IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    693             ijhom = nlcj-nrecj 
    694             DO jl = 1, jprecj 
    695                zt2sn(:,jl , ii) = pt2d_array(ii)%pt2d( : , ijhom +jl ) 
    696                zt2ns(:,jl , ii) = pt2d_array(ii)%pt2d( : , jprecj+jl ) 
    697             END DO 
    698          ENDIF 
    699       END DO 
    700       ! 
    701       !                           ! Migrations 
    702       imigr = jprecj * jpi 
    703       ! 
    704       SELECT CASE ( nbondj ) 
    705       CASE ( -1 ) 
    706          CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req1 ) 
    707          CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 
    708          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    709       CASE ( 0 ) 
    710          CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 
    711          CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req2 ) 
    712          CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 
    713          CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 
    714          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    715          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    716       CASE ( 1 ) 
    717          CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 
    718          CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 
    719          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    720       END SELECT 
    721       ! 
    722       !                           ! Write Dirichlet lateral conditions 
    723       ijhom = nlcj - jprecj 
    724       ! 
    725  
    726       DO ii = 1 , num_fields 
    727          !First Array 
    728          SELECT CASE ( nbondj ) 
    729          CASE ( -1 ) 
    730             DO jl = 1, jprecj 
    731                pt2d_array(ii)%pt2d( : , ijhom+jl ) = zt2ns( : , jl , num_fields+ii ) 
    732             END DO 
    733          CASE ( 0 ) 
    734             DO jl = 1, jprecj 
    735                pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii) 
    736                pt2d_array(ii)%pt2d( : , ijhom + jl ) = zt2ns( : , jl , num_fields + ii ) 
    737             END DO 
    738          CASE ( 1 ) 
    739             DO jl = 1, jprecj 
    740                pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii ) 
    741             END DO 
    742          END SELECT 
    743       END DO 
    744        
    745       ! 4. north fold treatment 
    746       ! ----------------------- 
    747       ! 
    748          !First Array 
    749       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    750          ! 
    751          SELECT CASE ( jpni ) 
    752          CASE ( 1 )     ;    
    753              DO ii = 1 , num_fields   
    754                        CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
    755              END DO 
    756          CASE DEFAULT   ;   CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields )   ! for all northern procs. 
    757          END SELECT 
    758          ! 
    759       ENDIF 
    760         ! 
    761       ! 
    762       DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
    763       ! 
    764    END SUBROUTINE mpp_lnk_2d_multiple 
    765  
    766     
    767    SUBROUTINE load_array( pt2d, cd_type, psgn, pt2d_array, type_array, psgn_array, num_fields ) 
    768       !!--------------------------------------------------------------------- 
    769       REAL(wp), DIMENSION(jpi,jpj), TARGET, INTENT(inout) ::   pt2d    ! Second 2D array on which the boundary condition is applied 
    770       CHARACTER(len=1)                    , INTENT(in   ) ::   cd_type ! define the nature of ptab array grid-points 
    771       REAL(wp)                            , INTENT(in   ) ::   psgn    ! =-1 the sign change across the north fold boundary 
    772       TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array 
    773       CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of ptab array grid-points 
    774       REAL(wp)         , DIMENSION(9) ::   psgn_array    ! =-1 the sign change across the north fold boundary 
    775       INTEGER                            , INTENT (inout) :: num_fields  
    776       !!--------------------------------------------------------------------- 
    777       num_fields = num_fields + 1 
    778       pt2d_array(num_fields)%pt2d => pt2d 
    779       type_array(num_fields)      =  cd_type 
    780       psgn_array(num_fields)      =  psgn 
    781    END SUBROUTINE load_array 
     336   !!---------------------------------------------------------------------- 
     337   !!                   ***  routine mpp_lnk_(2,3,4)d  *** 
     338   !! 
     339   !!   * Argument : dummy argument use in mpp_lnk_... routines 
     340   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
     341   !!                cd_nat :   nature of array grid-points 
     342   !!                psgn   :   sign used across the north fold boundary 
     343   !!                kfld   :   optional, number of pt3d arrays 
     344   !!                cd_mpp :   optional, fill the overlap area only 
     345   !!                pval   :   optional, background value (used at closed boundaries) 
     346   !!---------------------------------------------------------------------- 
     347   ! 
     348   !                       !==  2D array and array of 2D pointer  ==! 
     349   ! 
     350#  define DIM_2d 
     351#     define ROUTINE_LNK           mpp_lnk_2d 
     352#     include "mpp_lnk_generic.h90" 
     353#     undef ROUTINE_LNK 
     354#     define MULTI 
     355#     define ROUTINE_LNK           mpp_lnk_2d_ptr 
     356#     include "mpp_lnk_generic.h90" 
     357#     undef ROUTINE_LNK 
     358#     undef MULTI 
     359#  undef DIM_2d 
     360   ! 
     361   !                       !==  3D array and array of 3D pointer  ==! 
     362   ! 
     363#  define DIM_3d 
     364#     define ROUTINE_LNK           mpp_lnk_3d 
     365#     include "mpp_lnk_generic.h90" 
     366#     undef ROUTINE_LNK 
     367#     define MULTI 
     368#     define ROUTINE_LNK           mpp_lnk_3d_ptr 
     369#     include "mpp_lnk_generic.h90" 
     370#     undef ROUTINE_LNK 
     371#     undef MULTI 
     372#  undef DIM_3d 
     373   ! 
     374   !                       !==  4D array and array of 4D pointer  ==! 
     375   ! 
     376#  define DIM_4d 
     377#     define ROUTINE_LNK           mpp_lnk_4d 
     378#     include "mpp_lnk_generic.h90" 
     379#     undef ROUTINE_LNK 
     380#     define MULTI 
     381#     define ROUTINE_LNK           mpp_lnk_4d_ptr 
     382#     include "mpp_lnk_generic.h90" 
     383#     undef ROUTINE_LNK 
     384#     undef MULTI 
     385#  undef DIM_4d 
     386 
     387   !!---------------------------------------------------------------------- 
     388   !!                   ***  routine mpp_nfd_(2,3,4)d  *** 
     389   !! 
     390   !!   * Argument : dummy argument use in mpp_nfd_... routines 
     391   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
     392   !!                cd_nat :   nature of array grid-points 
     393   !!                psgn   :   sign used across the north fold boundary 
     394   !!                kfld   :   optional, number of pt3d arrays 
     395   !!                cd_mpp :   optional, fill the overlap area only 
     396   !!                pval   :   optional, background value (used at closed boundaries) 
     397   !!---------------------------------------------------------------------- 
     398   ! 
     399   !                       !==  2D array and array of 2D pointer  ==! 
     400   ! 
     401#  define DIM_2d 
     402#     define ROUTINE_NFD           mpp_nfd_2d 
     403#     include "mpp_nfd_generic.h90" 
     404#     undef ROUTINE_NFD 
     405#     define MULTI 
     406#     define ROUTINE_NFD           mpp_nfd_2d_ptr 
     407#     include "mpp_nfd_generic.h90" 
     408#     undef ROUTINE_NFD 
     409#     undef MULTI 
     410#  undef DIM_2d 
     411   ! 
     412   !                       !==  3D array and array of 3D pointer  ==! 
     413   ! 
     414#  define DIM_3d 
     415#     define ROUTINE_NFD           mpp_nfd_3d 
     416#     include "mpp_nfd_generic.h90" 
     417#     undef ROUTINE_NFD 
     418#     define MULTI 
     419#     define ROUTINE_NFD           mpp_nfd_3d_ptr 
     420#     include "mpp_nfd_generic.h90" 
     421#     undef ROUTINE_NFD 
     422#     undef MULTI 
     423#  undef DIM_3d 
     424   ! 
     425   !                       !==  4D array and array of 4D pointer  ==! 
     426   ! 
     427#  define DIM_4d 
     428#     define ROUTINE_NFD           mpp_nfd_4d 
     429#     include "mpp_nfd_generic.h90" 
     430#     undef ROUTINE_NFD 
     431#     define MULTI 
     432#     define ROUTINE_NFD           mpp_nfd_4d_ptr 
     433#     include "mpp_nfd_generic.h90" 
     434#     undef ROUTINE_NFD 
     435#     undef MULTI 
     436#  undef DIM_4d 
     437 
     438 
     439   !!---------------------------------------------------------------------- 
     440   !!                   ***  routine mpp_lnk_bdy_(2,3,4)d  *** 
     441   !! 
     442   !!   * Argument : dummy argument use in mpp_lnk_... routines 
     443   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
     444   !!                cd_nat :   nature of array grid-points 
     445   !!                psgn   :   sign used across the north fold boundary 
     446   !!                kb_bdy :   BDY boundary set 
     447   !!                kfld   :   optional, number of pt3d arrays 
     448   !!---------------------------------------------------------------------- 
     449   ! 
     450   !                       !==  2D array and array of 2D pointer  ==! 
     451   ! 
     452#  define DIM_2d 
     453#     define ROUTINE_BDY           mpp_lnk_bdy_2d 
     454#     include "mpp_bdy_generic.h90" 
     455#     undef ROUTINE_BDY 
     456#     define MULTI 
     457#     define ROUTINE_BDY           mpp_lnk_bdy_2d_ptr 
     458#     include "mpp_bdy_generic.h90" 
     459#     undef ROUTINE_BDY 
     460#     undef MULTI 
     461#  undef DIM_2d 
     462   ! 
     463   !                       !==  3D array and array of 3D pointer  ==! 
     464   ! 
     465#  define DIM_3d 
     466#     define ROUTINE_BDY           mpp_lnk_bdy_3d 
     467#     include "mpp_bdy_generic.h90" 
     468#     undef ROUTINE_BDY 
     469#     define MULTI 
     470#     define ROUTINE_BDY           mpp_lnk_bdy_3d_ptr 
     471#     include "mpp_bdy_generic.h90" 
     472#     undef ROUTINE_BDY 
     473#     undef MULTI 
     474#  undef DIM_3d 
     475   ! 
     476   !                       !==  4D array and array of 4D pointer  ==! 
     477   ! 
     478!!#  define DIM_4d 
     479!!#     define ROUTINE_BDY           mpp_lnk_bdy_4d 
     480!!#     include "mpp_bdy_generic.h90" 
     481!!#     undef ROUTINE_BDY 
     482!!#     define MULTI 
     483!!#     define ROUTINE_BDY           mpp_lnk_bdy_4d_ptr 
     484!!#     include "mpp_bdy_generic.h90" 
     485!!#     undef ROUTINE_BDY 
     486!!#     undef MULTI 
     487!!#  undef DIM_4d 
     488 
     489   !!---------------------------------------------------------------------- 
     490   !! 
     491   !!   load_array  &   mpp_lnk_2d_9    à generaliser a 3D et 4D 
    782492    
    783493    
    784    SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
    785       &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
    786       &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
    787       !!--------------------------------------------------------------------- 
    788       ! Second 2D array on which the boundary condition is applied 
    789       REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA     
    790       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
    791       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI  
    792       ! define the nature of ptab array grid-points 
    793       CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
    794       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
    795       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
    796       ! =-1 the sign change across the north fold boundary 
    797       REAL(wp)                                      , INTENT(in   ) ::   psgnA     
    798       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
    799       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI    
    800       CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    801       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    802       !! 
    803       TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array  
    804       CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of ptab array grid-points 
    805       !                                                         ! = T , U , V , F , W and I points 
    806       REAL(wp)         , DIMENSION(9) ::   psgn_array    ! =-1 the sign change across the north fold boundary 
    807       INTEGER :: num_fields 
    808       !!--------------------------------------------------------------------- 
    809       ! 
    810       num_fields = 0 
    811       ! 
    812       ! Load the first array 
    813       CALL load_array( pt2dA, cd_typeA, psgnA, pt2d_array, type_array, psgn_array, num_fields ) 
    814       ! 
    815       ! Look if more arrays are added 
    816       IF( PRESENT(psgnB) )   CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields) 
    817       IF( PRESENT(psgnC) )   CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields) 
    818       IF( PRESENT(psgnD) )   CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields) 
    819       IF( PRESENT(psgnE) )   CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields) 
    820       IF( PRESENT(psgnF) )   CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields) 
    821       IF( PRESENT(psgnG) )   CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields) 
    822       IF( PRESENT(psgnH) )   CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields) 
    823       IF( PRESENT(psgnI) )   CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields) 
    824       ! 
    825       CALL mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, num_fields, cd_mpp,pval ) 
    826       ! 
    827    END SUBROUTINE mpp_lnk_2d_9 
    828  
    829  
    830    SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    831       !!---------------------------------------------------------------------- 
    832       !!                  ***  routine mpp_lnk_2d  *** 
    833       !! 
    834       !! ** Purpose :   Message passing manadgement for 2d array 
    835       !! 
    836       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    837       !!      between processors following neighboring subdomains. 
    838       !!            domain parameters 
    839       !!                    nlci   : first dimension of the local subdomain 
    840       !!                    nlcj   : second dimension of the local subdomain 
    841       !!                    nbondi : mark for "east-west local boundary" 
    842       !!                    nbondj : mark for "north-south local boundary" 
    843       !!                    noea   : number for local neighboring processors 
    844       !!                    nowe   : number for local neighboring processors 
    845       !!                    noso   : number for local neighboring processors 
    846       !!                    nono   : number for local neighboring processors 
    847       !! 
    848       !!---------------------------------------------------------------------- 
    849       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied 
    850       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
    851       !                                                         ! = T , U , V , F , W and I points 
    852       REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    853       !                                                         ! =  1. , the sign is kept 
    854       CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    855       REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    856       !! 
    857       INTEGER  ::   ji, jj, jl   ! dummy loop indices 
    858       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    859       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    860       REAL(wp) ::   zland 
    861       INTEGER, DIMENSION(MPI_STATUS_SIZE)     ::   ml_stat       ! for key_mpi_isend 
    862       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
    863       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
    864       !!---------------------------------------------------------------------- 
    865       ! 
    866       ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  & 
    867          &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   ) 
    868       ! 
    869       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    870       ELSE                         ;   zland = 0._wp     ! zero by default 
    871       ENDIF 
    872  
    873       ! 1. standard boundary treatment 
    874       ! ------------------------------ 
    875       ! 
    876       IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
    877          ! 
    878          ! WARNING pt2d is defined only between nld and nle 
    879          DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    880             pt2d(nldi  :nlei  , jj          ) = pt2d(nldi:nlei,     nlej) 
    881             pt2d(1     :nldi-1, jj          ) = pt2d(nldi     ,     nlej) 
    882             pt2d(nlei+1:nlci  , jj          ) = pt2d(     nlei,     nlej) 
    883          END DO 
    884          DO ji = nlci+1, jpi                 ! added column(s) (full) 
    885             pt2d(ji           ,nldj  :nlej  ) = pt2d(     nlei,nldj:nlej) 
    886             pt2d(ji           ,1     :nldj-1) = pt2d(     nlei,nldj     ) 
    887             pt2d(ji           ,nlej+1:jpj   ) = pt2d(     nlei,     nlej) 
    888          END DO 
    889          ! 
    890       ELSE                              ! standard close or cyclic treatment 
    891          ! 
    892          !                                   ! East-West boundaries 
    893          IF( nbondi == 2 .AND.   &                ! Cyclic east-west 
    894             &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    895             pt2d( 1 ,:) = pt2d(jpim1,:)                                    ! west 
    896             pt2d(jpi,:) = pt2d(  2  ,:)                                    ! east 
    897          ELSE                                     ! closed 
    898             IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point 
    899                                          pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north 
    900          ENDIF 
    901                                             ! North-South boudaries 
    902          IF ( nbondj == 2 .AND. jperio == 7 )    THEN !* cyclic north south 
    903             pt2d(:,  1 ) = pt2d(:,jpjm1) 
    904             pt2d(:, jpj) = pt2d(:,    2) 
    905          ELSE     
    906          !                                   ! North-South boundaries (closed) 
    907             IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland    !south except F-point 
    908                                          pt2d(:,nlcj-jprecj+1:jpj   ) = zland    ! north 
    909          ENDIF      
    910       ENDIF 
    911  
    912       ! 2. East and west directions exchange 
    913       ! ------------------------------------ 
    914       ! we play with the neigbours AND the row number because of the periodicity 
    915       ! 
    916       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    917       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    918          iihom = nlci-nreci 
    919          DO jl = 1, jpreci 
    920             zt2ew(:,jl,1) = pt2d(jpreci+jl,:) 
    921             zt2we(:,jl,1) = pt2d(iihom +jl,:) 
    922          END DO 
    923       END SELECT 
    924       ! 
    925       !                           ! Migrations 
    926       imigr = jpreci * jpj 
    927       ! 
    928       SELECT CASE ( nbondi ) 
    929       CASE ( -1 ) 
    930          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 
    931          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    932          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    933       CASE ( 0 ) 
    934          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    935          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 
    936          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    937          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    938          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    939          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    940       CASE ( 1 ) 
    941          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    942          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    943          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    944       END SELECT 
    945       ! 
    946       !                           ! Write Dirichlet lateral conditions 
    947       iihom = nlci - jpreci 
    948       ! 
    949       SELECT CASE ( nbondi ) 
    950       CASE ( -1 ) 
    951          DO jl = 1, jpreci 
    952             pt2d(iihom+jl,:) = zt2ew(:,jl,2) 
    953          END DO 
    954       CASE ( 0 ) 
    955          DO jl = 1, jpreci 
    956             pt2d(jl      ,:) = zt2we(:,jl,2) 
    957             pt2d(iihom+jl,:) = zt2ew(:,jl,2) 
    958          END DO 
    959       CASE ( 1 ) 
    960          DO jl = 1, jpreci 
    961             pt2d(jl      ,:) = zt2we(:,jl,2) 
    962          END DO 
    963       END SELECT 
    964  
    965  
    966       ! 3. North and south directions 
    967       ! ----------------------------- 
    968       ! always closed : we play only with the neigbours 
    969       ! 
    970       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    971          ijhom = nlcj-nrecj 
    972          DO jl = 1, jprecj 
    973             zt2sn(:,jl,1) = pt2d(:,ijhom +jl) 
    974             zt2ns(:,jl,1) = pt2d(:,jprecj+jl) 
    975          END DO 
    976       ENDIF 
    977       ! 
    978       !                           ! Migrations 
    979       imigr = jprecj * jpi 
    980       ! 
    981       SELECT CASE ( nbondj ) 
    982       CASE ( -1 ) 
    983          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 
    984          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    985          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    986       CASE ( 0 ) 
    987          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    988          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 
    989          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    990          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    991          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    992          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    993       CASE ( 1 ) 
    994          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    995          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    996          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    997       END SELECT 
    998       ! 
    999       !                           ! Write Dirichlet lateral conditions 
    1000       ijhom = nlcj - jprecj 
    1001       ! 
    1002       SELECT CASE ( nbondj ) 
    1003       CASE ( -1 ) 
    1004          DO jl = 1, jprecj 
    1005             pt2d(:,ijhom+jl) = zt2ns(:,jl,2) 
    1006          END DO 
    1007       CASE ( 0 ) 
    1008          DO jl = 1, jprecj 
    1009             pt2d(:,jl      ) = zt2sn(:,jl,2) 
    1010             pt2d(:,ijhom+jl) = zt2ns(:,jl,2) 
    1011          END DO 
    1012       CASE ( 1 ) 
    1013          DO jl = 1, jprecj 
    1014             pt2d(:,jl      ) = zt2sn(:,jl,2) 
    1015          END DO 
    1016       END SELECT 
    1017  
    1018  
    1019       ! 4. north fold treatment 
    1020       ! ----------------------- 
    1021       ! 
    1022       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    1023          ! 
    1024          SELECT CASE ( jpni ) 
    1025          CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp 
    1026          CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs. 
    1027          END SELECT 
    1028          ! 
    1029       ENDIF 
    1030       ! 
    1031       DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
    1032       ! 
    1033    END SUBROUTINE mpp_lnk_2d 
    1034  
    1035  
    1036    SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn ) 
    1037       !!---------------------------------------------------------------------- 
    1038       !!                  ***  routine mpp_lnk_3d_gather  *** 
    1039       !! 
    1040       !! ** Purpose :   Message passing manadgement for two 3D arrays 
    1041       !! 
    1042       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1043       !!      between processors following neighboring subdomains. 
    1044       !!            domain parameters 
    1045       !!                    nlci   : first dimension of the local subdomain 
    1046       !!                    nlcj   : second dimension of the local subdomain 
    1047       !!                    nbondi : mark for "east-west local boundary" 
    1048       !!                    nbondj : mark for "north-south local boundary" 
    1049       !!                    noea   : number for local neighboring processors 
    1050       !!                    nowe   : number for local neighboring processors 
    1051       !!                    noso   : number for local neighboring processors 
    1052       !!                    nono   : number for local neighboring processors 
    1053       !! 
    1054       !! ** Action  :   ptab1 and ptab2  with update value at its periphery 
    1055       !! 
    1056       !!---------------------------------------------------------------------- 
    1057       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab1     ! first and second 3D array on which 
    1058       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab2     ! the boundary condition is applied 
    1059       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1  ! nature of ptab1 and ptab2 arrays 
    1060       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type2  ! i.e. grid-points = T , U , V , F or W points 
    1061       REAL(wp)                        , INTENT(in   ) ::   psgn      ! =-1 the sign change across the north fold boundary 
    1062       !!                                                             ! =  1. , the sign is kept 
    1063       INTEGER  ::   jl   ! dummy loop indices 
    1064       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    1065       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1066       INTEGER , DIMENSION(MPI_STATUS_SIZE)        ::   ml_stat   ! for key_mpi_isend 
    1067       REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zt4ns, zt4sn   ! 2 x 3d for north-south & south-north 
    1068       REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zt4ew, zt4we   ! 2 x 3d for east-west & west-east 
    1069       !!---------------------------------------------------------------------- 
    1070       ! 
    1071       ALLOCATE( zt4ns(jpi,jprecj,jpk,2,2), zt4sn(jpi,jprecj,jpk,2,2) ,    & 
    1072          &      zt4ew(jpj,jpreci,jpk,2,2), zt4we(jpj,jpreci,jpk,2,2) ) 
    1073       ! 
    1074       ! 1. standard boundary treatment 
    1075       ! ------------------------------ 
    1076       !                                      ! East-West boundaries 
    1077       !                                           !* Cyclic east-west 
    1078       IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    1079          ptab1( 1 ,:,:) = ptab1(jpim1,:,:) 
    1080          ptab1(jpi,:,:) = ptab1(  2  ,:,:) 
    1081          ptab2( 1 ,:,:) = ptab2(jpim1,:,:) 
    1082          ptab2(jpi,:,:) = ptab2(  2  ,:,:) 
    1083       ELSE                                        !* closed 
    1084          IF( .NOT. cd_type1 == 'F' )   ptab1(     1       :jpreci,:,:) = 0.e0    ! south except at F-point 
    1085          IF( .NOT. cd_type2 == 'F' )   ptab2(     1       :jpreci,:,:) = 0.e0 
    1086                                        ptab1(nlci-jpreci+1:jpi   ,:,:) = 0.e0    ! north 
    1087                                        ptab2(nlci-jpreci+1:jpi   ,:,:) = 0.e0 
    1088       ENDIF 
    1089                                             ! North-South boundaries 
    1090       IF ( nbondj == 2 .AND. jperio == 7 )    THEN !* cyclic north south 
    1091          ptab1(:,     1       ,:) = ptab1(: ,  jpjm1 , :) 
    1092          ptab1(:,   jpj       ,:) = ptab1(: ,      2 , :) 
    1093          ptab2(:,     1       ,:) = ptab2(: ,  jpjm1 , :) 
    1094          ptab2(:,   jpj       ,:) = ptab2(: ,      2 , :) 
    1095       ELSE      
    1096       !                                      ! North-South boundaries closed 
    1097       IF( .NOT. cd_type1 == 'F' )   ptab1(:,     1       :jprecj,:) = 0.e0    ! south except at F-point 
    1098       IF( .NOT. cd_type2 == 'F' )   ptab2(:,     1       :jprecj,:) = 0.e0 
    1099                                     ptab1(:,nlcj-jprecj+1:jpj   ,:) = 0.e0    ! north 
    1100                                     ptab2(:,nlcj-jprecj+1:jpj   ,:) = 0.e0 
    1101       ENDIF      
    1102  
    1103       ! 2. East and west directions exchange 
    1104       ! ------------------------------------ 
    1105       ! we play with the neigbours AND the row number because of the periodicity 
    1106       ! 
    1107       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    1108       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1109          iihom = nlci-nreci 
    1110          DO jl = 1, jpreci 
    1111             zt4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:) 
    1112             zt4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:) 
    1113             zt4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:) 
    1114             zt4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:) 
    1115          END DO 
    1116       END SELECT 
    1117       ! 
    1118       !                           ! Migrations 
    1119       imigr = jpreci * jpj * jpk *2 
    1120       ! 
    1121       SELECT CASE ( nbondi ) 
    1122       CASE ( -1 ) 
    1123          CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req1 ) 
    1124          CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea ) 
    1125          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1126       CASE ( 0 ) 
    1127          CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 
    1128          CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req2 ) 
    1129          CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea ) 
    1130          CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe ) 
    1131          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1132          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    1133       CASE ( 1 ) 
    1134          CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 
    1135          CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe ) 
    1136          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1137       END SELECT 
    1138       ! 
    1139       !                           ! Write Dirichlet lateral conditions 
    1140       iihom = nlci - jpreci 
    1141       ! 
    1142       SELECT CASE ( nbondi ) 
    1143       CASE ( -1 ) 
    1144          DO jl = 1, jpreci 
    1145             ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2) 
    1146             ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2) 
    1147          END DO 
    1148       CASE ( 0 ) 
    1149          DO jl = 1, jpreci 
    1150             ptab1(jl      ,:,:) = zt4we(:,jl,:,1,2) 
    1151             ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2) 
    1152             ptab2(jl      ,:,:) = zt4we(:,jl,:,2,2) 
    1153             ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2) 
    1154          END DO 
    1155       CASE ( 1 ) 
    1156          DO jl = 1, jpreci 
    1157             ptab1(jl      ,:,:) = zt4we(:,jl,:,1,2) 
    1158             ptab2(jl      ,:,:) = zt4we(:,jl,:,2,2) 
    1159          END DO 
    1160       END SELECT 
    1161  
    1162  
    1163       ! 3. North and south directions 
    1164       ! ----------------------------- 
    1165       ! always closed : we play only with the neigbours 
    1166       ! 
    1167       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    1168          ijhom = nlcj - nrecj 
    1169          DO jl = 1, jprecj 
    1170             zt4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:) 
    1171             zt4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:) 
    1172             zt4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:) 
    1173             zt4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:) 
    1174          END DO 
    1175       ENDIF 
    1176       ! 
    1177       !                           ! Migrations 
    1178       imigr = jprecj * jpi * jpk * 2 
    1179       ! 
    1180       SELECT CASE ( nbondj ) 
    1181       CASE ( -1 ) 
    1182          CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req1 ) 
    1183          CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono ) 
    1184          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1185       CASE ( 0 ) 
    1186          CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
    1187          CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req2 ) 
    1188          CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono ) 
    1189          CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso ) 
    1190          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1191          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    1192       CASE ( 1 ) 
    1193          CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
    1194          CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso ) 
    1195          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1196       END SELECT 
    1197       ! 
    1198       !                           ! Write Dirichlet lateral conditions 
    1199       ijhom = nlcj - jprecj 
    1200       ! 
    1201       SELECT CASE ( nbondj ) 
    1202       CASE ( -1 ) 
    1203          DO jl = 1, jprecj 
    1204             ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2) 
    1205             ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2) 
    1206          END DO 
    1207       CASE ( 0 ) 
    1208          DO jl = 1, jprecj 
    1209             ptab1(:,jl      ,:) = zt4sn(:,jl,:,1,2) 
    1210             ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2) 
    1211             ptab2(:,jl      ,:) = zt4sn(:,jl,:,2,2) 
    1212             ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2) 
    1213          END DO 
    1214       CASE ( 1 ) 
    1215          DO jl = 1, jprecj 
    1216             ptab1(:,jl,:) = zt4sn(:,jl,:,1,2) 
    1217             ptab2(:,jl,:) = zt4sn(:,jl,:,2,2) 
    1218          END DO 
    1219       END SELECT 
    1220  
    1221  
    1222       ! 4. north fold treatment 
    1223       ! ----------------------- 
    1224       IF( npolj /= 0 ) THEN 
    1225          ! 
    1226          SELECT CASE ( jpni ) 
    1227          CASE ( 1 ) 
    1228             CALL lbc_nfd      ( ptab1, cd_type1, psgn )   ! only for northern procs. 
    1229             CALL lbc_nfd      ( ptab2, cd_type2, psgn ) 
    1230          CASE DEFAULT 
    1231             CALL mpp_lbc_north( ptab1, cd_type1, psgn )   ! for all northern procs. 
    1232             CALL mpp_lbc_north (ptab2, cd_type2, psgn) 
    1233          END SELECT 
    1234          ! 
    1235       ENDIF 
    1236       ! 
    1237       DEALLOCATE( zt4ns, zt4sn, zt4ew, zt4we ) 
    1238       ! 
    1239    END SUBROUTINE mpp_lnk_3d_gather 
     494   !!    mpp_lnk_2d_e     utilisé dans ICB  
     495 
     496 
     497   !!    mpp_lnk_sum_2d et 3D   ====>>>>>>   à virer du code !!!! 
     498    
     499    
     500   !!---------------------------------------------------------------------- 
    1240501 
    1241502 
    … …  
    1284545 
    1285546 
    1286       ! 1. standard boundary treatment 
     547      ! 1. standard boundary treatment   (CAUTION: the order matters Here !!!! ) 
    1287548      ! ------------------------------ 
    1288       ! Order matters Here !!!! 
    1289       ! 
    1290                                            ! North-South cyclic 
    1291       IF ( nbondj == 2 .AND. jperio == 7 )    THEN !* cyclic north south 
    1292          pt2d(:, 1-jprj:  1     ) = pt2d ( :, jpjm1-jprj:jpjm1) 
     549      !                                !== North-South boundaries 
     550      !                                      !* cyclic 
     551      IF( nbondj == 2 .AND. jperio == 7 ) THEN 
     552         pt2d(:, 1-jprj:  1     ) = pt2d ( :, jpjm1-jprj:jpjm1 ) 
    1293553         pt2d(:, jpj   :jpj+jprj) = pt2d ( :, 2         :2+jprj) 
    1294       ELSE 
    1295          
    1296       !                                      !* North-South boundaries (closed) 
    1297       IF( .NOT. cd_type == 'F' )   pt2d(:,  1-jprj   :  jprecj  ) = 0.e0    ! south except at F-point 
    1298                                    pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0.e0    ! north 
    1299       ENDIF 
    1300                                  
    1301       !                                      ! East-West boundaries 
    1302       !                                           !* Cyclic east-west 
     554      ELSE                                   !* closed 
     555         IF( .NOT. cd_type == 'F' )   pt2d(:,  1-jprj   :  jprecj  ) = 0._wp     ! south except at F-point 
     556                                      pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0._wp     ! north 
     557      ENDIF 
     558      !                                !== East-West boundaries 
     559      !                                      !* Cyclic east-west 
    1303560      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    1304          pt2d(1-jpri:     1    ,:) = pt2d(jpim1-jpri:  jpim1 ,:)       ! east 
    1305          pt2d(   jpi  :jpi+jpri,:) = pt2d(     2      :2+jpri,:)       ! west 
    1306          ! 
    1307       ELSE                                        !* closed 
    1308          IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0.e0    ! south except at F-point 
    1309                                       pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0    ! north 
    1310       ENDIF 
    1311       ! 
    1312  
     561         pt2d(1-jpri:     1    ,:) = pt2d(jpim1-jpri:  jpim1 ,:)              ! east 
     562         pt2d(   jpi  :jpi+jpri,:) = pt2d(     2      :2+jpri,:)              ! west 
     563      ELSE                                   !* closed 
     564         IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0._wp  ! south except at F-point 
     565                                      pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp  ! north 
     566      ENDIF 
     567      ! 
    1313568      ! north fold treatment 
    1314       ! ----------------------- 
     569      ! -------------------- 
    1315570      IF( npolj /= 0 ) THEN 
    1316571         ! 
    1317572         SELECT CASE ( jpni ) 
    1318          CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 
    1319          CASE DEFAULT   ;   CALL mpp_lbc_north_e( pt2d                    , cd_type, psgn               ) 
     573!!gm ERROR        CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 
     574!!gm ERROR         CASE DEFAULT   ;   CALL mpp_lbc_north_e( pt2d                  , cd_type, psgn             ) 
    1320575         END SELECT 
    1321576         ! 
    … …  
    1375630      END SELECT 
    1376631 
    1377  
    1378632      ! 3. North and south directions 
    1379633      ! ----------------------------- 
    … …  
    1430684   END SUBROUTINE mpp_lnk_2d_e 
    1431685 
    1432    SUBROUTINE mpp_lnk_sum_3d( ptab, cd_type, psgn, cd_mpp, pval ) 
    1433       !!---------------------------------------------------------------------- 
    1434       !!                  ***  routine mpp_lnk_sum_3d  *** 
    1435       !! 
    1436       !! ** Purpose :   Message passing manadgement (sum the overlap region) 
    1437       !! 
    1438       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1439       !!      between processors following neighboring subdomains. 
    1440       !!            domain parameters 
    1441       !!                    nlci   : first dimension of the local subdomain 
    1442       !!                    nlcj   : second dimension of the local subdomain 
    1443       !!                    nbondi : mark for "east-west local boundary" 
    1444       !!                    nbondj : mark for "north-south local boundary" 
    1445       !!                    noea   : number for local neighboring processors 
    1446       !!                    nowe   : number for local neighboring processors 
    1447       !!                    noso   : number for local neighboring processors 
    1448       !!                    nono   : number for local neighboring processors 
    1449       !! 
    1450       !! ** Action  :   ptab with update value at its periphery 
    1451       !! 
    1452       !!---------------------------------------------------------------------- 
    1453       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
    1454       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
    1455       !                                                             ! = T , U , V , F , W points 
    1456       REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    1457       !                                                             ! =  1. , the sign is kept 
    1458       CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    1459       REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    1460       !! 
    1461       INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
    1462       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    1463       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1464       REAL(wp) ::   zland 
    1465       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    1466       ! 
    1467       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north 
    1468       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east 
    1469  
    1470       !!---------------------------------------------------------------------- 
    1471        
    1472       ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   & 
    1473          &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  ) 
    1474  
    1475       ! 
    1476       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    1477       ELSE                         ;   zland = 0.e0      ! zero by default 
    1478       ENDIF 
    1479  
    1480       ! 1. standard boundary treatment 
    1481       ! ------------------------------ 
    1482       ! 2. East and west directions exchange 
    1483       ! ------------------------------------ 
    1484       ! we play with the neigbours AND the row number because of the periodicity 
    1485       ! 
    1486       SELECT CASE ( nbondi )      ! Read lateral conditions 
    1487       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1488       iihom = nlci-jpreci 
    1489          DO jl = 1, jpreci 
    1490             zt3ew(:,jl,:,1) = ptab(jl      ,:,:) ; ptab(jl      ,:,:) = 0.0_wp 
    1491             zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0.0_wp  
    1492          END DO 
    1493       END SELECT 
    1494       ! 
    1495       !                           ! Migrations 
    1496       imigr = jpreci * jpj * jpk 
    1497       ! 
    1498       SELECT CASE ( nbondi ) 
    1499       CASE ( -1 ) 
    1500          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 
    1501          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    1502          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1503       CASE ( 0 ) 
    1504          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    1505          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 
    1506          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    1507          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    1508          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1509          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    1510       CASE ( 1 ) 
    1511          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    1512          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    1513          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1514       END SELECT 
    1515       ! 
    1516       !                           ! Write lateral conditions 
    1517       iihom = nlci-nreci 
    1518       ! 
    1519       SELECT CASE ( nbondi ) 
    1520       CASE ( -1 ) 
    1521          DO jl = 1, jpreci 
    1522             ptab(iihom+jl,:,:) = ptab(iihom+jl,:,:) + zt3ew(:,jl,:,2) 
    1523          END DO 
    1524       CASE ( 0 ) 
    1525          DO jl = 1, jpreci 
    1526             ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) 
    1527             ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2) 
    1528          END DO 
    1529       CASE ( 1 ) 
    1530          DO jl = 1, jpreci 
    1531             ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) 
    1532          END DO 
    1533       END SELECT 
    1534  
    1535  
    1536       ! 3. North and south directions 
    1537       ! ----------------------------- 
    1538       ! always closed : we play only with the neigbours 
    1539       ! 
    1540       IF( nbondj /= 2 ) THEN      ! Read lateral conditions 
    1541          ijhom = nlcj-jprecj 
    1542          DO jl = 1, jprecj 
    1543             zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:) ; ptab(:,ijhom+jl,:) = 0.0_wp 
    1544             zt3ns(:,jl,:,1) = ptab(:,jl      ,:) ; ptab(:,jl      ,:) = 0.0_wp 
    1545          END DO 
    1546       ENDIF 
    1547       ! 
    1548       !                           ! Migrations 
    1549       imigr = jprecj * jpi * jpk 
    1550       ! 
    1551       SELECT CASE ( nbondj ) 
    1552       CASE ( -1 ) 
    1553          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 
    1554          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    1555          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1556       CASE ( 0 ) 
    1557          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    1558          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 
    1559          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    1560          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    1561          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1562          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    1563       CASE ( 1 ) 
    1564          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    1565          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    1566          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1567       END SELECT 
    1568       ! 
    1569       !                           ! Write lateral conditions 
    1570       ijhom = nlcj-nrecj 
    1571       ! 
    1572       SELECT CASE ( nbondj ) 
    1573       CASE ( -1 ) 
    1574          DO jl = 1, jprecj 
    1575             ptab(:,ijhom+jl,:) = ptab(:,ijhom+jl,:) + zt3ns(:,jl,:,2) 
    1576          END DO 
    1577       CASE ( 0 ) 
    1578          DO jl = 1, jprecj 
    1579             ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl,:,2) 
    1580             ptab(:,ijhom +jl,:) = ptab(:,ijhom +jl,:) + zt3ns(:,jl,:,2) 
    1581          END DO 
    1582       CASE ( 1 ) 
    1583          DO jl = 1, jprecj 
    1584             ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl   ,:,2) 
    1585          END DO 
    1586       END SELECT 
    1587  
    1588  
    1589       ! 4. north fold treatment 
    1590       ! ----------------------- 
    1591       ! 
    1592       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    1593          ! 
    1594          SELECT CASE ( jpni ) 
    1595          CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
    1596          CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
    1597          END SELECT 
    1598          ! 
    1599       ENDIF 
    1600       ! 
    1601       DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) 
    1602       ! 
    1603    END SUBROUTINE mpp_lnk_sum_3d 
    1604  
    1605    SUBROUTINE mpp_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    1606       !!---------------------------------------------------------------------- 
    1607       !!                  ***  routine mpp_lnk_sum_2d  *** 
    1608       !! 
    1609       !! ** Purpose :   Message passing manadgement for 2d array (sum the overlap region) 
    1610       !! 
    1611       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1612       !!      between processors following neighboring subdomains. 
    1613       !!            domain parameters 
    1614       !!                    nlci   : first dimension of the local subdomain 
    1615       !!                    nlcj   : second dimension of the local subdomain 
    1616       !!                    nbondi : mark for "east-west local boundary" 
    1617       !!                    nbondj : mark for "north-south local boundary" 
    1618       !!                    noea   : number for local neighboring processors 
    1619       !!                    nowe   : number for local neighboring processors 
    1620       !!                    noso   : number for local neighboring processors 
    1621       !!                    nono   : number for local neighboring processors 
    1622       !! 
    1623       !!---------------------------------------------------------------------- 
    1624       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied 
    1625       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
    1626       !                                                         ! = T , U , V , F , W and I points 
    1627       REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    1628       !                                                         ! =  1. , the sign is kept 
    1629       CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    1630       REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    1631       !! 
    1632       INTEGER  ::   ji, jj, jl   ! dummy loop indices 
    1633       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    1634       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1635       REAL(wp) ::   zland 
    1636       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    1637       ! 
    1638       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
    1639       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
    1640  
    1641       !!---------------------------------------------------------------------- 
    1642  
    1643       ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  & 
    1644          &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   ) 
    1645  
    1646       ! 
    1647       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    1648       ELSE                         ;   zland = 0.e0      ! zero by default 
    1649       ENDIF 
    1650  
    1651       ! 1. standard boundary treatment 
    1652       ! ------------------------------ 
    1653       ! 2. East and west directions exchange 
    1654       ! ------------------------------------ 
    1655       ! we play with the neigbours AND the row number because of the periodicity 
    1656       ! 
    1657       SELECT CASE ( nbondi )      ! Read lateral conditions 
    1658       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1659          iihom = nlci - jpreci 
    1660          DO jl = 1, jpreci 
    1661             zt2ew(:,jl,1) = pt2d(jl       ,:) ; pt2d(jl       ,:) = 0.0_wp 
    1662             zt2we(:,jl,1) = pt2d(iihom +jl,:) ; pt2d(iihom +jl,:) = 0.0_wp 
    1663          END DO 
    1664       END SELECT 
    1665       ! 
    1666       !                           ! Migrations 
    1667       imigr = jpreci * jpj 
    1668       ! 
    1669       SELECT CASE ( nbondi ) 
    1670       CASE ( -1 ) 
    1671          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 
    1672          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    1673          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1674       CASE ( 0 ) 
    1675          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    1676          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 
    1677          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    1678          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    1679          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1680          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1681       CASE ( 1 ) 
    1682          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    1683          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    1684          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1685       END SELECT 
    1686       ! 
    1687       !                           ! Write lateral conditions 
    1688       iihom = nlci-nreci 
    1689       ! 
    1690       SELECT CASE ( nbondi ) 
    1691       CASE ( -1 ) 
    1692          DO jl = 1, jpreci 
    1693             pt2d(iihom+jl,:) = pt2d(iihom+jl,:) + zt2ew(:,jl,2) 
    1694          END DO 
    1695       CASE ( 0 ) 
    1696          DO jl = 1, jpreci 
    1697             pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) 
    1698             pt2d(iihom +jl,:) = pt2d(iihom +jl,:) + zt2ew(:,jl,2) 
    1699          END DO 
    1700       CASE ( 1 ) 
    1701          DO jl = 1, jpreci 
    1702             pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) 
    1703          END DO 
    1704       END SELECT 
    1705  
    1706  
    1707       ! 3. North and south directions 
    1708       ! ----------------------------- 
    1709       ! always closed : we play only with the neigbours 
    1710       ! 
    1711       IF( nbondj /= 2 ) THEN      ! Read lateral conditions 
    1712          ijhom = nlcj - jprecj 
    1713          DO jl = 1, jprecj 
    1714             zt2sn(:,jl,1) = pt2d(:,ijhom +jl) ; pt2d(:,ijhom +jl) = 0.0_wp 
    1715             zt2ns(:,jl,1) = pt2d(:,jl       ) ; pt2d(:,jl       ) = 0.0_wp 
    1716          END DO 
    1717       ENDIF 
    1718       ! 
    1719       !                           ! Migrations 
    1720       imigr = jprecj * jpi 
    1721       ! 
    1722       SELECT CASE ( nbondj ) 
    1723       CASE ( -1 ) 
    1724          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 
    1725          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    1726          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1727       CASE ( 0 ) 
    1728          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    1729          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 
    1730          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    1731          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    1732          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1733          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1734       CASE ( 1 ) 
    1735          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    1736          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    1737          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1738       END SELECT 
    1739       ! 
    1740       !                           ! Write lateral conditions 
    1741       ijhom = nlcj-nrecj 
    1742       ! 
    1743       SELECT CASE ( nbondj ) 
    1744       CASE ( -1 ) 
    1745          DO jl = 1, jprecj 
    1746             pt2d(:,ijhom+jl) = pt2d(:,ijhom+jl) + zt2ns(:,jl,2) 
    1747          END DO 
    1748       CASE ( 0 ) 
    1749          DO jl = 1, jprecj 
    1750             pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) 
    1751             pt2d(:,ijhom +jl) = pt2d(:,ijhom +jl) + zt2ns(:,jl,2) 
    1752          END DO 
    1753       CASE ( 1 ) 
    1754          DO jl = 1, jprecj 
    1755             pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) 
    1756          END DO 
    1757       END SELECT 
    1758  
    1759  
    1760       ! 4. north fold treatment 
    1761       ! ----------------------- 
    1762       ! 
    1763       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    1764          ! 
    1765          SELECT CASE ( jpni ) 
    1766          CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp 
    1767          CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs. 
    1768          END SELECT 
    1769          ! 
    1770       ENDIF 
    1771       ! 
    1772       DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
    1773       ! 
    1774    END SUBROUTINE mpp_lnk_sum_2d 
    1775686 
    1776687   SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req ) 
    … …  
    1874785   END SUBROUTINE mppscatter 
    1875786 
    1876  
     787   !!---------------------------------------------------------------------- 
     788   !!    ***  mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real  *** 
     789   !!    
     790   !!---------------------------------------------------------------------- 
     791   !! 
    1877792   SUBROUTINE mppmax_a_int( ktab, kdim, kcom ) 
    1878       !!---------------------------------------------------------------------- 
    1879       !!                  ***  routine mppmax_a_int  *** 
    1880       !! 
    1881       !! ** Purpose :   Find maximum value in an integer layout array 
    1882       !! 
    1883793      !!---------------------------------------------------------------------- 
    1884794      INTEGER , INTENT(in   )                  ::   kdim   ! size of array 
    1885795      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab   ! input array 
    1886796      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom   ! 
    1887       ! 
    1888       INTEGER :: ierror, localcomm   ! temporary integer 
     797      INTEGER :: ierror, ilocalcomm   ! temporary integer 
    1889798      INTEGER, DIMENSION(kdim) ::   iwork 
    1890799      !!---------------------------------------------------------------------- 
    1891       ! 
    1892       localcomm = mpi_comm_opa 
    1893       IF( PRESENT(kcom) )   localcomm = kcom 
    1894       ! 
    1895       CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror ) 
    1896       ! 
     800      ilocalcomm = mpi_comm_opa 
     801      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     802      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, ilocalcomm, ierror ) 
    1897803      ktab(:) = iwork(:) 
    1898       ! 
    1899804   END SUBROUTINE mppmax_a_int 
    1900  
    1901  
     805   !! 
    1902806   SUBROUTINE mppmax_int( ktab, kcom ) 
    1903       !!---------------------------------------------------------------------- 
    1904       !!                  ***  routine mppmax_int  *** 
    1905       !! 
    1906       !! ** Purpose :   Find maximum value in an integer layout array 
    1907       !! 
    1908807      !!---------------------------------------------------------------------- 
    1909808      INTEGER, INTENT(inout)           ::   ktab   ! ??? 
    1910809      INTEGER, INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
    1911       ! 
    1912       INTEGER ::   ierror, iwork, localcomm   ! temporary integer 
    1913       !!---------------------------------------------------------------------- 
    1914       ! 
    1915       localcomm = mpi_comm_opa 
    1916       IF( PRESENT(kcom) )   localcomm = kcom 
    1917       ! 
    1918       CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror ) 
    1919       ! 
     810      INTEGER ::   ierror, iwork, ilocalcomm   ! temporary integer 
     811      !!---------------------------------------------------------------------- 
     812      ilocalcomm = mpi_comm_opa 
     813      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     814      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, ilocalcomm, ierror ) 
    1920815      ktab = iwork 
    1921       ! 
    1922816   END SUBROUTINE mppmax_int 
    1923  
    1924  
     817   !! 
     818   SUBROUTINE mppmax_a_real( ptab, kdim, kcom ) 
     819      !!---------------------------------------------------------------------- 
     820      REAL(wp), DIMENSION(kdim), INTENT(inout) ::   ptab 
     821      INTEGER                  , INTENT(in   ) ::   kdim 
     822      INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom 
     823      INTEGER :: ierror, ilocalcomm 
     824      REAL(wp), DIMENSION(kdim) ::  zwork 
     825      !!---------------------------------------------------------------------- 
     826      ilocalcomm = mpi_comm_opa 
     827      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     828      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 
     829      ptab(:) = zwork(:) 
     830   END SUBROUTINE mppmax_a_real 
     831   !! 
     832   SUBROUTINE mppmax_real( ptab, kcom ) 
     833      !!---------------------------------------------------------------------- 
     834      REAL(wp), INTENT(inout)           ::   ptab   ! ??? 
     835      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
     836      INTEGER  ::   ierror, ilocalcomm 
     837      REAL(wp) ::   zwork 
     838      !!---------------------------------------------------------------------- 
     839      ilocalcomm = mpi_comm_opa 
     840      IF( PRESENT(kcom) )   ilocalcomm = kcom! 
     841      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 
     842      ptab = zwork 
     843   END SUBROUTINE mppmax_real 
     844 
     845 
     846   !!---------------------------------------------------------------------- 
     847   !!    ***  mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real  *** 
     848   !!    
     849   !!---------------------------------------------------------------------- 
     850   !! 
    1925851   SUBROUTINE mppmin_a_int( ktab, kdim, kcom ) 
    1926       !!---------------------------------------------------------------------- 
    1927       !!                  ***  routine mppmin_a_int  *** 
    1928       !! 
    1929       !! ** Purpose :   Find minimum value in an integer layout array 
    1930       !! 
    1931852      !!---------------------------------------------------------------------- 
    1932853      INTEGER , INTENT( in  )                  ::   kdim   ! size of array 
    … …  
    1934855      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom   ! input array 
    1935856      !! 
    1936       INTEGER ::   ierror, localcomm   ! temporary integer 
     857      INTEGER ::   ierror, ilocalcomm   ! temporary integer 
    1937858      INTEGER, DIMENSION(kdim) ::   iwork 
    1938859      !!---------------------------------------------------------------------- 
    1939       ! 
    1940       localcomm = mpi_comm_opa 
    1941       IF( PRESENT(kcom) )   localcomm = kcom 
    1942       ! 
    1943       CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror ) 
    1944       ! 
     860      ilocalcomm = mpi_comm_opa 
     861      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     862      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, ilocalcomm, ierror ) 
    1945863      ktab(:) = iwork(:) 
    1946       ! 
    1947864   END SUBROUTINE mppmin_a_int 
    1948  
    1949  
     865   !! 
    1950866   SUBROUTINE mppmin_int( ktab, kcom ) 
    1951       !!---------------------------------------------------------------------- 
    1952       !!                  ***  routine mppmin_int  *** 
    1953       !! 
    1954       !! ** Purpose :   Find minimum value in an integer layout array 
    1955       !! 
    1956867      !!---------------------------------------------------------------------- 
    1957868      INTEGER, INTENT(inout) ::   ktab      ! ??? 
    1958869      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array 
    1959870      !! 
    1960       INTEGER ::  ierror, iwork, localcomm 
    1961       !!---------------------------------------------------------------------- 
    1962       ! 
    1963       localcomm = mpi_comm_opa 
    1964       IF( PRESENT(kcom) )   localcomm = kcom 
    1965       ! 
    1966       CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror ) 
    1967       ! 
     871      INTEGER ::  ierror, iwork, ilocalcomm 
     872      !!---------------------------------------------------------------------- 
     873      ilocalcomm = mpi_comm_opa 
     874      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     875      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, ilocalcomm, ierror ) 
    1968876      ktab = iwork 
    1969       ! 
    1970877   END SUBROUTINE mppmin_int 
    1971  
    1972  
    1973    SUBROUTINE mppsum_a_int( ktab, kdim ) 
    1974       !!---------------------------------------------------------------------- 
    1975       !!                  ***  routine mppsum_a_int  *** 
    1976       !! 
    1977       !! ** Purpose :   Global integer sum, 1D array case 
    1978       !! 
    1979       !!---------------------------------------------------------------------- 
    1980       INTEGER, INTENT(in   )                   ::   kdim   ! ??? 
    1981       INTEGER, INTENT(inout), DIMENSION (kdim) ::   ktab   ! ??? 
    1982       ! 
    1983       INTEGER :: ierror 
    1984       INTEGER, DIMENSION (kdim) ::  iwork 
    1985       !!---------------------------------------------------------------------- 
    1986       ! 
    1987       CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 
    1988       ! 
    1989       ktab(:) = iwork(:) 
    1990       ! 
    1991    END SUBROUTINE mppsum_a_int 
    1992  
    1993  
    1994    SUBROUTINE mppsum_int( ktab ) 
    1995       !!---------------------------------------------------------------------- 
    1996       !!                 ***  routine mppsum_int  *** 
    1997       !! 
    1998       !! ** Purpose :   Global integer sum 
    1999       !! 
    2000       !!---------------------------------------------------------------------- 
    2001       INTEGER, INTENT(inout) ::   ktab 
    2002       !! 
    2003       INTEGER :: ierror, iwork 
    2004       !!---------------------------------------------------------------------- 
    2005       ! 
    2006       CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 
    2007       ! 
    2008       ktab = iwork 
    2009       ! 
    2010    END SUBROUTINE mppsum_int 
    2011  
    2012  
    2013    SUBROUTINE mppmax_a_real( ptab, kdim, kcom ) 
    2014       !!---------------------------------------------------------------------- 
    2015       !!                 ***  routine mppmax_a_real  *** 
    2016       !! 
    2017       !! ** Purpose :   Maximum 
    2018       !! 
     878   !! 
     879   SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
    2019880      !!---------------------------------------------------------------------- 
    2020881      INTEGER , INTENT(in   )                  ::   kdim 
    2021882      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab 
    2022883      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom 
    2023       ! 
    2024       INTEGER :: ierror, localcomm 
    2025       REAL(wp), DIMENSION(kdim) ::  zwork 
    2026       !!---------------------------------------------------------------------- 
    2027       ! 
    2028       localcomm = mpi_comm_opa 
    2029       IF( PRESENT(kcom) ) localcomm = kcom 
    2030       ! 
    2031       CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror ) 
    2032       ptab(:) = zwork(:) 
    2033       ! 
    2034    END SUBROUTINE mppmax_a_real 
    2035  
    2036  
    2037    SUBROUTINE mppmax_real( ptab, kcom ) 
    2038       !!---------------------------------------------------------------------- 
    2039       !!                  ***  routine mppmax_real  *** 
    2040       !! 
    2041       !! ** Purpose :   Maximum 
    2042       !! 
    2043       !!---------------------------------------------------------------------- 
    2044       REAL(wp), INTENT(inout)           ::   ptab   ! ??? 
    2045       INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
    2046       !! 
    2047       INTEGER  ::   ierror, localcomm 
    2048       REAL(wp) ::   zwork 
    2049       !!---------------------------------------------------------------------- 
    2050       ! 
    2051       localcomm = mpi_comm_opa 
    2052       IF( PRESENT(kcom) )   localcomm = kcom 
    2053       ! 
    2054       CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror ) 
    2055       ptab = zwork 
    2056       ! 
    2057    END SUBROUTINE mppmax_real 
    2058  
    2059    SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom  ) 
    2060       !!---------------------------------------------------------------------- 
    2061       !!                  ***  routine mppmax_real  *** 
    2062       !! 
    2063       !! ** Purpose :   Maximum 
    2064       !! 
    2065       !!---------------------------------------------------------------------- 
    2066       REAL(wp), DIMENSION(:) ,  INTENT(inout)           ::   ptab   ! ??? 
    2067       INTEGER , INTENT(in   )           ::   NUM 
    2068       INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
    2069       !! 
    2070       INTEGER  ::   ierror, localcomm 
    2071       REAL(wp) , POINTER , DIMENSION(:) ::   zwork 
    2072       !!---------------------------------------------------------------------- 
    2073       ! 
    2074       CALL wrk_alloc(NUM , zwork) 
    2075       localcomm = mpi_comm_opa 
    2076       IF( PRESENT(kcom) )   localcomm = kcom 
    2077       ! 
    2078       CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 
    2079       ptab = zwork 
    2080       CALL wrk_dealloc(NUM , zwork) 
    2081       ! 
    2082    END SUBROUTINE mppmax_real_multiple 
    2083  
    2084  
    2085    SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
    2086       !!---------------------------------------------------------------------- 
    2087       !!                 ***  routine mppmin_a_real  *** 
    2088       !! 
    2089       !! ** Purpose :   Minimum of REAL, array case 
    2090       !! 
    2091       !!----------------------------------------------------------------------- 
    2092       INTEGER , INTENT(in   )                  ::   kdim 
    2093       REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab 
    2094       INTEGER , INTENT(in   ), OPTIONAL        ::   kcom 
    2095       !! 
    2096       INTEGER :: ierror, localcomm 
     884      INTEGER :: ierror, ilocalcomm 
    2097885      REAL(wp), DIMENSION(kdim) ::   zwork 
    2098886      !!----------------------------------------------------------------------- 
    2099       ! 
    2100       localcomm = mpi_comm_opa 
    2101       IF( PRESENT(kcom) ) localcomm = kcom 
    2102       ! 
    2103       CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror ) 
     887      ilocalcomm = mpi_comm_opa 
     888      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     889      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, ilocalcomm, ierror ) 
    2104890      ptab(:) = zwork(:) 
    2105       ! 
    2106891   END SUBROUTINE mppmin_a_real 
    2107  
    2108  
     892   !! 
    2109893   SUBROUTINE mppmin_real( ptab, kcom ) 
    2110       !!---------------------------------------------------------------------- 
    2111       !!                  ***  routine mppmin_real  *** 
    2112       !! 
    2113       !! ** Purpose :   minimum of REAL, scalar case 
    2114       !! 
    2115894      !!----------------------------------------------------------------------- 
    2116895      REAL(wp), INTENT(inout)           ::   ptab        ! 
    2117896      INTEGER , INTENT(in   ), OPTIONAL :: kcom 
    2118       !! 
    2119       INTEGER  ::   ierror 
    2120       REAL(wp) ::   zwork 
    2121       INTEGER :: localcomm 
    2122       !!----------------------------------------------------------------------- 
    2123       ! 
    2124       localcomm = mpi_comm_opa 
    2125       IF( PRESENT(kcom) )   localcomm = kcom 
    2126       ! 
    2127       CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror ) 
    2128       ptab = zwork 
    2129       ! 
    2130    END SUBROUTINE mppmin_real 
    2131  
    2132  
    2133    SUBROUTINE mppsum_a_real( ptab, kdim, kcom ) 
    2134       !!---------------------------------------------------------------------- 
    2135       !!                  ***  routine mppsum_a_real  *** 
    2136       !! 
    2137       !! ** Purpose :   global sum, REAL ARRAY argument case 
    2138       !! 
    2139       !!----------------------------------------------------------------------- 
    2140       INTEGER , INTENT( in )                     ::   kdim      ! size of ptab 
    2141       REAL(wp), DIMENSION(kdim), INTENT( inout ) ::   ptab      ! input array 
    2142       INTEGER , INTENT( in ), OPTIONAL           :: kcom 
    2143       !! 
    2144       INTEGER                   ::   ierror    ! temporary integer 
    2145       INTEGER                   ::   localcomm 
    2146       REAL(wp), DIMENSION(kdim) ::   zwork     ! temporary workspace 
    2147       !!----------------------------------------------------------------------- 
    2148       ! 
    2149       localcomm = mpi_comm_opa 
    2150       IF( PRESENT(kcom) )   localcomm = kcom 
    2151       ! 
    2152       CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror ) 
    2153       ptab(:) = zwork(:) 
    2154       ! 
    2155    END SUBROUTINE mppsum_a_real 
    2156  
    2157  
    2158    SUBROUTINE mppsum_real( ptab, kcom ) 
    2159       !!---------------------------------------------------------------------- 
    2160       !!                  ***  routine mppsum_real  *** 
    2161       !! 
    2162       !! ** Purpose :   global sum, SCALAR argument case 
    2163       !! 
    2164       !!----------------------------------------------------------------------- 
    2165       REAL(wp), INTENT(inout)           ::   ptab   ! input scalar 
    2166       INTEGER , INTENT(in   ), OPTIONAL ::   kcom 
    2167       !! 
    2168       INTEGER  ::   ierror, localcomm 
     897      INTEGER  ::   ierror, ilocalcomm 
    2169898      REAL(wp) ::   zwork 
    2170899      !!----------------------------------------------------------------------- 
    2171       ! 
    2172       localcomm = mpi_comm_opa 
    2173       IF( PRESENT(kcom) ) localcomm = kcom 
    2174       ! 
    2175       CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror ) 
     900      ilocalcomm = mpi_comm_opa 
     901      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     902      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, ilocalcomm, ierror ) 
    2176903      ptab = zwork 
    2177       ! 
     904   END SUBROUTINE mppmin_real 
     905 
     906 
     907   !!---------------------------------------------------------------------- 
     908   !!    ***  mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real  *** 
     909   !!    
     910   !!   Global sum of 1D array or a variable (integer, real or complex) 
     911   !!---------------------------------------------------------------------- 
     912   !! 
     913   SUBROUTINE mppsum_a_int( ktab, kdim ) 
     914      !!---------------------------------------------------------------------- 
     915      INTEGER, INTENT(in   )                   ::   kdim   ! ??? 
     916      INTEGER, INTENT(inout), DIMENSION (kdim) ::   ktab   ! ??? 
     917      INTEGER :: ierror 
     918      INTEGER, DIMENSION (kdim) ::  iwork 
     919      !!---------------------------------------------------------------------- 
     920      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 
     921      ktab(:) = iwork(:) 
     922   END SUBROUTINE mppsum_a_int 
     923   !! 
     924   SUBROUTINE mppsum_int( ktab ) 
     925      !!---------------------------------------------------------------------- 
     926      INTEGER, INTENT(inout) ::   ktab 
     927      INTEGER :: ierror, iwork 
     928      !!---------------------------------------------------------------------- 
     929      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 
     930      ktab = iwork 
     931   END SUBROUTINE mppsum_int 
     932   !! 
     933   SUBROUTINE mppsum_a_real( ptab, kdim, kcom ) 
     934      !!----------------------------------------------------------------------- 
     935      INTEGER                  , INTENT(in   ) ::   kdim   ! size of ptab 
     936      REAL(wp), DIMENSION(kdim), INTENT(inout) ::   ptab   ! input array 
     937      INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom   ! specific communicator 
     938      INTEGER  ::   ierror, ilocalcomm    ! local integer 
     939      REAL(wp) ::   zwork(kdim)           ! local workspace 
     940      !!----------------------------------------------------------------------- 
     941      ilocalcomm = mpi_comm_opa 
     942      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     943      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, ilocalcomm, ierror ) 
     944      ptab(:) = zwork(:) 
     945   END SUBROUTINE mppsum_a_real 
     946   !! 
     947   SUBROUTINE mppsum_real( ptab, kcom ) 
     948      !!----------------------------------------------------------------------- 
     949      REAL(wp)          , INTENT(inout)           ::   ptab   ! input scalar 
     950      INTEGER , OPTIONAL, INTENT(in   ) ::   kcom 
     951      INTEGER  ::   ierror, ilocalcomm 
     952      REAL(wp) ::   zwork 
     953      !!----------------------------------------------------------------------- 
     954      ilocalcomm = mpi_comm_opa 
     955      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     956      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, ilocalcomm, ierror ) 
     957      ptab = zwork 
    2178958   END SUBROUTINE mppsum_real 
    2179  
    2180  
     959   !! 
    2181960   SUBROUTINE mppsum_realdd( ytab, kcom ) 
    2182       !!---------------------------------------------------------------------- 
    2183       !!                  ***  routine mppsum_realdd *** 
    2184       !! 
    2185       !! ** Purpose :   global sum in Massively Parallel Processing 
    2186       !!                SCALAR argument case for double-double precision 
    2187       !! 
    2188961      !!----------------------------------------------------------------------- 
    2189       COMPLEX(wp), INTENT(inout)           ::   ytab    ! input scalar 
    2190       INTEGER    , INTENT(in   ), OPTIONAL ::   kcom 
    2191       ! 
    2192       INTEGER     ::   ierror 
    2193       INTEGER     ::   localcomm 
     962      COMPLEX(wp)          , INTENT(inout) ::   ytab    ! input scalar 
     963      INTEGER    , OPTIONAL, INTENT(in   ) ::   kcom 
     964      INTEGER     ::   ierror, ilocalcomm 
    2194965      COMPLEX(wp) ::   zwork 
    2195966      !!----------------------------------------------------------------------- 
    2196       ! 
    2197       localcomm = mpi_comm_opa 
    2198       IF( PRESENT(kcom) )   localcomm = kcom 
    2199       ! 
    2200       ! reduce local sums into global sum 
    2201       CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror ) 
     967      ilocalcomm = mpi_comm_opa 
     968      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     969      CALL MPI_ALLREDUCE( ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, ilocalcomm, ierror ) 
    2202970      ytab = zwork 
    2203       ! 
    2204971   END SUBROUTINE mppsum_realdd 
    2205  
    2206  
     972   !! 
    2207973   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom ) 
    2208974      !!---------------------------------------------------------------------- 
    2209       !!                  ***  routine mppsum_a_realdd  *** 
    2210       !! 
    2211       !! ** Purpose :   global sum in Massively Parallel Processing 
    2212       !!                COMPLEX ARRAY case for double-double precision 
    2213       !! 
    2214       !!----------------------------------------------------------------------- 
    2215975      INTEGER                     , INTENT(in   ) ::   kdim   ! size of ytab 
    2216976      COMPLEX(wp), DIMENSION(kdim), INTENT(inout) ::   ytab   ! input array 
    2217977      INTEGER    , OPTIONAL       , INTENT(in   ) ::   kcom 
    2218       ! 
    2219       INTEGER:: ierror, localcomm    ! local integer 
     978      INTEGER:: ierror, ilocalcomm    ! local integer 
    2220979      COMPLEX(wp), DIMENSION(kdim) :: zwork     ! temporary workspace 
    2221980      !!----------------------------------------------------------------------- 
    2222       ! 
    2223       localcomm = mpi_comm_opa 
    2224       IF( PRESENT(kcom) )   localcomm = kcom 
    2225       ! 
    2226       CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror ) 
     981      ilocalcomm = mpi_comm_opa 
     982      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     983      CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, ilocalcomm, ierror ) 
    2227984      ytab(:) = zwork(:) 
    2228       ! 
    2229985   END SUBROUTINE mppsum_a_realdd 
     986    
     987 
     988   SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom  ) 
     989      !!---------------------------------------------------------------------- 
     990      !!                  ***  routine mppmax_real  *** 
     991      !! 
     992      !! ** Purpose :   Maximum across processor of each element of a 1D arrays 
     993      !! 
     994      !!---------------------------------------------------------------------- 
     995      REAL(wp), DIMENSION(kdim), INTENT(inout) ::   pt1d   ! 1D arrays 
     996      INTEGER                  , INTENT(in   ) ::   kdim 
     997      INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom   ! local communicator 
     998      !! 
     999      INTEGER  ::   ierror, ilocalcomm 
     1000      REAL(wp), DIMENSION(kdim) ::  zwork 
     1001      !!---------------------------------------------------------------------- 
     1002      ilocalcomm = mpi_comm_opa 
     1003      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     1004      ! 
     1005      CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 
     1006      pt1d(:) = zwork(:) 
     1007      ! 
     1008   END SUBROUTINE mppmax_real_multiple 
    22301009 
    22311010 
    … …  
    22431022      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask   ! Local mask 
    22441023      REAL(wp)                     , INTENT(  out) ::   pmin    ! Global minimum of ptab 
    2245       INTEGER                      , INTENT(  out) ::   ki, kj   ! index of minimum in global frame 
     1024      INTEGER                      , INTENT(  out) ::   ki, kj  ! index of minimum in global frame 
    22461025      ! 
    22471026      INTEGER :: ierror 
    … …  
    22511030      !!----------------------------------------------------------------------- 
    22521031      ! 
    2253       zmin  = MINVAL( ptab(:,:) , mask= pmask == 1.e0 ) 
    2254       ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 ) 
     1032      zmin  = MINVAL( ptab(:,:) , mask= pmask == 1._wp ) 
     1033      ilocs = MINLOC( ptab(:,:) , mask= pmask == 1._wp ) 
    22551034      ! 
    22561035      ki = ilocs(1) + nimpp - 1 
    … …  
    22791058      !! 
    22801059      !!-------------------------------------------------------------------------- 
    2281       REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab         ! Local 2D array 
    2282       REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask        ! Local mask 
    2283       REAL(wp)                         , INTENT(  out) ::   pmin         ! Global minimum of ptab 
    2284       INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of minimum in global frame 
    2285       !! 
     1060      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   ptab         ! Local 2D array 
     1061      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pmask        ! Local mask 
     1062      REAL(wp)                  , INTENT(  out) ::   pmin         ! Global minimum of ptab 
     1063      INTEGER                   , INTENT(  out) ::   ki, kj, kk   ! index of minimum in global frame 
     1064      ! 
    22861065      INTEGER  ::   ierror 
    22871066      REAL(wp) ::   zmin     ! local minimum 
    … …  
    22901069      !!----------------------------------------------------------------------- 
    22911070      ! 
    2292       zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 ) 
    2293       ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 ) 
     1071      zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1._wp ) 
     1072      ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1._wp ) 
    22941073      ! 
    22951074      ki = ilocs(1) + nimpp - 1 
    … …  
    22971076      kk = ilocs(3) 
    22981077      ! 
    2299       zain(1,:)=zmin 
    2300       zain(2,:)=ki+10000.*kj+100000000.*kk 
     1078      zain(1,:) = zmin 
     1079      zain(2,:) = ki + 10000.*kj + 100000000.*kk 
    23011080      ! 
    23021081      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror) 
    … …  
    23311110      !!----------------------------------------------------------------------- 
    23321111      ! 
    2333       zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 ) 
    2334       ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 ) 
     1112      zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1._wp ) 
     1113      ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1._wp ) 
    23351114      ! 
    23361115      ki = ilocs(1) + nimpp - 1 
    … …  
    23591138      !! 
    23601139      !!-------------------------------------------------------------------------- 
    2361       REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab         ! Local 2D array 
    2362       REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask        ! Local mask 
    2363       REAL(wp)                         , INTENT(  out) ::   pmax         ! Global maximum of ptab 
    2364       INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of maximum in global frame 
    2365       !! 
    2366       REAL(wp) :: zmax   ! local maximum 
     1140      REAL(wp), DIMENSION (:,:,:), INTENT(in   ) ::   ptab         ! Local 2D array 
     1141      REAL(wp), DIMENSION (:,:,:), INTENT(in   ) ::   pmask        ! Local mask 
     1142      REAL(wp)                   , INTENT(  out) ::   pmax         ! Global maximum of ptab 
     1143      INTEGER                    , INTENT(  out) ::   ki, kj, kk   ! index of maximum in global frame 
     1144      ! 
     1145      INTEGER  ::   ierror   ! local integer 
     1146      REAL(wp) ::   zmax     ! local maximum 
    23671147      REAL(wp), DIMENSION(2,1) ::   zain, zaout 
    23681148      INTEGER , DIMENSION(3)   ::   ilocs 
    2369       INTEGER :: ierror 
    23701149      !!----------------------------------------------------------------------- 
    23711150      ! 
    2372       zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 ) 
    2373       ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 ) 
     1151      zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1._wp ) 
     1152      ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1._wp ) 
    23741153      ! 
    23751154      ki = ilocs(1) + nimpp - 1 
    … …  
    23771156      kk = ilocs(3) 
    23781157      ! 
    2379       zain(1,:)=zmax 
    2380       zain(2,:)=ki+10000.*kj+100000000.*kk 
     1158      zain(1,:) = zmax 
     1159      zain(2,:) = ki + 10000.*kj + 100000000.*kk 
    23811160      ! 
    23821161      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror) 
    … …  
    24221201 
    24231202   SUBROUTINE mpp_comm_free( kcom ) 
    2424       !!---------------------------------------------------------------------- 
    24251203      !!---------------------------------------------------------------------- 
    24261204      INTEGER, INTENT(in) ::   kcom 
    … …  
    26801458 
    26811459 
    2682    SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn ) 
    2683       !!--------------------------------------------------------------------- 
    2684       !!                   ***  routine mpp_lbc_north_3d  *** 
    2685       !! 
    2686       !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    2687       !!              in mpp configuration in case of jpn1 > 1 
    2688       !! 
    2689       !! ** Method  :   North fold condition and mpp with more than one proc 
    2690       !!              in i-direction require a specific treatment. We gather 
    2691       !!              the 4 northern lines of the global domain on 1 processor 
    2692       !!              and apply lbc north-fold on this sub array. Then we 
    2693       !!              scatter the north fold array back to the processors. 
    2694       !! 
    2695       !!---------------------------------------------------------------------- 
    2696       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d      ! 3D array on which the b.c. is applied 
    2697       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    2698       !                                                              !   = T ,  U , V , F or W  gridpoints 
    2699       REAL(wp)                        , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
    2700       !!                                                             ! =  1. , the sign is kept 
    2701       INTEGER ::   ji, jj, jr, jk 
    2702       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    2703       INTEGER ::   ijpj, ijpjm1, ij, iproc 
    2704       INTEGER, DIMENSION (jpmaxngh)          ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
    2705       INTEGER                                ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
    2706       INTEGER, DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
    2707       !                                                              ! Workspace for message transfers avoiding mpi_allgather 
    2708       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
    2709       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk       
    2710       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
    2711       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr 
    2712  
    2713       INTEGER :: istatus(mpi_status_size) 
    2714       INTEGER :: iflag 
    2715       !!---------------------------------------------------------------------- 
    2716       ! 
    2717       ALLOCATE( ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk), zfoldwk(jpi,4,jpk), znorthgloio(jpi,4,jpk,jpni) ) 
    2718       ALLOCATE( ztabl(jpi,4,jpk), ztabr(jpi*jpmaxngh, 4, jpk) )  
    2719  
    2720       ijpj   = 4 
    2721       ijpjm1 = 3 
    2722       ! 
    2723       znorthloc(:,:,:) = 0 
    2724       DO jk = 1, jpk 
    2725          DO jj = nlcj - ijpj +1, nlcj          ! put in xnorthloc the last 4 jlines of pt3d 
    2726             ij = jj - nlcj + ijpj 
    2727             znorthloc(:,ij,jk) = pt3d(:,jj,jk) 
    2728          END DO 
    2729       END DO 
    2730       ! 
    2731       !                                     ! Build in procs of ncomm_north the znorthgloio 
    2732       itaille = jpi * jpk * ijpj 
    2733  
    2734       IF ( l_north_nogather ) THEN 
    2735          ! 
    2736         ztabr(:,:,:) = 0 
    2737         ztabl(:,:,:) = 0 
    2738  
    2739         DO jk = 1, jpk 
    2740            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
    2741               ij = jj - nlcj + ijpj 
    2742               DO ji = nfsloop, nfeloop 
    2743                  ztabl(ji,ij,jk) = pt3d(ji,jj,jk) 
    2744               END DO 
    2745            END DO 
    2746         END DO 
    2747  
    2748          DO jr = 1,nsndto 
    2749             IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
    2750               CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 
    2751             ENDIF 
    2752          END DO 
    2753          DO jr = 1,nsndto 
    2754             iproc = nfipproc(isendto(jr),jpnj) 
    2755             IF(iproc .ne. -1) THEN 
    2756                ilei = nleit (iproc+1) 
    2757                ildi = nldit (iproc+1) 
    2758                iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
    2759             ENDIF 
    2760             IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
    2761               CALL mpprecv(5, zfoldwk, itaille, iproc) 
    2762               DO jk = 1, jpk 
    2763                  DO jj = 1, ijpj 
    2764                     DO ji = ildi, ilei 
    2765                        ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) 
    2766                     END DO 
    2767                  END DO 
    2768               END DO 
    2769            ELSE IF (iproc .eq. (narea-1)) THEN 
    2770               DO jk = 1, jpk 
    2771                  DO jj = 1, ijpj 
    2772                     DO ji = ildi, ilei 
    2773                        ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk) 
    2774                     END DO 
    2775                  END DO 
    2776               END DO 
    2777            ENDIF 
    2778          END DO 
    2779          IF (l_isend) THEN 
    2780             DO jr = 1,nsndto 
    2781                IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
    2782                   CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
    2783                ENDIF     
    2784             END DO 
    2785          ENDIF 
    2786          CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition 
    2787          DO jk = 1, jpk 
    2788             DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d 
    2789                ij = jj - nlcj + ijpj 
    2790                DO ji= 1, nlci 
    2791                   pt3d(ji,jj,jk) = ztabl(ji,ij,jk) 
    2792                END DO 
    2793             END DO 
    2794          END DO 
    2795          ! 
    2796  
    2797       ELSE 
    2798          CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                & 
    2799             &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    2800          ! 
    2801          ztab(:,:,:) = 0.e0 
    2802          DO jr = 1, ndim_rank_north         ! recover the global north array 
    2803             iproc = nrank_north(jr) + 1 
    2804             ildi  = nldit (iproc) 
    2805             ilei  = nleit (iproc) 
    2806             iilb  = nimppt(iproc) 
    2807             DO jk = 1, jpk 
    2808                DO jj = 1, ijpj 
    2809                   DO ji = ildi, ilei 
    2810                     ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 
    2811                   END DO 
    2812                END DO 
    2813             END DO 
    2814          END DO 
    2815          CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition 
    2816          ! 
    2817          DO jk = 1, jpk 
    2818             DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d 
    2819                ij = jj - nlcj + ijpj 
    2820                DO ji= 1, nlci 
    2821                   pt3d(ji,jj,jk) = ztab(ji+nimpp-1,ij,jk) 
    2822                END DO 
    2823             END DO 
    2824          END DO 
    2825          ! 
    2826       ENDIF 
    2827       ! 
    2828       ! The ztab array has been either: 
    2829       !  a. Fully populated by the mpi_allgather operation or 
    2830       !  b. Had the active points for this domain and northern neighbours populated 
    2831       !     by peer to peer exchanges 
    2832       ! Either way the array may be folded by lbc_nfd and the result for the span of 
    2833       ! this domain will be identical. 
    2834       ! 
    2835       DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
    2836       DEALLOCATE( ztabl, ztabr )  
    2837       ! 
    2838    END SUBROUTINE mpp_lbc_north_3d 
    2839  
    2840  
    2841    SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn) 
    2842       !!--------------------------------------------------------------------- 
    2843       !!                   ***  routine mpp_lbc_north_2d  *** 
    2844       !! 
    2845       !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    2846       !!              in mpp configuration in case of jpn1 > 1 (for 2d array ) 
    2847       !! 
    2848       !! ** Method  :   North fold condition and mpp with more than one proc 
    2849       !!              in i-direction require a specific treatment. We gather 
    2850       !!              the 4 northern lines of the global domain on 1 processor 
    2851       !!              and apply lbc north-fold on this sub array. Then we 
    2852       !!              scatter the north fold array back to the processors. 
    2853       !! 
    2854       !!---------------------------------------------------------------------- 
    2855       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 2D array on which the b.c. is applied 
    2856       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points 
    2857       !                                                          !   = T ,  U , V , F or W  gridpoints 
    2858       REAL(wp)                    , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
    2859       !!                                                             ! =  1. , the sign is kept 
    2860       INTEGER ::   ji, jj, jr 
    2861       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    2862       INTEGER ::   ijpj, ijpjm1, ij, iproc 
    2863       INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
    2864       INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
    2865       INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
    2866       !                                                              ! Workspace for message transfers avoiding mpi_allgather 
    2867       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: ztab 
    2868       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk       
    2869       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE   :: znorthgloio 
    2870       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: ztabl, ztabr 
    2871       INTEGER :: istatus(mpi_status_size) 
    2872       INTEGER :: iflag 
    2873       !!---------------------------------------------------------------------- 
    2874       ! 
    2875       ALLOCATE( ztab(jpiglo,4), znorthloc(jpi,4), zfoldwk(jpi,4), znorthgloio(jpi,4,jpni) ) 
    2876       ALLOCATE( ztabl(jpi,4), ztabr(jpi*jpmaxngh, 4) )  
    2877       ! 
    2878       ijpj   = 4 
    2879       ijpjm1 = 3 
    2880       ! 
    2881       DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d 
    2882          ij = jj - nlcj + ijpj 
    2883          znorthloc(:,ij) = pt2d(:,jj) 
    2884       END DO 
    2885  
    2886       !                                     ! Build in procs of ncomm_north the znorthgloio 
    2887       itaille = jpi * ijpj 
    2888       IF ( l_north_nogather ) THEN 
    2889          ! 
    2890          ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
    2891          ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
    2892          ! 
    2893          ztabr(:,:) = 0 
    2894          ztabl(:,:) = 0 
    2895  
    2896          DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
    2897             ij = jj - nlcj + ijpj 
    2898               DO ji = nfsloop, nfeloop 
    2899                ztabl(ji,ij) = pt2d(ji,jj) 
    2900             END DO 
    2901          END DO 
    2902  
    2903          DO jr = 1,nsndto 
    2904             IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
    2905                CALL mppsend(5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) 
    2906             ENDIF 
    2907          END DO 
    2908          DO jr = 1,nsndto 
    2909             iproc = nfipproc(isendto(jr),jpnj) 
    2910             IF(iproc .ne. -1) THEN 
    2911                ilei = nleit (iproc+1) 
    2912                ildi = nldit (iproc+1) 
    2913                iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
    2914             ENDIF 
    2915             IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
    2916               CALL mpprecv(5, zfoldwk, itaille, iproc) 
    2917               DO jj = 1, ijpj 
    2918                  DO ji = ildi, ilei 
    2919                     ztabr(iilb+ji,jj) = zfoldwk(ji,jj) 
    2920                  END DO 
    2921               END DO 
    2922             ELSE IF (iproc .eq. (narea-1)) THEN 
    2923               DO jj = 1, ijpj 
    2924                  DO ji = ildi, ilei 
    2925                     ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj) 
    2926                  END DO 
    2927               END DO 
    2928             ENDIF 
    2929          END DO 
    2930          IF (l_isend) THEN 
    2931             DO jr = 1,nsndto 
    2932                IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
    2933                   CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
    2934                ENDIF 
    2935             END DO 
    2936          ENDIF 
    2937          CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition 
    2938          ! 
    2939          DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    2940             ij = jj - nlcj + ijpj 
    2941             DO ji = 1, nlci 
    2942                pt2d(ji,jj) = ztabl(ji,ij) 
    2943             END DO 
    2944          END DO 
    2945          ! 
    2946       ELSE 
    2947          CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,        & 
    2948             &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    2949          ! 
    2950          ztab(:,:) = 0.e0 
    2951          DO jr = 1, ndim_rank_north            ! recover the global north array 
    2952             iproc = nrank_north(jr) + 1 
    2953             ildi = nldit (iproc) 
    2954             ilei = nleit (iproc) 
    2955             iilb = nimppt(iproc) 
    2956             DO jj = 1, ijpj 
    2957                DO ji = ildi, ilei 
    2958                   ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr) 
    2959                END DO 
    2960             END DO 
    2961          END DO 
    2962          CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition 
    2963          ! 
    2964          DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    2965             ij = jj - nlcj + ijpj 
    2966             DO ji = 1, nlci 
    2967                pt2d(ji,jj) = ztab(ji+nimpp-1,ij) 
    2968             END DO 
    2969          END DO 
    2970          ! 
    2971       ENDIF 
    2972       DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
    2973       DEALLOCATE( ztabl, ztabr )  
    2974       ! 
    2975    END SUBROUTINE mpp_lbc_north_2d 
    2976  
    2977    SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 
    2978       !!--------------------------------------------------------------------- 
    2979       !!                   ***  routine mpp_lbc_north_2d  *** 
    2980       !! 
    2981       !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    2982       !!              in mpp configuration in case of jpn1 > 1 
    2983       !!              (for multiple 2d arrays ) 
    2984       !! 
    2985       !! ** Method  :   North fold condition and mpp with more than one proc 
    2986       !!              in i-direction require a specific treatment. We gather 
    2987       !!              the 4 northern lines of the global domain on 1 processor 
    2988       !!              and apply lbc north-fold on this sub array. Then we 
    2989       !!              scatter the north fold array back to the processors. 
    2990       !! 
    2991       !!---------------------------------------------------------------------- 
    2992       INTEGER ,  INTENT (in   ) ::   num_fields  ! number of variables contained in pt2d 
    2993       TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
    2994       CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points 
    2995       !                                                          !   = T ,  U , V , F or W  gridpoints 
    2996       REAL(wp), DIMENSION(:), INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
    2997       !!                                                             ! =  1. , the sign is kept 
    2998       INTEGER ::   ji, jj, jr, jk 
    2999       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    3000       INTEGER ::   ijpj, ijpjm1, ij, iproc 
    3001       INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
    3002       INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
    3003       INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
    3004       !                                                              ! Workspace for message transfers avoiding mpi_allgather 
    3005       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
    3006       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk 
    3007       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
    3008       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr 
    3009       INTEGER :: istatus(mpi_status_size) 
    3010       INTEGER :: iflag 
    3011       !!---------------------------------------------------------------------- 
    3012       ! 
    3013       ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields),   & 
    3014             &   znorthgloio(jpi,4,num_fields,jpni) )   ! expanded to 3 dimensions 
    3015       ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 
    3016       ! 
    3017       ijpj   = 4 
    3018       ijpjm1 = 3 
    3019       ! 
    3020        
    3021       DO jk = 1, num_fields 
    3022          DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable) 
    3023             ij = jj - nlcj + ijpj 
    3024             znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 
    3025          END DO 
    3026       END DO 
    3027       !                                     ! Build in procs of ncomm_north the znorthgloio 
    3028       itaille = jpi * ijpj 
    3029                                                                    
    3030       IF ( l_north_nogather ) THEN 
    3031          ! 
    3032          ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
    3033          ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
    3034          ! 
    3035          ztabr(:,:,:) = 0 
    3036          ztabl(:,:,:) = 0 
    3037  
    3038          DO jk = 1, num_fields 
    3039             DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
    3040                ij = jj - nlcj + ijpj 
    3041                DO ji = nfsloop, nfeloop 
    3042                   ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 
    3043                END DO 
    3044             END DO 
    3045          END DO 
    3046  
    3047          DO jr = 1,nsndto 
    3048             IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
    3049                CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times 
    3050             ENDIF 
    3051          END DO 
    3052          DO jr = 1,nsndto 
    3053             iproc = nfipproc(isendto(jr),jpnj) 
    3054             IF(iproc .ne. -1) THEN 
    3055                ilei = nleit (iproc+1) 
    3056                ildi = nldit (iproc+1) 
    3057                iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
    3058             ENDIF 
    3059             IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
    3060               CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times 
    3061               DO jk = 1 , num_fields 
    3062                  DO jj = 1, ijpj 
    3063                     DO ji = ildi, ilei 
    3064                        ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)       ! Modified to 3D 
    3065                     END DO 
    3066                  END DO 
    3067               END DO 
    3068             ELSE IF (iproc .eq. (narea-1)) THEN 
    3069               DO jk = 1, num_fields 
    3070                  DO jj = 1, ijpj 
    3071                     DO ji = ildi, ilei 
    3072                           ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj)       ! Modified to 3D 
    3073                     END DO 
    3074                  END DO 
    3075               END DO 
    3076             ENDIF 
    3077          END DO 
    3078          IF (l_isend) THEN 
    3079             DO jr = 1,nsndto 
    3080                IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
    3081                   CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
    3082                ENDIF 
    3083             END DO 
    3084          ENDIF 
    3085          ! 
    3086          DO ji = 1, num_fields     ! Loop to manage 3D variables 
    3087             CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition 
    3088          END DO 
    3089          ! 
    3090          DO jk = 1, num_fields 
    3091             DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    3092                ij = jj - nlcj + ijpj 
    3093                DO ji = 1, nlci 
    3094                   pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk)       ! Modified to 3D 
    3095                END DO 
    3096             END DO 
    3097          END DO 
    3098           
    3099          ! 
    3100       ELSE 
    3101          ! 
    3102          CALL MPI_ALLGATHER( znorthloc  , itaille*num_fields, MPI_DOUBLE_PRECISION,        & 
    3103             &                znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    3104          ! 
    3105          ztab(:,:,:) = 0.e0 
    3106          DO jk = 1, num_fields 
    3107             DO jr = 1, ndim_rank_north            ! recover the global north array 
    3108                iproc = nrank_north(jr) + 1 
    3109                ildi = nldit (iproc) 
    3110                ilei = nleit (iproc) 
    3111                iilb = nimppt(iproc) 
    3112                DO jj = 1, ijpj 
    3113                   DO ji = ildi, ilei 
    3114                      ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 
    3115                   END DO 
    3116                END DO 
    3117             END DO 
    3118          END DO 
    3119           
    3120          DO ji = 1, num_fields 
    3121             CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition 
    3122          END DO 
    3123          ! 
    3124          DO jk = 1, num_fields 
    3125             DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    3126                ij = jj - nlcj + ijpj 
    3127                DO ji = 1, nlci 
    3128                   pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 
    3129                END DO 
    3130             END DO 
    3131          END DO 
    3132          ! 
    3133          ! 
    3134       ENDIF 
    3135       DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
    3136       DEALLOCATE( ztabl, ztabr ) 
    3137       ! 
    3138    END SUBROUTINE mpp_lbc_north_2d_multiple 
    3139  
    31401460   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 
    31411461      !!--------------------------------------------------------------------- 
    … …  
    31551475      REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    31561476      CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points 
    3157       !                                                                                         !   = T ,  U , V , F or W -points 
    3158       REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
    3159       !!                                                                                        ! north fold, =  1. otherwise 
     1477      REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! sign used across the north fold 
     1478      ! 
    31601479      INTEGER ::   ji, jj, jr 
    31611480      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    31621481      INTEGER ::   ijpj, ij, iproc 
    3163       ! 
    31641482      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
    31651483      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e 
    3166  
    31671484      !!---------------------------------------------------------------------- 
    31681485      ! 
    31691486      ALLOCATE( ztab_e(jpiglo,4+2*jpr2dj), znorthloc_e(jpi,4+2*jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) ) 
    3170  
    31711487      ! 
    31721488      ijpj=4 
    3173       ztab_e(:,:) = 0.e0 
    3174  
    3175       ij=0 
     1489      ztab_e(:,:) = 0._wp 
     1490 
     1491      ij = 0 
    31761492      ! put in znorthloc_e the last 4 jlines of pt2d 
    31771493      DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj 
    31781494         ij = ij + 1 
    31791495         DO ji = 1, jpi 
    3180             znorthloc_e(ji,ij)=pt2d(ji,jj) 
     1496            znorthloc_e(ji,ij) = pt2d(ji,jj) 
    31811497         END DO 
    31821498      END DO 
    31831499      ! 
    31841500      itaille = jpi * ( ijpj + 2 * jpr2dj ) 
    3185       CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    & 
     1501      CALL MPI_ALLGATHER( znorthloc_e(1,1)    , itaille, MPI_DOUBLE_PRECISION,    & 
    31861502         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    31871503      ! 
    31881504      DO jr = 1, ndim_rank_north            ! recover the global north array 
    31891505         iproc = nrank_north(jr) + 1 
    3190          ildi = nldit (iproc) 
    3191          ilei = nleit (iproc) 
    3192          iilb = nimppt(iproc) 
     1506         ildi  = nldit (iproc) 
     1507         ilei  = nleit (iproc) 
     1508         iilb  = nimppt(iproc) 
    31931509         DO jj = 1, ijpj+2*jpr2dj 
    31941510            DO ji = ildi, ilei 
    … …  
    31981514      END DO 
    31991515 
    3200  
    32011516      ! 2. North-Fold boundary conditions 
    32021517      ! ---------------------------------- 
    3203       CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj ) 
     1518!!gm ERROR      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj ) 
    32041519 
    32051520      ij = jpr2dj 
    … …  
    32151530      ! 
    32161531   END SUBROUTINE mpp_lbc_north_e 
    3217  
    3218  
    3219    SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) 
    3220       !!---------------------------------------------------------------------- 
    3221       !!                  ***  routine mpp_lnk_bdy_3d  *** 
    3222       !! 
    3223       !! ** Purpose :   Message passing management 
    3224       !! 
    3225       !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries  
    3226       !!      between processors following neighboring subdomains. 
    3227       !!            domain parameters 
    3228       !!                    nlci   : first dimension of the local subdomain 
    3229       !!                    nlcj   : second dimension of the local subdomain 
    3230       !!                    nbondi_bdy : mark for "east-west local boundary" 
    3231       !!                    nbondj_bdy : mark for "north-south local boundary" 
    3232       !!                    noea   : number for local neighboring processors  
    3233       !!                    nowe   : number for local neighboring processors 
    3234       !!                    noso   : number for local neighboring processors 
    3235       !!                    nono   : number for local neighboring processors 
    3236       !! 
    3237       !! ** Action  :   ptab with update value at its periphery 
    3238       !! 
    3239       !!---------------------------------------------------------------------- 
    3240       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
    3241       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
    3242       !                                                             ! = T , U , V , F , W points 
    3243       REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    3244       !                                                             ! =  1. , the sign is kept 
    3245       INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set 
    3246       ! 
    3247       INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
    3248       INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    3249       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    3250       REAL(wp) ::   zland                      ! local scalar 
    3251       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    3252       ! 
    3253       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north 
    3254       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east 
    3255       !!---------------------------------------------------------------------- 
    3256       ! 
    3257       ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   & 
    3258          &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  ) 
    3259  
    3260       zland = 0._wp 
    3261  
    3262       ! 1. standard boundary treatment 
    3263       ! ------------------------------ 
    3264       !                                   ! East-West boundaries 
    3265       !                                        !* Cyclic east-west 
    3266       IF( nbondi == 2) THEN 
    3267          IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 
    3268             ptab( 1 ,:,:) = ptab(jpim1,:,:) 
    3269             ptab(jpi,:,:) = ptab(  2  ,:,:) 
    3270          ELSE 
    3271             IF( .NOT. cd_type == 'F' )   ptab(1:jpreci,:,:) = zland    ! south except F-point 
    3272             ptab(nlci-jpreci+1:jpi,:,:) = zland    ! north 
    3273          ENDIF 
    3274       ELSEIF(nbondi == -1) THEN 
    3275          IF( .NOT. cd_type == 'F' )   ptab(1:jpreci,:,:) = zland    ! south except F-point 
    3276       ELSEIF(nbondi == 1) THEN 
    3277          ptab(nlci-jpreci+1:jpi,:,:) = zland    ! north 
    3278       ENDIF                                     !* closed 
    3279  
    3280       IF (nbondj == 2 .OR. nbondj == -1) THEN 
    3281         IF( .NOT. cd_type == 'F' )   ptab(:,1:jprecj,:) = zland       ! south except F-point 
    3282       ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
    3283         ptab(:,nlcj-jprecj+1:jpj,:) = zland       ! north 
    3284       ENDIF 
    3285       ! 
    3286       ! 2. East and west directions exchange 
    3287       ! ------------------------------------ 
    3288       ! we play with the neigbours AND the row number because of the periodicity  
    3289       ! 
    3290       SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions 
    3291       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    3292          iihom = nlci-nreci 
    3293          DO jl = 1, jpreci 
    3294             zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 
    3295             zt3we(:,jl,:,1) = ptab(iihom +jl,:,:) 
    3296          END DO 
    3297       END SELECT 
    3298       ! 
    3299       !                           ! Migrations 
    3300       imigr = jpreci * jpj * jpk 
    3301       ! 
    3302       SELECT CASE ( nbondi_bdy(ib_bdy) ) 
    3303       CASE ( -1 ) 
    3304          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 
    3305       CASE ( 0 ) 
    3306          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    3307          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 
    3308       CASE ( 1 ) 
    3309          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    3310       END SELECT 
    3311       ! 
    3312       SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
    3313       CASE ( -1 ) 
    3314          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    3315       CASE ( 0 ) 
    3316          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    3317          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    3318       CASE ( 1 ) 
    3319          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    3320       END SELECT 
    3321       ! 
    3322       SELECT CASE ( nbondi_bdy(ib_bdy) ) 
    3323       CASE ( -1 ) 
    3324          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3325       CASE ( 0 ) 
    3326          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3327          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    3328       CASE ( 1 ) 
    3329          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3330       END SELECT 
    3331       ! 
    3332       !                           ! Write Dirichlet lateral conditions 
    3333       iihom = nlci-jpreci 
    3334       ! 
    3335       SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
    3336       CASE ( -1 ) 
    3337          DO jl = 1, jpreci 
    3338             ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 
    3339          END DO 
    3340       CASE ( 0 ) 
    3341          DO jl = 1, jpreci 
    3342             ptab(      jl,:,:) = zt3we(:,jl,:,2) 
    3343             ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 
    3344          END DO 
    3345       CASE ( 1 ) 
    3346          DO jl = 1, jpreci 
    3347             ptab(      jl,:,:) = zt3we(:,jl,:,2) 
    3348          END DO 
    3349       END SELECT 
    3350  
    3351  
    3352       ! 3. North and south directions 
    3353       ! ----------------------------- 
    3354       ! always closed : we play only with the neigbours 
    3355       ! 
    3356       IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    3357          ijhom = nlcj-nrecj 
    3358          DO jl = 1, jprecj 
    3359             zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 
    3360             zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 
    3361          END DO 
    3362       ENDIF 
    3363       ! 
    3364       !                           ! Migrations 
    3365       imigr = jprecj * jpi * jpk 
    3366       ! 
    3367       SELECT CASE ( nbondj_bdy(ib_bdy) ) 
    3368       CASE ( -1 ) 
    3369          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 
    3370       CASE ( 0 ) 
    3371          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    3372          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 
    3373       CASE ( 1 ) 
    3374          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    3375       END SELECT 
    3376       ! 
    3377       SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
    3378       CASE ( -1 ) 
    3379          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    3380       CASE ( 0 ) 
    3381          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    3382          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    3383       CASE ( 1 ) 
    3384          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    3385       END SELECT 
    3386       ! 
    3387       SELECT CASE ( nbondj_bdy(ib_bdy) ) 
    3388       CASE ( -1 ) 
    3389          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3390       CASE ( 0 ) 
    3391          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3392          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    3393       CASE ( 1 ) 
    3394          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3395       END SELECT 
    3396       ! 
    3397       !                           ! Write Dirichlet lateral conditions 
    3398       ijhom = nlcj-jprecj 
    3399       ! 
    3400       SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
    3401       CASE ( -1 ) 
    3402          DO jl = 1, jprecj 
    3403             ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 
    3404          END DO 
    3405       CASE ( 0 ) 
    3406          DO jl = 1, jprecj 
    3407             ptab(:,jl      ,:) = zt3sn(:,jl,:,2) 
    3408             ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 
    3409          END DO 
    3410       CASE ( 1 ) 
    3411          DO jl = 1, jprecj 
    3412             ptab(:,jl,:) = zt3sn(:,jl,:,2) 
    3413          END DO 
    3414       END SELECT 
    3415  
    3416  
    3417       ! 4. north fold treatment 
    3418       ! ----------------------- 
    3419       ! 
    3420       IF( npolj /= 0) THEN 
    3421          ! 
    3422          SELECT CASE ( jpni ) 
    3423          CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
    3424          CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
    3425          END SELECT 
    3426          ! 
    3427       ENDIF 
    3428       ! 
    3429       DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we  ) 
    3430       ! 
    3431    END SUBROUTINE mpp_lnk_bdy_3d 
    3432  
    3433  
    3434    SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) 
    3435       !!---------------------------------------------------------------------- 
    3436       !!                  ***  routine mpp_lnk_bdy_2d  *** 
    3437       !! 
    3438       !! ** Purpose :   Message passing management 
    3439       !! 
    3440       !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries  
    3441       !!      between processors following neighboring subdomains. 
    3442       !!            domain parameters 
    3443       !!                    nlci   : first dimension of the local subdomain 
    3444       !!                    nlcj   : second dimension of the local subdomain 
    3445       !!                    nbondi_bdy : mark for "east-west local boundary" 
    3446       !!                    nbondj_bdy : mark for "north-south local boundary" 
    3447       !!                    noea   : number for local neighboring processors  
    3448       !!                    nowe   : number for local neighboring processors 
    3449       !!                    noso   : number for local neighboring processors 
    3450       !!                    nono   : number for local neighboring processors 
    3451       !! 
    3452       !! ** Action  :   ptab with update value at its periphery 
    3453       !! 
    3454       !!---------------------------------------------------------------------- 
    3455       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
    3456       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
    3457       !                                                         ! = T , U , V , F , W points 
    3458       REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    3459       !                                                         ! =  1. , the sign is kept 
    3460       INTEGER                     , INTENT(in   ) ::   ib_bdy   ! BDY boundary set 
    3461       ! 
    3462       INTEGER  ::   ji, jj, jl             ! dummy loop indices 
    3463       INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    3464       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    3465       REAL(wp) ::   zland 
    3466       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    3467       ! 
    3468       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
    3469       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
    3470       !!---------------------------------------------------------------------- 
    3471  
    3472       ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  & 
    3473          &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   ) 
    3474  
    3475       zland = 0._wp 
    3476  
    3477       ! 1. standard boundary treatment 
    3478       ! ------------------------------ 
    3479       !                                   ! East-West boundaries 
    3480       !                                      !* Cyclic east-west 
    3481       IF( nbondi == 2 ) THEN 
    3482          IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 
    3483             ptab( 1 ,:) = ptab(jpim1,:) 
    3484             ptab(jpi,:) = ptab(  2  ,:) 
    3485          ELSE 
    3486             IF(.NOT.cd_type == 'F' )  ptab(     1       :jpreci,:) = zland    ! south except F-point 
    3487                                       ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
    3488          ENDIF 
    3489       ELSEIF(nbondi == -1) THEN 
    3490          IF( .NOT.cd_type == 'F' )    ptab(     1       :jpreci,:) = zland    ! south except F-point 
    3491       ELSEIF(nbondi == 1) THEN 
    3492                                       ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
    3493       ENDIF 
    3494       !                                      !* closed 
    3495       IF( nbondj == 2 .OR. nbondj == -1 ) THEN 
    3496          IF( .NOT.cd_type == 'F' )    ptab(:,     1       :jprecj) = zland    ! south except F-point 
    3497       ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
    3498                                       ptab(:,nlcj-jprecj+1:jpj   ) = zland    ! north 
    3499       ENDIF 
    3500       ! 
    3501       ! 2. East and west directions exchange 
    3502       ! ------------------------------------ 
    3503       ! we play with the neigbours AND the row number because of the periodicity  
    3504       ! 
    3505       SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions 
    3506       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    3507          iihom = nlci-nreci 
    3508          DO jl = 1, jpreci 
    3509             zt2ew(:,jl,1) = ptab(jpreci+jl,:) 
    3510             zt2we(:,jl,1) = ptab(iihom +jl,:) 
    3511          END DO 
    3512       END SELECT 
    3513       ! 
    3514       !                           ! Migrations 
    3515       imigr = jpreci * jpj 
    3516       ! 
    3517       SELECT CASE ( nbondi_bdy(ib_bdy) ) 
    3518       CASE ( -1 ) 
    3519          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 
    3520       CASE ( 0 ) 
    3521          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    3522          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 
    3523       CASE ( 1 ) 
    3524          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    3525       END SELECT 
    3526       ! 
    3527       SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
    3528       CASE ( -1 ) 
    3529          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    3530       CASE ( 0 ) 
    3531          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    3532          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    3533       CASE ( 1 ) 
    3534          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    3535       END SELECT 
    3536       ! 
    3537       SELECT CASE ( nbondi_bdy(ib_bdy) ) 
    3538       CASE ( -1 ) 
    3539          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3540       CASE ( 0 ) 
    3541          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3542          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    3543       CASE ( 1 ) 
    3544          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3545       END SELECT 
    3546       ! 
    3547       !                           ! Write Dirichlet lateral conditions 
    3548       iihom = nlci-jpreci 
    3549       ! 
    3550       SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
    3551       CASE ( -1 ) 
    3552          DO jl = 1, jpreci 
    3553             ptab(iihom+jl,:) = zt2ew(:,jl,2) 
    3554          END DO 
    3555       CASE ( 0 ) 
    3556          DO jl = 1, jpreci 
    3557             ptab(jl      ,:) = zt2we(:,jl,2) 
    3558             ptab(iihom+jl,:) = zt2ew(:,jl,2) 
    3559          END DO 
    3560       CASE ( 1 ) 
    3561          DO jl = 1, jpreci 
    3562             ptab(jl      ,:) = zt2we(:,jl,2) 
    3563          END DO 
    3564       END SELECT 
    3565  
    3566  
    3567       ! 3. North and south directions 
    3568       ! ----------------------------- 
    3569       ! always closed : we play only with the neigbours 
    3570       ! 
    3571       IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    3572          ijhom = nlcj-nrecj 
    3573          DO jl = 1, jprecj 
    3574             zt2sn(:,jl,1) = ptab(:,ijhom +jl) 
    3575             zt2ns(:,jl,1) = ptab(:,jprecj+jl) 
    3576          END DO 
    3577       ENDIF 
    3578       ! 
    3579       !                           ! Migrations 
    3580       imigr = jprecj * jpi 
    3581       ! 
    3582       SELECT CASE ( nbondj_bdy(ib_bdy) ) 
    3583       CASE ( -1 ) 
    3584          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 
    3585       CASE ( 0 ) 
    3586          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    3587          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 
    3588       CASE ( 1 ) 
    3589          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    3590       END SELECT 
    3591       ! 
    3592       SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
    3593       CASE ( -1 ) 
    3594          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    3595       CASE ( 0 ) 
    3596          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    3597          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    3598       CASE ( 1 ) 
    3599          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    3600       END SELECT 
    3601       ! 
    3602       SELECT CASE ( nbondj_bdy(ib_bdy) ) 
    3603       CASE ( -1 ) 
    3604          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3605       CASE ( 0 ) 
    3606          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3607          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    3608       CASE ( 1 ) 
    3609          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3610       END SELECT 
    3611       ! 
    3612       !                           ! Write Dirichlet lateral conditions 
    3613       ijhom = nlcj-jprecj 
    3614       ! 
    3615       SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
    3616       CASE ( -1 ) 
    3617          DO jl = 1, jprecj 
    3618             ptab(:,ijhom+jl) = zt2ns(:,jl,2) 
    3619          END DO 
    3620       CASE ( 0 ) 
    3621          DO jl = 1, jprecj 
    3622             ptab(:,jl      ) = zt2sn(:,jl,2) 
    3623             ptab(:,ijhom+jl) = zt2ns(:,jl,2) 
    3624          END DO 
    3625       CASE ( 1 ) 
    3626          DO jl = 1, jprecj 
    3627             ptab(:,jl) = zt2sn(:,jl,2) 
    3628          END DO 
    3629       END SELECT 
    3630  
    3631  
    3632       ! 4. north fold treatment 
    3633       ! ----------------------- 
    3634       ! 
    3635       IF( npolj /= 0) THEN 
    3636          ! 
    3637          SELECT CASE ( jpni ) 
    3638          CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
    3639          CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
    3640          END SELECT 
    3641          ! 
    3642       ENDIF 
    3643       ! 
    3644       DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we  ) 
    3645       ! 
    3646    END SUBROUTINE mpp_lnk_bdy_2d 
    36471532 
    36481533 
    … …  
    37061591   END SUBROUTINE mpi_init_opa 
    37071592 
    3708    SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype) 
     1593 
     1594   SUBROUTINE DDPDD_MPI( ydda, yddb, ilen, itype ) 
    37091595      !!--------------------------------------------------------------------- 
    37101596      !!   Routine DDPDD_MPI: used by reduction operator MPI_SUMDD 
    … …  
    37131599      !!   This subroutine computes yddb(i) = ydda(i)+yddb(i) 
    37141600      !!--------------------------------------------------------------------- 
    3715       INTEGER, INTENT(in)                         :: ilen, itype 
    3716       COMPLEX(wp), DIMENSION(ilen), INTENT(in)     :: ydda 
    3717       COMPLEX(wp), DIMENSION(ilen), INTENT(inout)  :: yddb 
     1601      INTEGER                     , INTENT(in)    ::  ilen, itype 
     1602      COMPLEX(wp), DIMENSION(ilen), INTENT(in)    ::  ydda 
     1603      COMPLEX(wp), DIMENSION(ilen), INTENT(inout) ::  yddb 
    37181604      ! 
    37191605      REAL(wp) :: zerr, zt1, zt2    ! local work variables 
    3720       INTEGER :: ji, ztmp           ! local scalar 
    3721  
     1606      INTEGER  :: ji, ztmp           ! local scalar 
     1607      !!--------------------------------------------------------------------- 
     1608      ! 
    37221609      ztmp = itype   ! avoid compilation warning 
    3723  
     1610      ! 
    37241611      DO ji=1,ilen 
    37251612      ! Compute ydda + yddb using Knuth's trick. 
    … …  
    37321619         yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp ) 
    37331620      END DO 
    3734  
     1621      ! 
    37351622   END SUBROUTINE DDPDD_MPI 
    37361623 
    … …  
    38021689      END DO 
    38031690 
    3804  
    38051691      ! 2. North-Fold boundary conditions 
    38061692      ! ---------------------------------- 
    3807       CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj ) 
     1693!!gm ERROR      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj ) 
    38081694 
    38091695      ij = ipr2dj 
    … …  
    38411727      !!                    nono   : number for local neighboring processors 
    38421728      !!---------------------------------------------------------------------- 
     1729      REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
     1730      CHARACTER(len=1)                                    , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
     1731      REAL(wp)                                            , INTENT(in   ) ::   psgn     ! sign used across the north fold 
    38431732      INTEGER                                             , INTENT(in   ) ::   jpri 
    38441733      INTEGER                                             , INTENT(in   ) ::   jprj 
    3845       REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    3846       CHARACTER(len=1)                                    , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
    3847       !                                                                                 ! = T , U , V , F , W and I points 
    3848       REAL(wp)                                            , INTENT(in   ) ::   psgn     ! =-1 the sign change across the 
    3849       !!                                                                                ! north boundary, =  1. otherwise 
     1734      ! 
    38501735      INTEGER  ::   jl   ! dummy loop indices 
    3851       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    3852       INTEGER  ::   ipreci, iprecj             ! temporary integers 
     1736      INTEGER  ::   imigr, iihom, ijhom        ! local integers 
     1737      INTEGER  ::   ipreci, iprecj             !   -       - 
    38531738      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    38541739      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    38551740      !! 
    3856       REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns 
    3857       REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn 
    3858       REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe 
    3859       REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew 
     1741      REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) ::   r2dns, r2dsn 
     1742      REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) ::   r2dwe, r2dew 
    38601743      !!---------------------------------------------------------------------- 
    38611744 
    … …  
    38751758         ! 
    38761759      ELSE                                        !* closed 
    3877          IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0.e0    ! south except at F-point 
    3878                                       pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0    ! north 
     1760         IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0._wp    ! south except at F-point 
     1761                                      pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp    ! north 
    38791762      ENDIF 
    38801763      ! 
    … …  
    38851768         ! 
    38861769         SELECT CASE ( jpni ) 
    3887          CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 
    3888          CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj)  , cd_type, psgn , pr2dj=jprj  ) 
     1770!!gm ERROR         CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 
     1771!!gm ERROR         CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj)  , cd_type, psgn , pr2dj=jprj  ) 
    38891772         END SELECT 
    38901773         ! 
    … …  
    39961879         END DO 
    39971880      END SELECT 
    3998  
     1881      ! 
    39991882   END SUBROUTINE mpp_lnk_2d_icb 
    40001883    
    … …  
    40201903      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
    40211904   END INTERFACE 
     1905   INTERFACE mpp_max_multiple 
     1906      MODULE PROCEDURE mppmax_real_multiple 
     1907   END INTERFACE 
    40221908 
    40231909   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag 
    … …  
    41912077      WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom 
    41922078   END SUBROUTINE mpp_comm_free 
     2079    
     2080   SUBROUTINE mppmax_real_multiple( ptab, kdim , kcom  ) 
     2081      REAL, DIMENSION(:) ::   ptab   !  
     2082      INTEGER            ::   kdim   !  
     2083      INTEGER, OPTIONAL  ::   kcom   !  
     2084      WRITE(*,*) 'mppmax_real_multiple: You should not have seen this print! error?', ptab(1), kdim 
     2085   END SUBROUTINE mppmax_real_multiple 
     2086 
    41932087#endif 
    41942088 
    … …  
    42252119                               CALL FLUSH(numout    ) 
    42262120      IF( numstp     /= -1 )   CALL FLUSH(numstp    ) 
    4227       IF( numsol     /= -1 )   CALL FLUSH(numsol    ) 
     2121      IF( numrun     /= -1 )   CALL FLUSH(numrun    ) 
    42282122      IF( numevo_ice /= -1 )   CALL FLUSH(numevo_ice) 
    42292123      ! 
    … …  
    43322226            WRITE(kout,*) 
    43332227         ENDIF 
    4334          CALL FLUSH(kout)  
     2228         CALL FLUSH( kout )  
    43352229         STOP 'ctl_opn bad opening' 
    43362230      ENDIF 
Note: See TracChangeset for help on using the changeset viewer.