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

Ignore:
Timestamp:
2017-12-13T15:58:53+01:00 (7 years ago)
Author:
timgraham
Message:

Merge of dev_CNRS_2017 into branch

File:
1 edited

Legend:

Unmodified
Added
Removed

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

    r7753 r9019  
    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 
    44    !!   mpp_lnk_e     : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e) 
    4543   !!   mpp_lnk_icb   : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 
    4644   !!   mpprecv       : 
    47    !!   mppsend       :   SUBROUTINE mpp_ini_znl 
     45   !!   mppsend       : 
    4846   !!   mppscatter    : 
    4947   !!   mppgather     : 
    … …  
    5654   !!   mppstop       : 
    5755   !!   mpp_ini_north : initialisation of north fold 
    58    !!   mpp_lbc_north : north fold processors gathering 
    59    !!   mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo 
    60    !!   mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs 
     56   !!   mpp_lbc_north_icb : alternative to mpp_nfd for extra outer halo with icebergs 
    6157   !!---------------------------------------------------------------------- 
    6258   USE dom_oce        ! ocean space and time domain 
    … …  
    6763   IMPLICIT NONE 
    6864   PRIVATE 
    69     
     65 
     66   INTERFACE mpp_nfd 
     67      MODULE PROCEDURE   mpp_nfd_2d      , mpp_nfd_3d      , mpp_nfd_4d 
     68      MODULE PROCEDURE   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 
     69   END INTERFACE 
     70 
     71   ! Interface associated to the mpp_lnk_... routines is defined in lbclnk 
     72   PUBLIC   mpp_lnk_2d      , mpp_lnk_3d      , mpp_lnk_4d 
     73   PUBLIC   mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr 
     74   ! 
     75!!gm  this should be useless 
     76   PUBLIC   mpp_nfd_2d    , mpp_nfd_3d    , mpp_nfd_4d 
     77   PUBLIC   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 
     78!!gm end 
     79   ! 
    7080   PUBLIC   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 
    7181   PUBLIC   mynode, mppstop, mppsync, mpp_comm_free 
    72    PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 
     82   PUBLIC   mpp_ini_north 
     83   PUBLIC   mpp_lnk_2d_icb 
     84   PUBLIC   mpp_lbc_north_icb 
    7385   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
    7486   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 
    7887   PUBLIC   mppscatter, mppgather 
    7988   PUBLIC   mpp_ini_ice, mpp_ini_znl 
    … …  
    8190   PUBLIC   mppsend, mpprecv                          ! needed by TAM and ICB routines 
    8291   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
    83    PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
    8492   PUBLIC   mpprank 
    85  
    86    TYPE arrayptr 
    87       REAL , DIMENSION (:,:),  POINTER :: pt2d 
    88    END TYPE arrayptr 
    89    PUBLIC   arrayptr 
    9093    
    9194   !! * Interfaces 
    … …  
    101104   INTERFACE mpp_sum 
    102105      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real,   & 
    103                        mppsum_realdd, mppsum_a_realdd 
    104    END INTERFACE 
    105    INTERFACE mpp_lbc_north 
    106       MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 
     106         &             mppsum_realdd, mppsum_a_realdd 
    107107   END INTERFACE 
    108108   INTERFACE mpp_minloc 
    … …  
    112112      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
    113113   END INTERFACE 
    114  
    115114   INTERFACE mpp_max_multiple 
    116115      MODULE PROCEDURE mppmax_real_multiple 
    … …  
    138137   ! variables used in case of sea-ice 
    139138   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 
     139   INTEGER         ::   ngrp_iworld     !  group ID for the world processors (for rheology) 
     140   INTEGER         ::   ngrp_ice        !  group ID for the ice processors (for rheology) 
     141   INTEGER         ::   ndim_rank_ice   !  number of 'ice' processors 
     142   INTEGER         ::   n_ice_root      !  number (in the comm_ice) of proc 0 in the ice comm 
    144143   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_ice     ! dimension ndim_rank_ice 
    145144 
    146145   ! variables used for zonal integration 
    147146   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 
     147   LOGICAL, PUBLIC ::   l_znl_root      !: True on the 'left'most processor on the same row 
     148   INTEGER         ::   ngrp_znl        ! group ID for the znl processors 
     149   INTEGER         ::   ndim_rank_znl   ! number of processors on the same zonal average 
    151150   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_znl  ! dimension ndim_rank_znl, number of the procs into the same znl domain 
    152151 
    153152   ! 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 
     153   INTEGER, PUBLIC ::   ngrp_world        !: group ID for the world processors 
     154   INTEGER, PUBLIC ::   ngrp_opa          !: group ID for the opa processors 
     155   INTEGER, PUBLIC ::   ngrp_north        !: group ID for the northern processors (to be fold) 
     156   INTEGER, PUBLIC ::   ncomm_north       !: communicator made by the processors belonging to ngrp_north 
     157   INTEGER, PUBLIC ::   ndim_rank_north   !: number of 'sea' processor in the northern line (can be /= jpni !) 
     158   INTEGER, PUBLIC ::   njmppmax          !: value of njmpp for the processors of the northern line 
     159   INTEGER, PUBLIC ::   north_root        !: number (in the comm_opa) of proc 0 in the northern comm 
     160   INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_north   !: dimension ndim_rank_north 
    162161 
    163162   ! 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) 
     163   CHARACTER(len=1), PUBLIC ::   cn_mpi_send        !: type od mpi send/recieve (S=standard, B=bsend, I=isend) 
     164   LOGICAL         , PUBLIC ::   l_isend = .FALSE.  !: isend use indicator (T if cn_mpi_send='I') 
     165   INTEGER         , PUBLIC ::   nn_buffer          !: size of the buffer in case of mpi_bsend 
     166 
     167   REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::   tampon   ! buffer in case of bsend 
     168 
     169   LOGICAL, PUBLIC ::   ln_nnogather                !: namelist control of northfold comms 
     170   LOGICAL, PUBLIC ::   l_north_nogather = .FALSE.  !: internal control of northfold comms 
     171 
     172   !!---------------------------------------------------------------------- 
     173   !! NEMO/OPA 4.0 , NEMO Consortium (2017) 
    175174   !! $Id$ 
    176175   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    178177CONTAINS 
    179178 
    180  
    181    FUNCTION mynode( ldtxt, ldname, kumnam_ref , kumnam_cfg , kumond , kstop, localComm ) 
     179   FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm ) 
    182180      !!---------------------------------------------------------------------- 
    183181      !!                  ***  routine mynode  *** 
    … …  
    204202      WRITE(ldtxt(ii),*) '~~~~~~ '                                                        ;   ii = ii + 1 
    205203      ! 
    206  
    207204      REWIND( kumnam_ref )              ! Namelist nammpp in reference namelist: mpi variables 
    208205      READ  ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901) 
    209206901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp ) 
    210  
     207      ! 
    211208      REWIND( kumnam_cfg )              ! Namelist nammpp in configuration namelist: mpi variables 
    212209      READ  ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 
    213210902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp ) 
    214  
     211      ! 
    215212      !                              ! control print 
    216213      WRITE(ldtxt(ii),*) '   Namelist nammpp'                                             ;   ii = ii + 1 
    217214      WRITE(ldtxt(ii),*) '      mpi send type          cn_mpi_send = ', cn_mpi_send       ;   ii = ii + 1 
    218215      WRITE(ldtxt(ii),*) '      size exported buffer   nn_buffer   = ', nn_buffer,' bytes';   ii = ii + 1 
    219  
     216      ! 
    220217#if defined key_agrif 
    221218      IF( .NOT. Agrif_Root() ) THEN 
    … …  
    225222      ENDIF 
    226223#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 
     224      ! 
     225      IF( jpnij < 1 ) THEN         ! If jpnij is not specified in namelist then we calculate it 
     226         jpnij = jpni * jpnj       ! this means there will be no land cutting out. 
     227      ENDIF 
     228 
     229      IF( jpni < 1 .OR. jpnj < 1  ) THEN 
    235230         WRITE(ldtxt(ii),*) '      jpni, jpnj and jpnij will be calculated automatically' ;   ii = ii + 1 
    236231      ELSE 
    … …  
    238233         WRITE(ldtxt(ii),*) '      processor grid extent in j         jpnj = ',jpnj       ;   ii = ii + 1 
    239234         WRITE(ldtxt(ii),*) '      number of local domains           jpnij = ',jpnij      ;   ii = ii + 1 
    240       END IF 
     235      ENDIF 
    241236 
    242237      WRITE(ldtxt(ii),*) '      avoid use of mpi_allgather at the north fold  ln_nnogather = ', ln_nnogather  ; ii = ii + 1 
    … …  
    268263            kstop = kstop + 1 
    269264         END SELECT 
    270       ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN 
     265         ! 
     266      ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN 
    271267         WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator '          ;   ii = ii + 1 
    272268         WRITE(ldtxt(ii),*) '          without calling MPI_Init before ! '                ;   ii = ii + 1 
    … …  
    309305 
    310306#if defined key_agrif 
    311       IF (Agrif_Root()) THEN 
     307      IF( Agrif_Root() ) THEN 
    312308         CALL Agrif_MPI_Init(mpi_comm_opa) 
    313309      ELSE 
    … …  
    329325   END FUNCTION mynode 
    330326 
    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 
     327   !!---------------------------------------------------------------------- 
     328   !!                   ***  routine mpp_lnk_(2,3,4)d  *** 
     329   !! 
     330   !!   * Argument : dummy argument use in mpp_lnk_... routines 
     331   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
     332   !!                cd_nat :   nature of array grid-points 
     333   !!                psgn   :   sign used across the north fold boundary 
     334   !!                kfld   :   optional, number of pt3d arrays 
     335   !!                cd_mpp :   optional, fill the overlap area only 
     336   !!                pval   :   optional, background value (used at closed boundaries) 
     337   !!---------------------------------------------------------------------- 
     338   ! 
     339   !                       !==  2D array and array of 2D pointer  ==! 
     340   ! 
     341#  define DIM_2d 
     342#     define ROUTINE_LNK           mpp_lnk_2d 
     343#     include "mpp_lnk_generic.h90" 
     344#     undef ROUTINE_LNK 
     345#     define MULTI 
     346#     define ROUTINE_LNK           mpp_lnk_2d_ptr 
     347#     include "mpp_lnk_generic.h90" 
     348#     undef ROUTINE_LNK 
     349#     undef MULTI 
     350#  undef DIM_2d 
     351   ! 
     352   !                       !==  3D array and array of 3D pointer  ==! 
     353   ! 
     354#  define DIM_3d 
     355#     define ROUTINE_LNK           mpp_lnk_3d 
     356#     include "mpp_lnk_generic.h90" 
     357#     undef ROUTINE_LNK 
     358#     define MULTI 
     359#     define ROUTINE_LNK           mpp_lnk_3d_ptr 
     360#     include "mpp_lnk_generic.h90" 
     361#     undef ROUTINE_LNK 
     362#     undef MULTI 
     363#  undef DIM_3d 
     364   ! 
     365   !                       !==  4D array and array of 4D pointer  ==! 
     366   ! 
     367#  define DIM_4d 
     368#     define ROUTINE_LNK           mpp_lnk_4d 
     369#     include "mpp_lnk_generic.h90" 
     370#     undef ROUTINE_LNK 
     371#     define MULTI 
     372#     define ROUTINE_LNK           mpp_lnk_4d_ptr 
     373#     include "mpp_lnk_generic.h90" 
     374#     undef ROUTINE_LNK 
     375#     undef MULTI 
     376#  undef DIM_4d 
     377 
     378   !!---------------------------------------------------------------------- 
     379   !!                   ***  routine mpp_nfd_(2,3,4)d  *** 
     380   !! 
     381   !!   * Argument : dummy argument use in mpp_nfd_... routines 
     382   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
     383   !!                cd_nat :   nature of array grid-points 
     384   !!                psgn   :   sign used across the north fold boundary 
     385   !!                kfld   :   optional, number of pt3d arrays 
     386   !!                cd_mpp :   optional, fill the overlap area only 
     387   !!                pval   :   optional, background value (used at closed boundaries) 
     388   !!---------------------------------------------------------------------- 
     389   ! 
     390   !                       !==  2D array and array of 2D pointer  ==! 
     391   ! 
     392#  define DIM_2d 
     393#     define ROUTINE_NFD           mpp_nfd_2d 
     394#     include "mpp_nfd_generic.h90" 
     395#     undef ROUTINE_NFD 
     396#     define MULTI 
     397#     define ROUTINE_NFD           mpp_nfd_2d_ptr 
     398#     include "mpp_nfd_generic.h90" 
     399#     undef ROUTINE_NFD 
     400#     undef MULTI 
     401#  undef DIM_2d 
     402   ! 
     403   !                       !==  3D array and array of 3D pointer  ==! 
     404   ! 
     405#  define DIM_3d 
     406#     define ROUTINE_NFD           mpp_nfd_3d 
     407#     include "mpp_nfd_generic.h90" 
     408#     undef ROUTINE_NFD 
     409#     define MULTI 
     410#     define ROUTINE_NFD           mpp_nfd_3d_ptr 
     411#     include "mpp_nfd_generic.h90" 
     412#     undef ROUTINE_NFD 
     413#     undef MULTI 
     414#  undef DIM_3d 
     415   ! 
     416   !                       !==  4D array and array of 4D pointer  ==! 
     417   ! 
     418#  define DIM_4d 
     419#     define ROUTINE_NFD           mpp_nfd_4d 
     420#     include "mpp_nfd_generic.h90" 
     421#     undef ROUTINE_NFD 
     422#     define MULTI 
     423#     define ROUTINE_NFD           mpp_nfd_4d_ptr 
     424#     include "mpp_nfd_generic.h90" 
     425#     undef ROUTINE_NFD 
     426#     undef MULTI 
     427#  undef DIM_4d 
     428 
     429 
     430   !!---------------------------------------------------------------------- 
     431   !!                   ***  routine mpp_lnk_bdy_(2,3,4)d  *** 
     432   !! 
     433   !!   * Argument : dummy argument use in mpp_lnk_... routines 
     434   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
     435   !!                cd_nat :   nature of array grid-points 
     436   !!                psgn   :   sign used across the north fold boundary 
     437   !!                kb_bdy :   BDY boundary set 
     438   !!                kfld   :   optional, number of pt3d arrays 
     439   !!---------------------------------------------------------------------- 
     440   ! 
     441   !                       !==  2D array and array of 2D pointer  ==! 
     442   ! 
     443#  define DIM_2d 
     444#     define ROUTINE_BDY           mpp_lnk_bdy_2d 
     445#     include "mpp_bdy_generic.h90" 
     446#     undef ROUTINE_BDY 
     447#  undef DIM_2d 
     448   ! 
     449   !                       !==  3D array and array of 3D pointer  ==! 
     450   ! 
     451#  define DIM_3d 
     452#     define ROUTINE_BDY           mpp_lnk_bdy_3d 
     453#     include "mpp_bdy_generic.h90" 
     454#     undef ROUTINE_BDY 
     455#  undef DIM_3d 
     456   ! 
     457   !                       !==  4D array and array of 4D pointer  ==! 
     458   ! 
     459!!#  define DIM_4d 
     460!!#     define ROUTINE_BDY           mpp_lnk_bdy_4d 
     461!!#     include "mpp_bdy_generic.h90" 
     462!!#     undef ROUTINE_BDY 
     463!!#  undef DIM_4d 
     464 
     465   !!---------------------------------------------------------------------- 
     466   !! 
     467   !!   load_array  &   mpp_lnk_2d_9    à generaliser a 3D et 4D 
    782468    
    783469    
    784    SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
    785       &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
    786       &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
    787       !!--------------------------------------------------------------------- 
    788       ! Second 2D array on which the boundary condition is applied 
    789       REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA     
    790       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
    791       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI  
    792       ! define the nature of ptab array grid-points 
    793       CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
    794       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
    795       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
    796       ! =-1 the sign change across the north fold boundary 
    797       REAL(wp)                                      , INTENT(in   ) ::   psgnA     
    798       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
    799       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI    
    800       CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    801       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    802       !! 
    803       TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array  
    804       CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of ptab array grid-points 
    805       !                                                         ! = T , U , V , F , W and I points 
    806       REAL(wp)         , DIMENSION(9) ::   psgn_array    ! =-1 the sign change across the north fold boundary 
    807       INTEGER :: num_fields 
    808       !!--------------------------------------------------------------------- 
    809       ! 
    810       num_fields = 0 
    811       ! 
    812       ! Load the first array 
    813       CALL load_array( pt2dA, cd_typeA, psgnA, pt2d_array, type_array, psgn_array, num_fields ) 
    814       ! 
    815       ! Look if more arrays are added 
    816       IF( PRESENT(psgnB) )   CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields) 
    817       IF( PRESENT(psgnC) )   CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields) 
    818       IF( PRESENT(psgnD) )   CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields) 
    819       IF( PRESENT(psgnE) )   CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields) 
    820       IF( PRESENT(psgnF) )   CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields) 
    821       IF( PRESENT(psgnG) )   CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields) 
    822       IF( PRESENT(psgnH) )   CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields) 
    823       IF( PRESENT(psgnI) )   CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields) 
    824       ! 
    825       CALL mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, num_fields, cd_mpp,pval ) 
    826       ! 
    827    END SUBROUTINE mpp_lnk_2d_9 
    828  
    829  
    830    SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    831       !!---------------------------------------------------------------------- 
    832       !!                  ***  routine mpp_lnk_2d  *** 
    833       !! 
    834       !! ** Purpose :   Message passing manadgement for 2d array 
    835       !! 
    836       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    837       !!      between processors following neighboring subdomains. 
    838       !!            domain parameters 
    839       !!                    nlci   : first dimension of the local subdomain 
    840       !!                    nlcj   : second dimension of the local subdomain 
    841       !!                    nbondi : mark for "east-west local boundary" 
    842       !!                    nbondj : mark for "north-south local boundary" 
    843       !!                    noea   : number for local neighboring processors 
    844       !!                    nowe   : number for local neighboring processors 
    845       !!                    noso   : number for local neighboring processors 
    846       !!                    nono   : number for local neighboring processors 
    847       !! 
    848       !!---------------------------------------------------------------------- 
    849       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied 
    850       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
    851       !                                                         ! = T , U , V , F , W and I points 
    852       REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    853       !                                                         ! =  1. , the sign is kept 
    854       CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    855       REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    856       !! 
    857       INTEGER  ::   ji, jj, jl   ! dummy loop indices 
    858       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    859       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    860       REAL(wp) ::   zland 
    861       INTEGER, DIMENSION(MPI_STATUS_SIZE)     ::   ml_stat       ! for key_mpi_isend 
    862       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
    863       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
    864       !!---------------------------------------------------------------------- 
    865       ! 
    866       ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  & 
    867          &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   ) 
    868       ! 
    869       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    870       ELSE                         ;   zland = 0._wp     ! zero by default 
    871       ENDIF 
    872  
    873       ! 1. standard boundary treatment 
    874       ! ------------------------------ 
    875       ! 
    876       IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
    877          ! 
    878          ! WARNING pt2d is defined only between nld and nle 
    879          DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    880             pt2d(nldi  :nlei  , jj          ) = pt2d(nldi:nlei,     nlej) 
    881             pt2d(1     :nldi-1, jj          ) = pt2d(nldi     ,     nlej) 
    882             pt2d(nlei+1:nlci  , jj          ) = pt2d(     nlei,     nlej) 
    883          END DO 
    884          DO ji = nlci+1, jpi                 ! added column(s) (full) 
    885             pt2d(ji           ,nldj  :nlej  ) = pt2d(     nlei,nldj:nlej) 
    886             pt2d(ji           ,1     :nldj-1) = pt2d(     nlei,nldj     ) 
    887             pt2d(ji           ,nlej+1:jpj   ) = pt2d(     nlei,     nlej) 
    888          END DO 
    889          ! 
    890       ELSE                              ! standard close or cyclic treatment 
    891          ! 
    892          !                                   ! East-West boundaries 
    893          IF( nbondi == 2 .AND.   &                ! Cyclic east-west 
    894             &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    895             pt2d( 1 ,:) = pt2d(jpim1,:)                                    ! west 
    896             pt2d(jpi,:) = pt2d(  2  ,:)                                    ! east 
    897          ELSE                                     ! closed 
    898             IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point 
    899                                          pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north 
    900          ENDIF 
    901                                             ! North-South boudaries 
    902          IF ( nbondj == 2 .AND. jperio == 7 )    THEN !* cyclic north south 
    903             pt2d(:,  1 ) = pt2d(:,jpjm1) 
    904             pt2d(:, jpj) = pt2d(:,    2) 
    905          ELSE     
    906          !                                   ! North-South boundaries (closed) 
    907             IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland    !south except F-point 
    908                                          pt2d(:,nlcj-jprecj+1:jpj   ) = zland    ! north 
    909          ENDIF      
    910       ENDIF 
    911  
    912       ! 2. East and west directions exchange 
    913       ! ------------------------------------ 
    914       ! we play with the neigbours AND the row number because of the periodicity 
    915       ! 
    916       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    917       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    918          iihom = nlci-nreci 
    919          DO jl = 1, jpreci 
    920             zt2ew(:,jl,1) = pt2d(jpreci+jl,:) 
    921             zt2we(:,jl,1) = pt2d(iihom +jl,:) 
    922          END DO 
    923       END SELECT 
    924       ! 
    925       !                           ! Migrations 
    926       imigr = jpreci * jpj 
    927       ! 
    928       SELECT CASE ( nbondi ) 
    929       CASE ( -1 ) 
    930          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 
    931          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    932          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    933       CASE ( 0 ) 
    934          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    935          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 
    936          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    937          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    938          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    939          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    940       CASE ( 1 ) 
    941          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    942          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    943          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    944       END SELECT 
    945       ! 
    946       !                           ! Write Dirichlet lateral conditions 
    947       iihom = nlci - jpreci 
    948       ! 
    949       SELECT CASE ( nbondi ) 
    950       CASE ( -1 ) 
    951          DO jl = 1, jpreci 
    952             pt2d(iihom+jl,:) = zt2ew(:,jl,2) 
    953          END DO 
    954       CASE ( 0 ) 
    955          DO jl = 1, jpreci 
    956             pt2d(jl      ,:) = zt2we(:,jl,2) 
    957             pt2d(iihom+jl,:) = zt2ew(:,jl,2) 
    958          END DO 
    959       CASE ( 1 ) 
    960          DO jl = 1, jpreci 
    961             pt2d(jl      ,:) = zt2we(:,jl,2) 
    962          END DO 
    963       END SELECT 
    964  
    965  
    966       ! 3. North and south directions 
    967       ! ----------------------------- 
    968       ! always closed : we play only with the neigbours 
    969       ! 
    970       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    971          ijhom = nlcj-nrecj 
    972          DO jl = 1, jprecj 
    973             zt2sn(:,jl,1) = pt2d(:,ijhom +jl) 
    974             zt2ns(:,jl,1) = pt2d(:,jprecj+jl) 
    975          END DO 
    976       ENDIF 
    977       ! 
    978       !                           ! Migrations 
    979       imigr = jprecj * jpi 
    980       ! 
    981       SELECT CASE ( nbondj ) 
    982       CASE ( -1 ) 
    983          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 
    984          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    985          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    986       CASE ( 0 ) 
    987          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    988          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 
    989          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    990          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    991          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    992          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    993       CASE ( 1 ) 
    994          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    995          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    996          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    997       END SELECT 
    998       ! 
    999       !                           ! Write Dirichlet lateral conditions 
    1000       ijhom = nlcj - jprecj 
    1001       ! 
    1002       SELECT CASE ( nbondj ) 
    1003       CASE ( -1 ) 
    1004          DO jl = 1, jprecj 
    1005             pt2d(:,ijhom+jl) = zt2ns(:,jl,2) 
    1006          END DO 
    1007       CASE ( 0 ) 
    1008          DO jl = 1, jprecj 
    1009             pt2d(:,jl      ) = zt2sn(:,jl,2) 
    1010             pt2d(:,ijhom+jl) = zt2ns(:,jl,2) 
    1011          END DO 
    1012       CASE ( 1 ) 
    1013          DO jl = 1, jprecj 
    1014             pt2d(:,jl      ) = zt2sn(:,jl,2) 
    1015          END DO 
    1016       END SELECT 
    1017  
    1018  
    1019       ! 4. north fold treatment 
    1020       ! ----------------------- 
    1021       ! 
    1022       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    1023          ! 
    1024          SELECT CASE ( jpni ) 
    1025          CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp 
    1026          CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs. 
    1027          END SELECT 
    1028          ! 
    1029       ENDIF 
    1030       ! 
    1031       DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
    1032       ! 
    1033    END SUBROUTINE mpp_lnk_2d 
    1034  
    1035  
    1036    SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn ) 
    1037       !!---------------------------------------------------------------------- 
    1038       !!                  ***  routine mpp_lnk_3d_gather  *** 
    1039       !! 
    1040       !! ** Purpose :   Message passing manadgement for two 3D arrays 
    1041       !! 
    1042       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1043       !!      between processors following neighboring subdomains. 
    1044       !!            domain parameters 
    1045       !!                    nlci   : first dimension of the local subdomain 
    1046       !!                    nlcj   : second dimension of the local subdomain 
    1047       !!                    nbondi : mark for "east-west local boundary" 
    1048       !!                    nbondj : mark for "north-south local boundary" 
    1049       !!                    noea   : number for local neighboring processors 
    1050       !!                    nowe   : number for local neighboring processors 
    1051       !!                    noso   : number for local neighboring processors 
    1052       !!                    nono   : number for local neighboring processors 
    1053       !! 
    1054       !! ** Action  :   ptab1 and ptab2  with update value at its periphery 
    1055       !! 
    1056       !!---------------------------------------------------------------------- 
    1057       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab1     ! first and second 3D array on which 
    1058       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab2     ! the boundary condition is applied 
    1059       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1  ! nature of ptab1 and ptab2 arrays 
    1060       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type2  ! i.e. grid-points = T , U , V , F or W points 
    1061       REAL(wp)                        , INTENT(in   ) ::   psgn      ! =-1 the sign change across the north fold boundary 
    1062       !!                                                             ! =  1. , the sign is kept 
    1063       INTEGER  ::   jl   ! dummy loop indices 
    1064       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    1065       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1066       INTEGER , DIMENSION(MPI_STATUS_SIZE)        ::   ml_stat   ! for key_mpi_isend 
    1067       REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zt4ns, zt4sn   ! 2 x 3d for north-south & south-north 
    1068       REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zt4ew, zt4we   ! 2 x 3d for east-west & west-east 
    1069       !!---------------------------------------------------------------------- 
    1070       ! 
    1071       ALLOCATE( zt4ns(jpi,jprecj,jpk,2,2), zt4sn(jpi,jprecj,jpk,2,2) ,    & 
    1072          &      zt4ew(jpj,jpreci,jpk,2,2), zt4we(jpj,jpreci,jpk,2,2) ) 
    1073       ! 
    1074       ! 1. standard boundary treatment 
    1075       ! ------------------------------ 
    1076       !                                      ! East-West boundaries 
    1077       !                                           !* Cyclic east-west 
    1078       IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    1079          ptab1( 1 ,:,:) = ptab1(jpim1,:,:) 
    1080          ptab1(jpi,:,:) = ptab1(  2  ,:,:) 
    1081          ptab2( 1 ,:,:) = ptab2(jpim1,:,:) 
    1082          ptab2(jpi,:,:) = ptab2(  2  ,:,:) 
    1083       ELSE                                        !* closed 
    1084          IF( .NOT. cd_type1 == 'F' )   ptab1(     1       :jpreci,:,:) = 0.e0    ! south except at F-point 
    1085          IF( .NOT. cd_type2 == 'F' )   ptab2(     1       :jpreci,:,:) = 0.e0 
    1086                                        ptab1(nlci-jpreci+1:jpi   ,:,:) = 0.e0    ! north 
    1087                                        ptab2(nlci-jpreci+1:jpi   ,:,:) = 0.e0 
    1088       ENDIF 
    1089                                             ! North-South boundaries 
    1090       IF ( nbondj == 2 .AND. jperio == 7 )    THEN !* cyclic north south 
    1091          ptab1(:,     1       ,:) = ptab1(: ,  jpjm1 , :) 
    1092          ptab1(:,   jpj       ,:) = ptab1(: ,      2 , :) 
    1093          ptab2(:,     1       ,:) = ptab2(: ,  jpjm1 , :) 
    1094          ptab2(:,   jpj       ,:) = ptab2(: ,      2 , :) 
    1095       ELSE      
    1096       !                                      ! North-South boundaries closed 
    1097       IF( .NOT. cd_type1 == 'F' )   ptab1(:,     1       :jprecj,:) = 0.e0    ! south except at F-point 
    1098       IF( .NOT. cd_type2 == 'F' )   ptab2(:,     1       :jprecj,:) = 0.e0 
    1099                                     ptab1(:,nlcj-jprecj+1:jpj   ,:) = 0.e0    ! north 
    1100                                     ptab2(:,nlcj-jprecj+1:jpj   ,:) = 0.e0 
    1101       ENDIF      
    1102  
    1103       ! 2. East and west directions exchange 
    1104       ! ------------------------------------ 
    1105       ! we play with the neigbours AND the row number because of the periodicity 
    1106       ! 
    1107       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    1108       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1109          iihom = nlci-nreci 
    1110          DO jl = 1, jpreci 
    1111             zt4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:) 
    1112             zt4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:) 
    1113             zt4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:) 
    1114             zt4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:) 
    1115          END DO 
    1116       END SELECT 
    1117       ! 
    1118       !                           ! Migrations 
    1119       imigr = jpreci * jpj * jpk *2 
    1120       ! 
    1121       SELECT CASE ( nbondi ) 
    1122       CASE ( -1 ) 
    1123          CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req1 ) 
    1124          CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea ) 
    1125          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1126       CASE ( 0 ) 
    1127          CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 
    1128          CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req2 ) 
    1129          CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea ) 
    1130          CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe ) 
    1131          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1132          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    1133       CASE ( 1 ) 
    1134          CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 
    1135          CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe ) 
    1136          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1137       END SELECT 
    1138       ! 
    1139       !                           ! Write Dirichlet lateral conditions 
    1140       iihom = nlci - jpreci 
    1141       ! 
    1142       SELECT CASE ( nbondi ) 
    1143       CASE ( -1 ) 
    1144          DO jl = 1, jpreci 
    1145             ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2) 
    1146             ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2) 
    1147          END DO 
    1148       CASE ( 0 ) 
    1149          DO jl = 1, jpreci 
    1150             ptab1(jl      ,:,:) = zt4we(:,jl,:,1,2) 
    1151             ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2) 
    1152             ptab2(jl      ,:,:) = zt4we(:,jl,:,2,2) 
    1153             ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2) 
    1154          END DO 
    1155       CASE ( 1 ) 
    1156          DO jl = 1, jpreci 
    1157             ptab1(jl      ,:,:) = zt4we(:,jl,:,1,2) 
    1158             ptab2(jl      ,:,:) = zt4we(:,jl,:,2,2) 
    1159          END DO 
    1160       END SELECT 
    1161  
    1162  
    1163       ! 3. North and south directions 
    1164       ! ----------------------------- 
    1165       ! always closed : we play only with the neigbours 
    1166       ! 
    1167       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    1168          ijhom = nlcj - nrecj 
    1169          DO jl = 1, jprecj 
    1170             zt4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:) 
    1171             zt4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:) 
    1172             zt4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:) 
    1173             zt4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:) 
    1174          END DO 
    1175       ENDIF 
    1176       ! 
    1177       !                           ! Migrations 
    1178       imigr = jprecj * jpi * jpk * 2 
    1179       ! 
    1180       SELECT CASE ( nbondj ) 
    1181       CASE ( -1 ) 
    1182          CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req1 ) 
    1183          CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono ) 
    1184          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1185       CASE ( 0 ) 
    1186          CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
    1187          CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req2 ) 
    1188          CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono ) 
    1189          CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso ) 
    1190          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1191          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    1192       CASE ( 1 ) 
    1193          CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
    1194          CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso ) 
    1195          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1196       END SELECT 
    1197       ! 
    1198       !                           ! Write Dirichlet lateral conditions 
    1199       ijhom = nlcj - jprecj 
    1200       ! 
    1201       SELECT CASE ( nbondj ) 
    1202       CASE ( -1 ) 
    1203          DO jl = 1, jprecj 
    1204             ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2) 
    1205             ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2) 
    1206          END DO 
    1207       CASE ( 0 ) 
    1208          DO jl = 1, jprecj 
    1209             ptab1(:,jl      ,:) = zt4sn(:,jl,:,1,2) 
    1210             ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2) 
    1211             ptab2(:,jl      ,:) = zt4sn(:,jl,:,2,2) 
    1212             ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2) 
    1213          END DO 
    1214       CASE ( 1 ) 
    1215          DO jl = 1, jprecj 
    1216             ptab1(:,jl,:) = zt4sn(:,jl,:,1,2) 
    1217             ptab2(:,jl,:) = zt4sn(:,jl,:,2,2) 
    1218          END DO 
    1219       END SELECT 
    1220  
    1221  
    1222       ! 4. north fold treatment 
    1223       ! ----------------------- 
    1224       IF( npolj /= 0 ) THEN 
    1225          ! 
    1226          SELECT CASE ( jpni ) 
    1227          CASE ( 1 ) 
    1228             CALL lbc_nfd      ( ptab1, cd_type1, psgn )   ! only for northern procs. 
    1229             CALL lbc_nfd      ( ptab2, cd_type2, psgn ) 
    1230          CASE DEFAULT 
    1231             CALL mpp_lbc_north( ptab1, cd_type1, psgn )   ! for all northern procs. 
    1232             CALL mpp_lbc_north (ptab2, cd_type2, psgn) 
    1233          END SELECT 
    1234          ! 
    1235       ENDIF 
    1236       ! 
    1237       DEALLOCATE( zt4ns, zt4sn, zt4ew, zt4we ) 
    1238       ! 
    1239    END SUBROUTINE mpp_lnk_3d_gather 
    1240  
    1241  
    1242    SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj ) 
    1243       !!---------------------------------------------------------------------- 
    1244       !!                  ***  routine mpp_lnk_2d_e  *** 
    1245       !! 
    1246       !! ** Purpose :   Message passing manadgement for 2d array (with halo) 
    1247       !! 
    1248       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1249       !!      between processors following neighboring subdomains. 
    1250       !!            domain parameters 
    1251       !!                    nlci   : first dimension of the local subdomain 
    1252       !!                    nlcj   : second dimension of the local subdomain 
    1253       !!                    jpri   : number of rows for extra outer halo 
    1254       !!                    jprj   : number of columns for extra outer halo 
    1255       !!                    nbondi : mark for "east-west local boundary" 
    1256       !!                    nbondj : mark for "north-south local boundary" 
    1257       !!                    noea   : number for local neighboring processors 
    1258       !!                    nowe   : number for local neighboring processors 
    1259       !!                    noso   : number for local neighboring processors 
    1260       !!                    nono   : number for local neighboring processors 
    1261       !! 
    1262       !!---------------------------------------------------------------------- 
    1263       INTEGER                                             , INTENT(in   ) ::   jpri 
    1264       INTEGER                                             , INTENT(in   ) ::   jprj 
    1265       REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    1266       CHARACTER(len=1)                                    , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
    1267       !                                                                                 ! = T , U , V , F , W and I points 
    1268       REAL(wp)                                            , INTENT(in   ) ::   psgn     ! =-1 the sign change across the 
    1269       !!                                                                                ! north boundary, =  1. otherwise 
    1270       INTEGER  ::   jl   ! dummy loop indices 
    1271       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    1272       INTEGER  ::   ipreci, iprecj             ! temporary integers 
    1273       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1274       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    1275       !! 
    1276       REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns 
    1277       REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn 
    1278       REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe 
    1279       REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew 
    1280       !!---------------------------------------------------------------------- 
    1281  
    1282       ipreci = jpreci + jpri      ! take into account outer extra 2D overlap area 
    1283       iprecj = jprecj + jprj 
    1284  
    1285  
    1286       ! 1. standard boundary treatment 
    1287       ! ------------------------------ 
    1288       ! Order matters Here !!!! 
    1289       ! 
    1290                                            ! North-South cyclic 
    1291       IF ( nbondj == 2 .AND. jperio == 7 )    THEN !* cyclic north south 
    1292          pt2d(:, 1-jprj:  1     ) = pt2d ( :, jpjm1-jprj:jpjm1) 
    1293          pt2d(:, jpj   :jpj+jprj) = pt2d ( :, 2         :2+jprj) 
    1294       ELSE 
    1295          
    1296       !                                      !* North-South boundaries (closed) 
    1297       IF( .NOT. cd_type == 'F' )   pt2d(:,  1-jprj   :  jprecj  ) = 0.e0    ! south except at F-point 
    1298                                    pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0.e0    ! north 
    1299       ENDIF 
    1300                                  
    1301       !                                      ! East-West boundaries 
    1302       !                                           !* Cyclic east-west 
    1303       IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    1304          pt2d(1-jpri:     1    ,:) = pt2d(jpim1-jpri:  jpim1 ,:)       ! east 
    1305          pt2d(   jpi  :jpi+jpri,:) = pt2d(     2      :2+jpri,:)       ! west 
    1306          ! 
    1307       ELSE                                        !* closed 
    1308          IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0.e0    ! south except at F-point 
    1309                                       pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0    ! north 
    1310       ENDIF 
    1311       ! 
    1312  
    1313       ! north fold treatment 
    1314       ! ----------------------- 
    1315       IF( npolj /= 0 ) THEN 
    1316          ! 
    1317          SELECT CASE ( jpni ) 
    1318          CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 
    1319          CASE DEFAULT   ;   CALL mpp_lbc_north_e( pt2d                    , cd_type, psgn               ) 
    1320          END SELECT 
    1321          ! 
    1322       ENDIF 
    1323  
    1324       ! 2. East and west directions exchange 
    1325       ! ------------------------------------ 
    1326       ! we play with the neigbours AND the row number because of the periodicity 
    1327       ! 
    1328       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    1329       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1330          iihom = nlci-nreci-jpri 
    1331          DO jl = 1, ipreci 
    1332             r2dew(:,jl,1) = pt2d(jpreci+jl,:) 
    1333             r2dwe(:,jl,1) = pt2d(iihom +jl,:) 
    1334          END DO 
    1335       END SELECT 
    1336       ! 
    1337       !                           ! Migrations 
    1338       imigr = ipreci * ( jpj + 2*jprj) 
    1339       ! 
    1340       SELECT CASE ( nbondi ) 
    1341       CASE ( -1 ) 
    1342          CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 ) 
    1343          CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) 
    1344          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1345       CASE ( 0 ) 
    1346          CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) 
    1347          CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 ) 
    1348          CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) 
    1349          CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) 
    1350          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1351          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1352       CASE ( 1 ) 
    1353          CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) 
    1354          CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) 
    1355          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1356       END SELECT 
    1357       ! 
    1358       !                           ! Write Dirichlet lateral conditions 
    1359       iihom = nlci - jpreci 
    1360       ! 
    1361       SELECT CASE ( nbondi ) 
    1362       CASE ( -1 ) 
    1363          DO jl = 1, ipreci 
    1364             pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    1365          END DO 
    1366       CASE ( 0 ) 
    1367          DO jl = 1, ipreci 
    1368             pt2d(jl-jpri,:) = r2dwe(:,jl,2) 
    1369             pt2d( iihom+jl,:) = r2dew(:,jl,2) 
    1370          END DO 
    1371       CASE ( 1 ) 
    1372          DO jl = 1, ipreci 
    1373             pt2d(jl-jpri,:) = r2dwe(:,jl,2) 
    1374          END DO 
    1375       END SELECT 
    1376  
    1377  
    1378       ! 3. North and south directions 
    1379       ! ----------------------------- 
    1380       ! always closed : we play only with the neigbours 
    1381       ! 
    1382       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    1383          ijhom = nlcj-nrecj-jprj 
    1384          DO jl = 1, iprecj 
    1385             r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 
    1386             r2dns(:,jl,1) = pt2d(:,jprecj+jl) 
    1387          END DO 
    1388       ENDIF 
    1389       ! 
    1390       !                           ! Migrations 
    1391       imigr = iprecj * ( jpi + 2*jpri ) 
    1392       ! 
    1393       SELECT CASE ( nbondj ) 
    1394       CASE ( -1 ) 
    1395          CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 ) 
    1396          CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) 
    1397          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1398       CASE ( 0 ) 
    1399          CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) 
    1400          CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 ) 
    1401          CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) 
    1402          CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) 
    1403          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1404          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1405       CASE ( 1 ) 
    1406          CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) 
    1407          CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) 
    1408          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1409       END SELECT 
    1410       ! 
    1411       !                           ! Write Dirichlet lateral conditions 
    1412       ijhom = nlcj - jprecj 
    1413       ! 
    1414       SELECT CASE ( nbondj ) 
    1415       CASE ( -1 ) 
    1416          DO jl = 1, iprecj 
    1417             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    1418          END DO 
    1419       CASE ( 0 ) 
    1420          DO jl = 1, iprecj 
    1421             pt2d(:,jl-jprj) = r2dsn(:,jl,2) 
    1422             pt2d(:,ijhom+jl ) = r2dns(:,jl,2) 
    1423          END DO 
    1424       CASE ( 1 ) 
    1425          DO jl = 1, iprecj 
    1426             pt2d(:,jl-jprj) = r2dsn(:,jl,2) 
    1427          END DO 
    1428       END SELECT 
    1429       ! 
    1430    END SUBROUTINE mpp_lnk_2d_e 
    1431  
    1432    SUBROUTINE mpp_lnk_sum_3d( ptab, cd_type, psgn, cd_mpp, pval ) 
    1433       !!---------------------------------------------------------------------- 
    1434       !!                  ***  routine mpp_lnk_sum_3d  *** 
    1435       !! 
    1436       !! ** Purpose :   Message passing manadgement (sum the overlap region) 
    1437       !! 
    1438       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1439       !!      between processors following neighboring subdomains. 
    1440       !!            domain parameters 
    1441       !!                    nlci   : first dimension of the local subdomain 
    1442       !!                    nlcj   : second dimension of the local subdomain 
    1443       !!                    nbondi : mark for "east-west local boundary" 
    1444       !!                    nbondj : mark for "north-south local boundary" 
    1445       !!                    noea   : number for local neighboring processors 
    1446       !!                    nowe   : number for local neighboring processors 
    1447       !!                    noso   : number for local neighboring processors 
    1448       !!                    nono   : number for local neighboring processors 
    1449       !! 
    1450       !! ** Action  :   ptab with update value at its periphery 
    1451       !! 
    1452       !!---------------------------------------------------------------------- 
    1453       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
    1454       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
    1455       !                                                             ! = T , U , V , F , W points 
    1456       REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    1457       !                                                             ! =  1. , the sign is kept 
    1458       CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    1459       REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    1460       !! 
    1461       INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
    1462       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    1463       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1464       REAL(wp) ::   zland 
    1465       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    1466       ! 
    1467       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north 
    1468       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east 
    1469  
    1470       !!---------------------------------------------------------------------- 
    1471        
    1472       ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   & 
    1473          &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  ) 
    1474  
    1475       ! 
    1476       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    1477       ELSE                         ;   zland = 0.e0      ! zero by default 
    1478       ENDIF 
    1479  
    1480       ! 1. standard boundary treatment 
    1481       ! ------------------------------ 
    1482       ! 2. East and west directions exchange 
    1483       ! ------------------------------------ 
    1484       ! we play with the neigbours AND the row number because of the periodicity 
    1485       ! 
    1486       SELECT CASE ( nbondi )      ! Read lateral conditions 
    1487       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1488       iihom = nlci-jpreci 
    1489          DO jl = 1, jpreci 
    1490             zt3ew(:,jl,:,1) = ptab(jl      ,:,:) ; ptab(jl      ,:,:) = 0.0_wp 
    1491             zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0.0_wp  
    1492          END DO 
    1493       END SELECT 
    1494       ! 
    1495       !                           ! Migrations 
    1496       imigr = jpreci * jpj * jpk 
    1497       ! 
    1498       SELECT CASE ( nbondi ) 
    1499       CASE ( -1 ) 
    1500          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 
    1501          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    1502          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1503       CASE ( 0 ) 
    1504          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    1505          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 
    1506          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    1507          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    1508          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1509          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    1510       CASE ( 1 ) 
    1511          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    1512          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    1513          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1514       END SELECT 
    1515       ! 
    1516       !                           ! Write lateral conditions 
    1517       iihom = nlci-nreci 
    1518       ! 
    1519       SELECT CASE ( nbondi ) 
    1520       CASE ( -1 ) 
    1521          DO jl = 1, jpreci 
    1522             ptab(iihom+jl,:,:) = ptab(iihom+jl,:,:) + zt3ew(:,jl,:,2) 
    1523          END DO 
    1524       CASE ( 0 ) 
    1525          DO jl = 1, jpreci 
    1526             ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) 
    1527             ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2) 
    1528          END DO 
    1529       CASE ( 1 ) 
    1530          DO jl = 1, jpreci 
    1531             ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) 
    1532          END DO 
    1533       END SELECT 
    1534  
    1535  
    1536       ! 3. North and south directions 
    1537       ! ----------------------------- 
    1538       ! always closed : we play only with the neigbours 
    1539       ! 
    1540       IF( nbondj /= 2 ) THEN      ! Read lateral conditions 
    1541          ijhom = nlcj-jprecj 
    1542          DO jl = 1, jprecj 
    1543             zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:) ; ptab(:,ijhom+jl,:) = 0.0_wp 
    1544             zt3ns(:,jl,:,1) = ptab(:,jl      ,:) ; ptab(:,jl      ,:) = 0.0_wp 
    1545          END DO 
    1546       ENDIF 
    1547       ! 
    1548       !                           ! Migrations 
    1549       imigr = jprecj * jpi * jpk 
    1550       ! 
    1551       SELECT CASE ( nbondj ) 
    1552       CASE ( -1 ) 
    1553          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 
    1554          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    1555          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1556       CASE ( 0 ) 
    1557          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    1558          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 
    1559          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    1560          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    1561          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1562          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    1563       CASE ( 1 ) 
    1564          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    1565          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    1566          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1567       END SELECT 
    1568       ! 
    1569       !                           ! Write lateral conditions 
    1570       ijhom = nlcj-nrecj 
    1571       ! 
    1572       SELECT CASE ( nbondj ) 
    1573       CASE ( -1 ) 
    1574          DO jl = 1, jprecj 
    1575             ptab(:,ijhom+jl,:) = ptab(:,ijhom+jl,:) + zt3ns(:,jl,:,2) 
    1576          END DO 
    1577       CASE ( 0 ) 
    1578          DO jl = 1, jprecj 
    1579             ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl,:,2) 
    1580             ptab(:,ijhom +jl,:) = ptab(:,ijhom +jl,:) + zt3ns(:,jl,:,2) 
    1581          END DO 
    1582       CASE ( 1 ) 
    1583          DO jl = 1, jprecj 
    1584             ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl   ,:,2) 
    1585          END DO 
    1586       END SELECT 
    1587  
    1588  
    1589       ! 4. north fold treatment 
    1590       ! ----------------------- 
    1591       ! 
    1592       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    1593          ! 
    1594          SELECT CASE ( jpni ) 
    1595          CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
    1596          CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
    1597          END SELECT 
    1598          ! 
    1599       ENDIF 
    1600       ! 
    1601       DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) 
    1602       ! 
    1603    END SUBROUTINE mpp_lnk_sum_3d 
    1604  
    1605    SUBROUTINE mpp_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    1606       !!---------------------------------------------------------------------- 
    1607       !!                  ***  routine mpp_lnk_sum_2d  *** 
    1608       !! 
    1609       !! ** Purpose :   Message passing manadgement for 2d array (sum the overlap region) 
    1610       !! 
    1611       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1612       !!      between processors following neighboring subdomains. 
    1613       !!            domain parameters 
    1614       !!                    nlci   : first dimension of the local subdomain 
    1615       !!                    nlcj   : second dimension of the local subdomain 
    1616       !!                    nbondi : mark for "east-west local boundary" 
    1617       !!                    nbondj : mark for "north-south local boundary" 
    1618       !!                    noea   : number for local neighboring processors 
    1619       !!                    nowe   : number for local neighboring processors 
    1620       !!                    noso   : number for local neighboring processors 
    1621       !!                    nono   : number for local neighboring processors 
    1622       !! 
    1623       !!---------------------------------------------------------------------- 
    1624       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied 
    1625       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
    1626       !                                                         ! = T , U , V , F , W and I points 
    1627       REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    1628       !                                                         ! =  1. , the sign is kept 
    1629       CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    1630       REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    1631       !! 
    1632       INTEGER  ::   ji, jj, jl   ! dummy loop indices 
    1633       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    1634       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1635       REAL(wp) ::   zland 
    1636       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    1637       ! 
    1638       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
    1639       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
    1640  
    1641       !!---------------------------------------------------------------------- 
    1642  
    1643       ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  & 
    1644          &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   ) 
    1645  
    1646       ! 
    1647       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    1648       ELSE                         ;   zland = 0.e0      ! zero by default 
    1649       ENDIF 
    1650  
    1651       ! 1. standard boundary treatment 
    1652       ! ------------------------------ 
    1653       ! 2. East and west directions exchange 
    1654       ! ------------------------------------ 
    1655       ! we play with the neigbours AND the row number because of the periodicity 
    1656       ! 
    1657       SELECT CASE ( nbondi )      ! Read lateral conditions 
    1658       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1659          iihom = nlci - jpreci 
    1660          DO jl = 1, jpreci 
    1661             zt2ew(:,jl,1) = pt2d(jl       ,:) ; pt2d(jl       ,:) = 0.0_wp 
    1662             zt2we(:,jl,1) = pt2d(iihom +jl,:) ; pt2d(iihom +jl,:) = 0.0_wp 
    1663          END DO 
    1664       END SELECT 
    1665       ! 
    1666       !                           ! Migrations 
    1667       imigr = jpreci * jpj 
    1668       ! 
    1669       SELECT CASE ( nbondi ) 
    1670       CASE ( -1 ) 
    1671          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 
    1672          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    1673          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1674       CASE ( 0 ) 
    1675          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    1676          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 
    1677          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    1678          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    1679          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1680          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1681       CASE ( 1 ) 
    1682          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    1683          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    1684          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1685       END SELECT 
    1686       ! 
    1687       !                           ! Write lateral conditions 
    1688       iihom = nlci-nreci 
    1689       ! 
    1690       SELECT CASE ( nbondi ) 
    1691       CASE ( -1 ) 
    1692          DO jl = 1, jpreci 
    1693             pt2d(iihom+jl,:) = pt2d(iihom+jl,:) + zt2ew(:,jl,2) 
    1694          END DO 
    1695       CASE ( 0 ) 
    1696          DO jl = 1, jpreci 
    1697             pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) 
    1698             pt2d(iihom +jl,:) = pt2d(iihom +jl,:) + zt2ew(:,jl,2) 
    1699          END DO 
    1700       CASE ( 1 ) 
    1701          DO jl = 1, jpreci 
    1702             pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) 
    1703          END DO 
    1704       END SELECT 
    1705  
    1706  
    1707       ! 3. North and south directions 
    1708       ! ----------------------------- 
    1709       ! always closed : we play only with the neigbours 
    1710       ! 
    1711       IF( nbondj /= 2 ) THEN      ! Read lateral conditions 
    1712          ijhom = nlcj - jprecj 
    1713          DO jl = 1, jprecj 
    1714             zt2sn(:,jl,1) = pt2d(:,ijhom +jl) ; pt2d(:,ijhom +jl) = 0.0_wp 
    1715             zt2ns(:,jl,1) = pt2d(:,jl       ) ; pt2d(:,jl       ) = 0.0_wp 
    1716          END DO 
    1717       ENDIF 
    1718       ! 
    1719       !                           ! Migrations 
    1720       imigr = jprecj * jpi 
    1721       ! 
    1722       SELECT CASE ( nbondj ) 
    1723       CASE ( -1 ) 
    1724          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 
    1725          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    1726          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1727       CASE ( 0 ) 
    1728          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    1729          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 
    1730          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    1731          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    1732          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1733          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1734       CASE ( 1 ) 
    1735          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    1736          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    1737          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1738       END SELECT 
    1739       ! 
    1740       !                           ! Write lateral conditions 
    1741       ijhom = nlcj-nrecj 
    1742       ! 
    1743       SELECT CASE ( nbondj ) 
    1744       CASE ( -1 ) 
    1745          DO jl = 1, jprecj 
    1746             pt2d(:,ijhom+jl) = pt2d(:,ijhom+jl) + zt2ns(:,jl,2) 
    1747          END DO 
    1748       CASE ( 0 ) 
    1749          DO jl = 1, jprecj 
    1750             pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) 
    1751             pt2d(:,ijhom +jl) = pt2d(:,ijhom +jl) + zt2ns(:,jl,2) 
    1752          END DO 
    1753       CASE ( 1 ) 
    1754          DO jl = 1, jprecj 
    1755             pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) 
    1756          END DO 
    1757       END SELECT 
    1758  
    1759  
    1760       ! 4. north fold treatment 
    1761       ! ----------------------- 
    1762       ! 
    1763       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    1764          ! 
    1765          SELECT CASE ( jpni ) 
    1766          CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp 
    1767          CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs. 
    1768          END SELECT 
    1769          ! 
    1770       ENDIF 
    1771       ! 
    1772       DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
    1773       ! 
    1774    END SUBROUTINE mpp_lnk_sum_2d 
     470   !!    mpp_lnk_sum_2d et 3D   ====>>>>>>   à virer du code !!!! 
     471    
     472    
     473   !!---------------------------------------------------------------------- 
     474 
     475 
    1775476 
    1776477   SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req ) 
    … …  
    1874575   END SUBROUTINE mppscatter 
    1875576 
    1876  
     577   !!---------------------------------------------------------------------- 
     578   !!    ***  mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real  *** 
     579   !!    
     580   !!---------------------------------------------------------------------- 
     581   !! 
    1877582   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       !! 
    1883583      !!---------------------------------------------------------------------- 
    1884584      INTEGER , INTENT(in   )                  ::   kdim   ! size of array 
    1885585      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab   ! input array 
    1886586      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom   ! 
    1887       ! 
    1888       INTEGER :: ierror, localcomm   ! temporary integer 
     587      INTEGER :: ierror, ilocalcomm   ! temporary integer 
    1889588      INTEGER, DIMENSION(kdim) ::   iwork 
    1890589      !!---------------------------------------------------------------------- 
    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       ! 
     590      ilocalcomm = mpi_comm_opa 
     591      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     592      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, ilocalcomm, ierror ) 
    1897593      ktab(:) = iwork(:) 
    1898       ! 
    1899594   END SUBROUTINE mppmax_a_int 
    1900  
    1901  
     595   !! 
    1902596   SUBROUTINE mppmax_int( ktab, kcom ) 
    1903       !!---------------------------------------------------------------------- 
    1904       !!                  ***  routine mppmax_int  *** 
    1905       !! 
    1906       !! ** Purpose :   Find maximum value in an integer layout array 
    1907       !! 
    1908597      !!---------------------------------------------------------------------- 
    1909598      INTEGER, INTENT(inout)           ::   ktab   ! ??? 
    1910599      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       ! 
     600      INTEGER ::   ierror, iwork, ilocalcomm   ! temporary integer 
     601      !!---------------------------------------------------------------------- 
     602      ilocalcomm = mpi_comm_opa 
     603      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     604      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, ilocalcomm, ierror ) 
    1920605      ktab = iwork 
    1921       ! 
    1922606   END SUBROUTINE mppmax_int 
    1923  
    1924  
     607   !! 
     608   SUBROUTINE mppmax_a_real( ptab, kdim, kcom ) 
     609      !!---------------------------------------------------------------------- 
     610      REAL(wp), DIMENSION(kdim), INTENT(inout) ::   ptab 
     611      INTEGER                  , INTENT(in   ) ::   kdim 
     612      INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom 
     613      INTEGER :: ierror, ilocalcomm 
     614      REAL(wp), DIMENSION(kdim) ::  zwork 
     615      !!---------------------------------------------------------------------- 
     616      ilocalcomm = mpi_comm_opa 
     617      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     618      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 
     619      ptab(:) = zwork(:) 
     620   END SUBROUTINE mppmax_a_real 
     621   !! 
     622   SUBROUTINE mppmax_real( ptab, kcom ) 
     623      !!---------------------------------------------------------------------- 
     624      REAL(wp), INTENT(inout)           ::   ptab   ! ??? 
     625      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
     626      INTEGER  ::   ierror, ilocalcomm 
     627      REAL(wp) ::   zwork 
     628      !!---------------------------------------------------------------------- 
     629      ilocalcomm = mpi_comm_opa 
     630      IF( PRESENT(kcom) )   ilocalcomm = kcom! 
     631      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 
     632      ptab = zwork 
     633   END SUBROUTINE mppmax_real 
     634 
     635 
     636   !!---------------------------------------------------------------------- 
     637   !!    ***  mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real  *** 
     638   !!    
     639   !!---------------------------------------------------------------------- 
     640   !! 
    1925641   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       !! 
    1931642      !!---------------------------------------------------------------------- 
    1932643      INTEGER , INTENT( in  )                  ::   kdim   ! size of array 
    … …  
    1934645      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom   ! input array 
    1935646      !! 
    1936       INTEGER ::   ierror, localcomm   ! temporary integer 
     647      INTEGER ::   ierror, ilocalcomm   ! temporary integer 
    1937648      INTEGER, DIMENSION(kdim) ::   iwork 
    1938649      !!---------------------------------------------------------------------- 
    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       ! 
     650      ilocalcomm = mpi_comm_opa 
     651      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     652      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, ilocalcomm, ierror ) 
    1945653      ktab(:) = iwork(:) 
    1946       ! 
    1947654   END SUBROUTINE mppmin_a_int 
    1948  
    1949  
     655   !! 
    1950656   SUBROUTINE mppmin_int( ktab, kcom ) 
    1951       !!---------------------------------------------------------------------- 
    1952       !!                  ***  routine mppmin_int  *** 
    1953       !! 
    1954       !! ** Purpose :   Find minimum value in an integer layout array 
    1955       !! 
    1956657      !!---------------------------------------------------------------------- 
    1957658      INTEGER, INTENT(inout) ::   ktab      ! ??? 
    1958659      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array 
    1959660      !! 
    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       ! 
     661      INTEGER ::  ierror, iwork, ilocalcomm 
     662      !!---------------------------------------------------------------------- 
     663      ilocalcomm = mpi_comm_opa 
     664      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     665      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, ilocalcomm, ierror ) 
    1968666      ktab = iwork 
    1969       ! 
    1970667   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       !! 
     668   !! 
     669   SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
    2019670      !!---------------------------------------------------------------------- 
    2020671      INTEGER , INTENT(in   )                  ::   kdim 
    2021672      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab 
    2022673      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 
     674      INTEGER :: ierror, ilocalcomm 
    2097675      REAL(wp), DIMENSION(kdim) ::   zwork 
    2098676      !!----------------------------------------------------------------------- 
    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 ) 
     677      ilocalcomm = mpi_comm_opa 
     678      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     679      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, ilocalcomm, ierror ) 
    2104680      ptab(:) = zwork(:) 
    2105       ! 
    2106681   END SUBROUTINE mppmin_a_real 
    2107  
    2108  
     682   !! 
    2109683   SUBROUTINE mppmin_real( ptab, kcom ) 
    2110       !!---------------------------------------------------------------------- 
    2111       !!                  ***  routine mppmin_real  *** 
    2112       !! 
    2113       !! ** Purpose :   minimum of REAL, scalar case 
    2114       !! 
    2115684      !!----------------------------------------------------------------------- 
    2116685      REAL(wp), INTENT(inout)           ::   ptab        ! 
    2117686      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 
     687      INTEGER  ::   ierror, ilocalcomm 
    2169688      REAL(wp) ::   zwork 
    2170689      !!----------------------------------------------------------------------- 
    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 ) 
     690      ilocalcomm = mpi_comm_opa 
     691      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     692      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, ilocalcomm, ierror ) 
    2176693      ptab = zwork 
    2177       ! 
     694   END SUBROUTINE mppmin_real 
     695 
     696 
     697   !!---------------------------------------------------------------------- 
     698   !!    ***  mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real  *** 
     699   !!    
     700   !!   Global sum of 1D array or a variable (integer, real or complex) 
     701   !!---------------------------------------------------------------------- 
     702   !! 
     703   SUBROUTINE mppsum_a_int( ktab, kdim ) 
     704      !!---------------------------------------------------------------------- 
     705      INTEGER, INTENT(in   )                   ::   kdim   ! ??? 
     706      INTEGER, INTENT(inout), DIMENSION (kdim) ::   ktab   ! ??? 
     707      INTEGER :: ierror 
     708      INTEGER, DIMENSION (kdim) ::  iwork 
     709      !!---------------------------------------------------------------------- 
     710      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 
     711      ktab(:) = iwork(:) 
     712   END SUBROUTINE mppsum_a_int 
     713   !! 
     714   SUBROUTINE mppsum_int( ktab ) 
     715      !!---------------------------------------------------------------------- 
     716      INTEGER, INTENT(inout) ::   ktab 
     717      INTEGER :: ierror, iwork 
     718      !!---------------------------------------------------------------------- 
     719      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 
     720      ktab = iwork 
     721   END SUBROUTINE mppsum_int 
     722   !! 
     723   SUBROUTINE mppsum_a_real( ptab, kdim, kcom ) 
     724      !!----------------------------------------------------------------------- 
     725      INTEGER                  , INTENT(in   ) ::   kdim   ! size of ptab 
     726      REAL(wp), DIMENSION(kdim), INTENT(inout) ::   ptab   ! input array 
     727      INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom   ! specific communicator 
     728      INTEGER  ::   ierror, ilocalcomm    ! local integer 
     729      REAL(wp) ::   zwork(kdim)           ! local workspace 
     730      !!----------------------------------------------------------------------- 
     731      ilocalcomm = mpi_comm_opa 
     732      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     733      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, ilocalcomm, ierror ) 
     734      ptab(:) = zwork(:) 
     735   END SUBROUTINE mppsum_a_real 
     736   !! 
     737   SUBROUTINE mppsum_real( ptab, kcom ) 
     738      !!----------------------------------------------------------------------- 
     739      REAL(wp)          , INTENT(inout)           ::   ptab   ! input scalar 
     740      INTEGER , OPTIONAL, INTENT(in   ) ::   kcom 
     741      INTEGER  ::   ierror, ilocalcomm 
     742      REAL(wp) ::   zwork 
     743      !!----------------------------------------------------------------------- 
     744      ilocalcomm = mpi_comm_opa 
     745      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     746      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, ilocalcomm, ierror ) 
     747      ptab = zwork 
    2178748   END SUBROUTINE mppsum_real 
    2179  
    2180  
     749   !! 
    2181750   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       !! 
    2188751      !!----------------------------------------------------------------------- 
    2189       COMPLEX(wp), INTENT(inout)           ::   ytab    ! input scalar 
    2190       INTEGER    , INTENT(in   ), OPTIONAL ::   kcom 
    2191       ! 
    2192       INTEGER     ::   ierror 
    2193       INTEGER     ::   localcomm 
     752      COMPLEX(wp)          , INTENT(inout) ::   ytab    ! input scalar 
     753      INTEGER    , OPTIONAL, INTENT(in   ) ::   kcom 
     754      INTEGER     ::   ierror, ilocalcomm 
    2194755      COMPLEX(wp) ::   zwork 
    2195756      !!----------------------------------------------------------------------- 
    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 ) 
     757      ilocalcomm = mpi_comm_opa 
     758      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     759      CALL MPI_ALLREDUCE( ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, ilocalcomm, ierror ) 
    2202760      ytab = zwork 
    2203       ! 
    2204761   END SUBROUTINE mppsum_realdd 
    2205  
    2206  
     762   !! 
    2207763   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom ) 
    2208764      !!---------------------------------------------------------------------- 
    2209       !!                  ***  routine mppsum_a_realdd  *** 
    2210       !! 
    2211       !! ** Purpose :   global sum in Massively Parallel Processing 
    2212       !!                COMPLEX ARRAY case for double-double precision 
    2213       !! 
    2214       !!----------------------------------------------------------------------- 
    2215765      INTEGER                     , INTENT(in   ) ::   kdim   ! size of ytab 
    2216766      COMPLEX(wp), DIMENSION(kdim), INTENT(inout) ::   ytab   ! input array 
    2217767      INTEGER    , OPTIONAL       , INTENT(in   ) ::   kcom 
    2218       ! 
    2219       INTEGER:: ierror, localcomm    ! local integer 
     768      INTEGER:: ierror, ilocalcomm    ! local integer 
    2220769      COMPLEX(wp), DIMENSION(kdim) :: zwork     ! temporary workspace 
    2221770      !!----------------------------------------------------------------------- 
    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 ) 
     771      ilocalcomm = mpi_comm_opa 
     772      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     773      CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, ilocalcomm, ierror ) 
    2227774      ytab(:) = zwork(:) 
    2228       ! 
    2229775   END SUBROUTINE mppsum_a_realdd 
     776    
     777 
     778   SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom  ) 
     779      !!---------------------------------------------------------------------- 
     780      !!                  ***  routine mppmax_real  *** 
     781      !! 
     782      !! ** Purpose :   Maximum across processor of each element of a 1D arrays 
     783      !! 
     784      !!---------------------------------------------------------------------- 
     785      REAL(wp), DIMENSION(kdim), INTENT(inout) ::   pt1d   ! 1D arrays 
     786      INTEGER                  , INTENT(in   ) ::   kdim 
     787      INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom   ! local communicator 
     788      !! 
     789      INTEGER  ::   ierror, ilocalcomm 
     790      REAL(wp), DIMENSION(kdim) ::  zwork 
     791      !!---------------------------------------------------------------------- 
     792      ilocalcomm = mpi_comm_opa 
     793      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     794      ! 
     795      CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 
     796      pt1d(:) = zwork(:) 
     797      ! 
     798   END SUBROUTINE mppmax_real_multiple 
    2230799 
    2231800 
    … …  
    2243812      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask   ! Local mask 
    2244813      REAL(wp)                     , INTENT(  out) ::   pmin    ! Global minimum of ptab 
    2245       INTEGER                      , INTENT(  out) ::   ki, kj   ! index of minimum in global frame 
     814      INTEGER                      , INTENT(  out) ::   ki, kj  ! index of minimum in global frame 
    2246815      ! 
    2247816      INTEGER :: ierror 
    … …  
    2251820      !!----------------------------------------------------------------------- 
    2252821      ! 
    2253       zmin  = MINVAL( ptab(:,:) , mask= pmask == 1.e0 ) 
    2254       ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 ) 
     822      zmin  = MINVAL( ptab(:,:) , mask= pmask == 1._wp ) 
     823      ilocs = MINLOC( ptab(:,:) , mask= pmask == 1._wp ) 
    2255824      ! 
    2256825      ki = ilocs(1) + nimpp - 1 
    … …  
    2279848      !! 
    2280849      !!-------------------------------------------------------------------------- 
    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       !! 
     850      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   ptab         ! Local 2D array 
     851      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pmask        ! Local mask 
     852      REAL(wp)                  , INTENT(  out) ::   pmin         ! Global minimum of ptab 
     853      INTEGER                   , INTENT(  out) ::   ki, kj, kk   ! index of minimum in global frame 
     854      ! 
    2286855      INTEGER  ::   ierror 
    2287856      REAL(wp) ::   zmin     ! local minimum 
    … …  
    2290859      !!----------------------------------------------------------------------- 
    2291860      ! 
    2292       zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 ) 
    2293       ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 ) 
     861      zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1._wp ) 
     862      ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1._wp ) 
    2294863      ! 
    2295864      ki = ilocs(1) + nimpp - 1 
    … …  
    2297866      kk = ilocs(3) 
    2298867      ! 
    2299       zain(1,:)=zmin 
    2300       zain(2,:)=ki+10000.*kj+100000000.*kk 
     868      zain(1,:) = zmin 
     869      zain(2,:) = ki + 10000.*kj + 100000000.*kk 
    2301870      ! 
    2302871      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror) 
    … …  
    2331900      !!----------------------------------------------------------------------- 
    2332901      ! 
    2333       zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 ) 
    2334       ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 ) 
     902      zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1._wp ) 
     903      ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1._wp ) 
    2335904      ! 
    2336905      ki = ilocs(1) + nimpp - 1 
    … …  
    2359928      !! 
    2360929      !!-------------------------------------------------------------------------- 
    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 
     930      REAL(wp), DIMENSION (:,:,:), INTENT(in   ) ::   ptab         ! Local 2D array 
     931      REAL(wp), DIMENSION (:,:,:), INTENT(in   ) ::   pmask        ! Local mask 
     932      REAL(wp)                   , INTENT(  out) ::   pmax         ! Global maximum of ptab 
     933      INTEGER                    , INTENT(  out) ::   ki, kj, kk   ! index of maximum in global frame 
     934      ! 
     935      INTEGER  ::   ierror   ! local integer 
     936      REAL(wp) ::   zmax     ! local maximum 
    2367937      REAL(wp), DIMENSION(2,1) ::   zain, zaout 
    2368938      INTEGER , DIMENSION(3)   ::   ilocs 
    2369       INTEGER :: ierror 
    2370939      !!----------------------------------------------------------------------- 
    2371940      ! 
    2372       zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 ) 
    2373       ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 ) 
     941      zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1._wp ) 
     942      ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1._wp ) 
    2374943      ! 
    2375944      ki = ilocs(1) + nimpp - 1 
    … …  
    2377946      kk = ilocs(3) 
    2378947      ! 
    2379       zain(1,:)=zmax 
    2380       zain(2,:)=ki+10000.*kj+100000000.*kk 
     948      zain(1,:) = zmax 
     949      zain(2,:) = ki + 10000.*kj + 100000000.*kk 
    2381950      ! 
    2382951      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror) 
    … …  
    2422991 
    2423992   SUBROUTINE mpp_comm_free( kcom ) 
    2424       !!---------------------------------------------------------------------- 
    2425993      !!---------------------------------------------------------------------- 
    2426994      INTEGER, INTENT(in) ::   kcom 
    … …  
    26801248 
    26811249 
    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  
    3140    SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 
    3141       !!--------------------------------------------------------------------- 
    3142       !!                   ***  routine mpp_lbc_north_2d  *** 
    3143       !! 
    3144       !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    3145       !!              in mpp configuration in case of jpn1 > 1 and for 2d 
    3146       !!              array with outer extra halo 
    3147       !! 
    3148       !! ** Method  :   North fold condition and mpp with more than one proc 
    3149       !!              in i-direction require a specific treatment. We gather 
    3150       !!              the 4+2*jpr2dj northern lines of the global domain on 1 
    3151       !!              processor and apply lbc north-fold on this sub array. 
    3152       !!              Then we scatter the north fold array back to the processors. 
    3153       !! 
    3154       !!---------------------------------------------------------------------- 
    3155       REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    3156       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 
    3160       INTEGER ::   ji, jj, jr 
    3161       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    3162       INTEGER ::   ijpj, ij, iproc 
    3163       ! 
    3164       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
    3165       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e 
    3166  
    3167       !!---------------------------------------------------------------------- 
    3168       ! 
    3169       ALLOCATE( ztab_e(jpiglo,4+2*jpr2dj), znorthloc_e(jpi,4+2*jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) ) 
    3170  
    3171       ! 
    3172       ijpj=4 
    3173       ztab_e(:,:) = 0.e0 
    3174  
    3175       ij=0 
    3176       ! put in znorthloc_e the last 4 jlines of pt2d 
    3177       DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj 
    3178          ij = ij + 1 
    3179          DO ji = 1, jpi 
    3180             znorthloc_e(ji,ij)=pt2d(ji,jj) 
    3181          END DO 
    3182       END DO 
    3183       ! 
    3184       itaille = jpi * ( ijpj + 2 * jpr2dj ) 
    3185       CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    & 
    3186          &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    3187       ! 
    3188       DO jr = 1, ndim_rank_north            ! recover the global north array 
    3189          iproc = nrank_north(jr) + 1 
    3190          ildi = nldit (iproc) 
    3191          ilei = nleit (iproc) 
    3192          iilb = nimppt(iproc) 
    3193          DO jj = 1, ijpj+2*jpr2dj 
    3194             DO ji = ildi, ilei 
    3195                ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 
    3196             END DO 
    3197          END DO 
    3198       END DO 
    3199  
    3200  
    3201       ! 2. North-Fold boundary conditions 
    3202       ! ---------------------------------- 
    3203       CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj ) 
    3204  
    3205       ij = jpr2dj 
    3206       !! Scatter back to pt2d 
    3207       DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj 
    3208       ij  = ij +1 
    3209          DO ji= 1, nlci 
    3210             pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 
    3211          END DO 
    3212       END DO 
    3213       ! 
    3214       DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 
    3215       ! 
    3216    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 
    3647  
    3648  
    36491250   SUBROUTINE mpi_init_opa( ldtxt, ksft, code ) 
    36501251      !!--------------------------------------------------------------------- 
    … …  
    37061307   END SUBROUTINE mpi_init_opa 
    37071308 
    3708    SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype) 
     1309 
     1310   SUBROUTINE DDPDD_MPI( ydda, yddb, ilen, itype ) 
    37091311      !!--------------------------------------------------------------------- 
    37101312      !!   Routine DDPDD_MPI: used by reduction operator MPI_SUMDD 
    … …  
    37131315      !!   This subroutine computes yddb(i) = ydda(i)+yddb(i) 
    37141316      !!--------------------------------------------------------------------- 
    3715       INTEGER, INTENT(in)                         :: ilen, itype 
    3716       COMPLEX(wp), DIMENSION(ilen), INTENT(in)     :: ydda 
    3717       COMPLEX(wp), DIMENSION(ilen), INTENT(inout)  :: yddb 
     1317      INTEGER                     , INTENT(in)    ::  ilen, itype 
     1318      COMPLEX(wp), DIMENSION(ilen), INTENT(in)    ::  ydda 
     1319      COMPLEX(wp), DIMENSION(ilen), INTENT(inout) ::  yddb 
    37181320      ! 
    37191321      REAL(wp) :: zerr, zt1, zt2    ! local work variables 
    3720       INTEGER :: ji, ztmp           ! local scalar 
    3721  
     1322      INTEGER  :: ji, ztmp           ! local scalar 
     1323      !!--------------------------------------------------------------------- 
     1324      ! 
    37221325      ztmp = itype   ! avoid compilation warning 
    3723  
     1326      ! 
    37241327      DO ji=1,ilen 
    37251328      ! Compute ydda + yddb using Knuth's trick. 
    … …  
    37321335         yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp ) 
    37331336      END DO 
    3734  
     1337      ! 
    37351338   END SUBROUTINE DDPDD_MPI 
    37361339 
    37371340 
    3738    SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj) 
     1341   SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 
    37391342      !!--------------------------------------------------------------------- 
    37401343      !!                   ***  routine mpp_lbc_north_icb  *** 
    … …  
    37461349      !! ** Method  :   North fold condition and mpp with more than one proc 
    37471350      !!              in i-direction require a specific treatment. We gather 
    3748       !!              the 4+2*jpr2dj northern lines of the global domain on 1 
     1351      !!              the 4+kextj northern lines of the global domain on 1 
    37491352      !!              processor and apply lbc north-fold on this sub array. 
    37501353      !!              Then we scatter the north fold array back to the processors. 
    3751       !!              This version accounts for an extra halo with icebergs. 
     1354      !!              This routine accounts for an extra halo with icebergs 
     1355      !!              and assumes ghost rows and columns have been suppressed. 
    37521356      !! 
    37531357      !!---------------------------------------------------------------------- 
    … …  
    37571361      REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
    37581362      !!                                                    ! north fold, =  1. otherwise 
    3759       INTEGER, OPTIONAL       , INTENT(in   ) ::   pr2dj 
     1363      INTEGER                 , INTENT(in   ) ::   kextj    ! Extra halo width at north fold 
    37601364      ! 
    37611365      INTEGER ::   ji, jj, jr 
    37621366      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    3763       INTEGER ::   ijpj, ij, iproc, ipr2dj 
     1367      INTEGER ::   ipj, ij, iproc 
    37641368      ! 
    37651369      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
    … …  
    37671371      !!---------------------------------------------------------------------- 
    37681372      ! 
    3769       ijpj=4 
    3770       IF( PRESENT(pr2dj) ) THEN           ! use of additional halos 
    3771          ipr2dj = pr2dj 
    3772       ELSE 
    3773          ipr2dj = 0 
    3774       ENDIF 
    3775       ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpi,4+2*ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) ) 
    3776       ! 
    3777       ztab_e(:,:) = 0._wp 
     1373      ipj=4 
     1374      ALLOCATE( ztab_e(jpiglo,ipj+kextj), znorthloc_e(  jpimax,ipj+kextj), & 
     1375     &                                    znorthgloio_e(jpimax,ipj+kextj,jpni) ) 
     1376      ! 
     1377      ztab_e(:,:)      = 0._wp 
     1378      znorthloc_e(:,:) = 0._wp 
    37781379      ! 
    37791380      ij = 0 
    3780       ! put in znorthloc_e the last 4 jlines of pt2d 
    3781       DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj 
     1381      ! put the last ipj+kextj lines of pt2d into znorthloc_e  
     1382      DO jj = jpj - ipj + 1, jpj + kextj 
    37821383         ij = ij + 1 
    3783          DO ji = 1, jpi 
    3784             znorthloc_e(ji,ij)=pt2d(ji,jj) 
    3785          END DO 
     1384         znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 
    37861385      END DO 
    37871386      ! 
    3788       itaille = jpi * ( ijpj + 2 * ipr2dj ) 
     1387      itaille = jpimax * ( ipj + kextj ) 
    37891388      CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    & 
    37901389         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    … …  
    37951394         ilei = nleit (iproc) 
    37961395         iilb = nimppt(iproc) 
    3797          DO jj = 1, ijpj+2*ipr2dj 
     1396         DO jj = 1, ipj+kextj 
    37981397            DO ji = ildi, ilei 
    37991398               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 
    … …  
    38021401      END DO 
    38031402 
    3804  
    38051403      ! 2. North-Fold boundary conditions 
    38061404      ! ---------------------------------- 
    3807       CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj ) 
    3808  
    3809       ij = ipr2dj 
     1405      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, kextj ) 
     1406 
     1407      ij = 0 
    38101408      !! Scatter back to pt2d 
    3811       DO jj = nlcj - ijpj + 1 , nlcj +ipr2dj 
     1409      DO jj = jpj - ipj + 1 , jpj + kextj 
    38121410      ij  = ij +1 
    3813          DO ji= 1, nlci 
     1411         DO ji= 1, jpi 
    38141412            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 
    38151413         END DO 
    … …  
    38211419 
    38221420 
    3823    SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj ) 
     1421   SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, kexti, kextj ) 
    38241422      !!---------------------------------------------------------------------- 
    38251423      !!                  ***  routine mpp_lnk_2d_icb  *** 
    38261424      !! 
    3827       !! ** Purpose :   Message passing manadgement for 2d array (with extra halo and icebergs) 
     1425      !! ** Purpose :   Message passing management for 2d array (with extra halo for icebergs) 
     1426      !!                This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) 
     1427      !!                array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. 
    38281428      !! 
    38291429      !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    38301430      !!      between processors following neighboring subdomains. 
    38311431      !!            domain parameters 
    3832       !!                    nlci   : first dimension of the local subdomain 
    3833       !!                    nlcj   : second dimension of the local subdomain 
    3834       !!                    jpri   : number of rows for extra outer halo 
    3835       !!                    jprj   : number of columns for extra outer halo 
     1432      !!                    jpi    : first dimension of the local subdomain 
     1433      !!                    jpj    : second dimension of the local subdomain 
     1434      !!                    kexti  : number of columns for extra outer halo 
     1435      !!                    kextj  : number of rows for extra outer halo 
    38361436      !!                    nbondi : mark for "east-west local boundary" 
    38371437      !!                    nbondj : mark for "north-south local boundary" 
    … …  
    38411441      !!                    nono   : number for local neighboring processors 
    38421442      !!---------------------------------------------------------------------- 
    3843       INTEGER                                             , INTENT(in   ) ::   jpri 
    3844       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 
     1443      REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
     1444      CHARACTER(len=1)                                        , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
     1445      REAL(wp)                                                , INTENT(in   ) ::   psgn     ! sign used across the north fold 
     1446      INTEGER                                                 , INTENT(in   ) ::   kexti    ! extra i-halo width 
     1447      INTEGER                                                 , INTENT(in   ) ::   kextj    ! extra j-halo width 
     1448      ! 
    38501449      INTEGER  ::   jl   ! dummy loop indices 
    3851       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    3852       INTEGER  ::   ipreci, iprecj             ! temporary integers 
     1450      INTEGER  ::   imigr, iihom, ijhom        ! local integers 
     1451      INTEGER  ::   ipreci, iprecj             !   -       - 
    38531452      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    38541453      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    38551454      !! 
    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 
    3860       !!---------------------------------------------------------------------- 
    3861  
    3862       ipreci = jpreci + jpri      ! take into account outer extra 2D overlap area 
    3863       iprecj = jprecj + jprj 
     1455      REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) ::   r2dns, r2dsn 
     1456      REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) ::   r2dwe, r2dew 
     1457      !!---------------------------------------------------------------------- 
     1458 
     1459      ipreci = nn_hls + kexti      ! take into account outer extra 2D overlap area 
     1460      iprecj = nn_hls + kextj 
    38641461 
    38651462 
    … …  
    38711468      !                                           !* Cyclic east-west 
    38721469      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    3873          pt2d(1-jpri:     1    ,:) = pt2d(jpim1-jpri:  jpim1 ,:)       ! east 
    3874          pt2d(   jpi  :jpi+jpri,:) = pt2d(     2      :2+jpri,:)       ! west 
     1470         pt2d(1-kexti:     1    ,:) = pt2d(jpim1-kexti:  jpim1 ,:)       ! east 
     1471         pt2d(   jpi  :jpi+kexti,:) = pt2d(     2      :2+kexti,:)       ! west 
    38751472         ! 
    38761473      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 
     1474         IF( .NOT. cd_type == 'F' )   pt2d(  1-kexti   :nn_hls    ,:) = 0._wp    ! south except at F-point 
     1475                                      pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp    ! north 
    38791476      ENDIF 
    38801477      ! 
    … …  
    38851482         ! 
    38861483         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 ) 
     1484                   CASE ( 1 )     ;   CALL lbc_nfd          ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
     1485                   CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
    38891486         END SELECT 
    38901487         ! 
    … …  
    38971494      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    38981495      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    3899          iihom = nlci-nreci-jpri 
     1496         iihom = jpi-nreci-kexti 
    39001497         DO jl = 1, ipreci 
    3901             r2dew(:,jl,1) = pt2d(jpreci+jl,:) 
     1498            r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 
    39021499            r2dwe(:,jl,1) = pt2d(iihom +jl,:) 
    39031500         END DO 
    … …  
    39051502      ! 
    39061503      !                           ! Migrations 
    3907       imigr = ipreci * ( jpj + 2*jprj) 
     1504      imigr = ipreci * ( jpj + 2*kextj ) 
    39081505      ! 
    39091506      SELECT CASE ( nbondi ) 
    39101507      CASE ( -1 ) 
    3911          CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 ) 
    3912          CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) 
     1508         CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 
     1509         CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
    39131510         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    39141511      CASE ( 0 ) 
    3915          CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) 
    3916          CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 ) 
    3917          CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) 
    3918          CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) 
     1512         CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
     1513         CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 
     1514         CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
     1515         CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    39191516         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    39201517         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    39211518      CASE ( 1 ) 
    3922          CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) 
    3923          CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) 
     1519         CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
     1520         CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    39241521         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    39251522      END SELECT 
    39261523      ! 
    39271524      !                           ! Write Dirichlet lateral conditions 
    3928       iihom = nlci - jpreci 
     1525      iihom = jpi - nn_hls 
    39291526      ! 
    39301527      SELECT CASE ( nbondi ) 
    … …  
    39351532      CASE ( 0 ) 
    39361533         DO jl = 1, ipreci 
    3937             pt2d(jl-jpri,:) = r2dwe(:,jl,2) 
    3938             pt2d( iihom+jl,:) = r2dew(:,jl,2) 
     1534            pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
     1535            pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    39391536         END DO 
    39401537      CASE ( 1 ) 
    39411538         DO jl = 1, ipreci 
    3942             pt2d(jl-jpri,:) = r2dwe(:,jl,2) 
     1539            pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
    39431540         END DO 
    39441541      END SELECT 
    … …  
    39501547      ! 
    39511548      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    3952          ijhom = nlcj-nrecj-jprj 
     1549         ijhom = jpj-nrecj-kextj 
    39531550         DO jl = 1, iprecj 
    39541551            r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 
    3955             r2dns(:,jl,1) = pt2d(:,jprecj+jl) 
     1552            r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 
    39561553         END DO 
    39571554      ENDIF 
    39581555      ! 
    39591556      !                           ! Migrations 
    3960       imigr = iprecj * ( jpi + 2*jpri ) 
     1557      imigr = iprecj * ( jpi + 2*kexti ) 
    39611558      ! 
    39621559      SELECT CASE ( nbondj ) 
    39631560      CASE ( -1 ) 
    3964          CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 ) 
    3965          CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) 
     1561         CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 
     1562         CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
    39661563         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    39671564      CASE ( 0 ) 
    3968          CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) 
    3969          CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 ) 
    3970          CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) 
    3971          CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) 
     1565         CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
     1566         CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 
     1567         CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
     1568         CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    39721569         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    39731570         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    39741571      CASE ( 1 ) 
    3975          CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) 
    3976          CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) 
     1572         CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
     1573         CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    39771574         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    39781575      END SELECT 
    39791576      ! 
    39801577      !                           ! Write Dirichlet lateral conditions 
    3981       ijhom = nlcj - jprecj 
     1578      ijhom = jpj - nn_hls 
    39821579      ! 
    39831580      SELECT CASE ( nbondj ) 
    … …  
    39881585      CASE ( 0 ) 
    39891586         DO jl = 1, iprecj 
    3990             pt2d(:,jl-jprj) = r2dsn(:,jl,2) 
    3991             pt2d(:,ijhom+jl ) = r2dns(:,jl,2) 
     1587            pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
     1588            pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    39921589         END DO 
    39931590      CASE ( 1 ) 
    39941591         DO jl = 1, iprecj 
    3995             pt2d(:,jl-jprj) = r2dsn(:,jl,2) 
     1592            pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
    39961593         END DO 
    39971594      END SELECT 
    3998  
     1595      ! 
    39991596   END SUBROUTINE mpp_lnk_2d_icb 
    40001597    
    … …  
    40201617      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
    40211618   END INTERFACE 
     1619   INTERFACE mpp_max_multiple 
     1620      MODULE PROCEDURE mppmax_real_multiple 
     1621   END INTERFACE 
    40221622 
    40231623   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag 
    … …  
    41911791      WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom 
    41921792   END SUBROUTINE mpp_comm_free 
     1793    
     1794   SUBROUTINE mppmax_real_multiple( ptab, kdim , kcom  ) 
     1795      REAL, DIMENSION(:) ::   ptab   !  
     1796      INTEGER            ::   kdim   !  
     1797      INTEGER, OPTIONAL  ::   kcom   !  
     1798      WRITE(*,*) 'mppmax_real_multiple: You should not have seen this print! error?', ptab(1), kdim 
     1799   END SUBROUTINE mppmax_real_multiple 
     1800 
    41931801#endif 
    41941802 
    … …  
    42251833                               CALL FLUSH(numout    ) 
    42261834      IF( numstp     /= -1 )   CALL FLUSH(numstp    ) 
    4227       IF( numsol     /= -1 )   CALL FLUSH(numsol    ) 
     1835      IF( numrun     /= -1 )   CALL FLUSH(numrun    ) 
    42281836      IF( numevo_ice /= -1 )   CALL FLUSH(numevo_ice) 
    42291837      ! 
    … …  
    43321940            WRITE(kout,*) 
    43331941         ENDIF 
    4334          CALL FLUSH(kout)  
     1942         CALL FLUSH( kout )  
    43351943         STOP 'ctl_opn bad opening' 
    43361944      ENDIF 
Note: See TracChangeset for help on using the changeset viewer.