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

Ignore:
Timestamp:
2017-04-11T15:10:20+02:00 (7 years ago)
Author:
gm
Message:

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

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/2017/dev_r7832_HPC08_lbclnk_3rd_dim/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r7753 r7897  
    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 
     
    2424   !!            3.5  !  2013  ( C. Ethe, G. Madec ) message passing arrays as local variables  
    2525   !!            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'  
     26   !!            3.6  !  2015  (O. Tintó and M. Castrillo - BSC) Added '_multiple' case for 2D lbc and max 
     27   !!            4.0  !  2017  (G. Madec) automatique allocation of array argument (use any 3rd dimension) 
    2728   !!---------------------------------------------------------------------- 
    2829 
     
    4546   !!   mpp_lnk_icb   : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 
    4647   !!   mpprecv       : 
    47    !!   mppsend       :   SUBROUTINE mpp_ini_znl 
     48   !!   mppsend       : 
    4849   !!   mppscatter    : 
    4950   !!   mppgather     : 
     
    8586 
    8687   TYPE arrayptr 
    87       REAL , DIMENSION (:,:),  POINTER :: pt2d 
     88      REAL(wp), DIMENSION (:,:),  POINTER ::  pt2d 
    8889   END TYPE arrayptr 
     90   ! 
    8991   PUBLIC   arrayptr 
    9092    
     
    101103   INTERFACE mpp_sum 
    102104      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real,   & 
    103                        mppsum_realdd, mppsum_a_realdd 
     105         &             mppsum_realdd, mppsum_a_realdd 
    104106   END INTERFACE 
    105107   INTERFACE mpp_lbc_north 
     
    112114      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
    113115   END INTERFACE 
    114  
    115116   INTERFACE mpp_max_multiple 
    116117      MODULE PROCEDURE mppmax_real_multiple 
     
    138139   ! variables used in case of sea-ice 
    139140   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 
     141   INTEGER         ::   ngrp_iworld     !  group ID for the world processors (for rheology) 
     142   INTEGER         ::   ngrp_ice        !  group ID for the ice processors (for rheology) 
     143   INTEGER         ::   ndim_rank_ice   !  number of 'ice' processors 
     144   INTEGER         ::   n_ice_root      !  number (in the comm_ice) of proc 0 in the ice comm 
    144145   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_ice     ! dimension ndim_rank_ice 
    145146 
    146147   ! variables used for zonal integration 
    147148   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 
     149   LOGICAL, PUBLIC ::   l_znl_root      !  True on the 'left'most processor on the same row 
     150   INTEGER         ::   ngrp_znl        ! group ID for the znl processors 
     151   INTEGER         ::   ndim_rank_znl   ! number of processors on the same zonal average 
    151152   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_znl  ! dimension ndim_rank_znl, number of the procs into the same znl domain 
    152153 
    153154   ! 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 
     155   INTEGER, PUBLIC ::   ngrp_world        !: group ID for the world processors 
     156   INTEGER, PUBLIC ::   ngrp_opa          !: group ID for the opa processors 
     157   INTEGER, PUBLIC ::   ngrp_north        !: group ID for the northern processors (to be fold) 
     158   INTEGER, PUBLIC ::   ncomm_north       !: communicator made by the processors belonging to ngrp_north 
     159   INTEGER, PUBLIC ::   ndim_rank_north   !: number of 'sea' processor in the northern line (can be /= jpni !) 
     160   INTEGER, PUBLIC ::   njmppmax          !: value of njmpp for the processors of the northern line 
     161   INTEGER, PUBLIC ::   north_root        !: number (in the comm_opa) of proc 0 in the northern comm 
     162   INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_north   !: dimension ndim_rank_north 
    162163 
    163164   ! 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 
     165   CHARACTER(len=1), PUBLIC ::   cn_mpi_send         !: type od mpi send/recieve (S=standard, B=bsend, I=isend) 
     166   LOGICAL         , PUBLIC ::   l_isend = .FALSE.   !: isend use indicator (T if cn_mpi_send='I') 
     167   INTEGER         , PUBLIC ::   nn_buffer           !: size of the buffer in case of mpi_bsend 
     168 
     169   REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::   tampon   ! buffer in case of bsend 
     170 
     171   LOGICAL, PUBLIC ::   ln_nnogather                !: namelist control of northfold comms 
     172   LOGICAL, PUBLIC ::   l_north_nogather = .FALSE.  !: internal control of northfold comms 
     173 
    173174   !!---------------------------------------------------------------------- 
    174    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     175   !! NEMO/OPA 4.0 , NEMO Consortium (2017) 
    175176   !! $Id$ 
    176177   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     
    178179CONTAINS 
    179180 
    180  
    181    FUNCTION mynode( ldtxt, ldname, kumnam_ref , kumnam_cfg , kumond , kstop, localComm ) 
     181   FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm ) 
    182182      !!---------------------------------------------------------------------- 
    183183      !!                  ***  routine mynode  *** 
     
    204204      WRITE(ldtxt(ii),*) '~~~~~~ '                                                        ;   ii = ii + 1 
    205205      ! 
    206  
    207206      REWIND( kumnam_ref )              ! Namelist nammpp in reference namelist: mpi variables 
    208207      READ  ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901) 
    209208901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp ) 
    210  
     209      ! 
    211210      REWIND( kumnam_cfg )              ! Namelist nammpp in configuration namelist: mpi variables 
    212211      READ  ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 
    213212902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp ) 
    214  
     213      ! 
    215214      !                              ! control print 
    216215      WRITE(ldtxt(ii),*) '   Namelist nammpp'                                             ;   ii = ii + 1 
    217216      WRITE(ldtxt(ii),*) '      mpi send type          cn_mpi_send = ', cn_mpi_send       ;   ii = ii + 1 
    218217      WRITE(ldtxt(ii),*) '      size exported buffer   nn_buffer   = ', nn_buffer,' bytes';   ii = ii + 1 
    219  
     218      ! 
    220219#if defined key_agrif 
    221220      IF( .NOT. Agrif_Root() ) THEN 
     
    225224      ENDIF 
    226225#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 
     226      ! 
     227      IF( jpnij < 1 ) THEN         ! If jpnij is not specified in namelist then we calculate it 
     228         jpnij = jpni * jpnj       ! this means there will be no land cutting out. 
     229      ENDIF 
     230 
     231      IF( jpni < 1 .OR. jpnj < 1  ) THEN 
    235232         WRITE(ldtxt(ii),*) '      jpni, jpnj and jpnij will be calculated automatically' ;   ii = ii + 1 
    236233      ELSE 
     
    238235         WRITE(ldtxt(ii),*) '      processor grid extent in j         jpnj = ',jpnj       ;   ii = ii + 1 
    239236         WRITE(ldtxt(ii),*) '      number of local domains           jpnij = ',jpnij      ;   ii = ii + 1 
    240       END IF 
     237      ENDIF 
    241238 
    242239      WRITE(ldtxt(ii),*) '      avoid use of mpi_allgather at the north fold  ln_nnogather = ', ln_nnogather  ; ii = ii + 1 
     
    268265            kstop = kstop + 1 
    269266         END SELECT 
    270       ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN 
     267         ! 
     268      ELSE IF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN 
    271269         WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator '          ;   ii = ii + 1 
    272270         WRITE(ldtxt(ii),*) '          without calling MPI_Init before ! '                ;   ii = ii + 1 
     
    309307 
    310308#if defined key_agrif 
    311       IF (Agrif_Root()) THEN 
     309      IF( Agrif_Root() ) THEN 
    312310         CALL Agrif_MPI_Init(mpi_comm_opa) 
    313311      ELSE 
     
    335333      !! 
    336334      !! ** Purpose :   Message passing manadgement 
     335      !! 
     336      !! ** Method  :   Use mppsend and mpprecv function for passing mask 
     337      !!              between processors following neighboring subdomains. 
     338      !!            domain parameters 
     339      !!                    nlci   : first dimension of the local subdomain 
     340      !!                    nlcj   : second dimension of the local subdomain 
     341      !!                    nbondi : mark for "east-west local boundary" 
     342      !!                    nbondj : mark for "north-south local boundary" 
     343      !!                    noea   : number for local neighboring processors 
     344      !!                    nowe   : number for local neighboring processors 
     345      !!                    noso   : number for local neighboring processors 
     346      !!                    nono   : number for local neighboring processors 
     347      !! 
     348      !! ** Action  :   ptab with update value at its periphery 
     349      !!---------------------------------------------------------------------- 
     350      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
     351      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
     352      REAL(wp)                  , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
     353      CHARACTER(len=3), OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     354      REAL(wp)        , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     355      ! 
     356      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
     357      INTEGER  ::   ipk                        ! 3rd dimension of the input array 
     358      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
     359      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     360      REAL(wp) ::   zland 
     361      INTEGER , DIMENSION(MPI_STATUS_SIZE)      ::   ml_stat        ! for key_mpi_isend 
     362      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north 
     363      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east 
     364      !!---------------------------------------------------------------------- 
     365      ! 
     366      ipk = SIZE( ptab, 3 ) 
     367      ! 
     368      ALLOCATE( zt3ns(jpi,jprecj,ipk,2), zt3sn(jpi,jprecj,ipk,2),   & 
     369         &      zt3ew(jpj,jpreci,ipk,2), zt3we(jpj,jpreci,ipk,2)  ) 
     370 
     371      ! 
     372      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
     373      ELSE                         ;   zland = 0._wp     ! zero by default 
     374      ENDIF 
     375 
     376      ! 1. standard boundary treatment 
     377      ! ------------------------------ 
     378      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
     379         ! 
     380         ! WARNING ptab is defined only between nld and nle 
     381         DO jk = 1, ipk 
     382            DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
     383               ptab(nldi  :nlei  , jj          ,jk) = ptab(nldi:nlei,     nlej,jk) 
     384               ptab(1     :nldi-1, jj          ,jk) = ptab(nldi     ,     nlej,jk) 
     385               ptab(nlei+1:nlci  , jj          ,jk) = ptab(     nlei,     nlej,jk) 
     386            END DO 
     387            DO ji = nlci+1, jpi                 ! added column(s) (full) 
     388               ptab(ji           ,nldj  :nlej  ,jk) = ptab(     nlei,nldj:nlej,jk) 
     389               ptab(ji           ,1     :nldj-1,jk) = ptab(     nlei,nldj     ,jk) 
     390               ptab(ji           ,nlej+1:jpj   ,jk) = ptab(     nlei,     nlej,jk) 
     391            END DO 
     392         END DO 
     393         ! 
     394      ELSE                              ! standard close or cyclic treatment 
     395         ! 
     396         !                                   ! East-West boundaries 
     397         !                                        !* Cyclic 
     398         IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
     399            ptab( 1 ,:,:) = ptab(jpim1,:,:) 
     400            ptab(jpi,:,:) = ptab(  2  ,:,:) 
     401         ELSE                                     !* closed 
     402            IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
     403                                         ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
     404         ENDIF 
     405         !                                   ! North-South boundaries 
     406         !                                        !* cyclic (only with no mpp j-split) 
     407         IF( nbondj == 2 .AND. jperio == 7 ) THEN  
     408            ptab(:,1 , :) = ptab(:, jpjm1,:) 
     409            ptab(:,jpj,:) = ptab(:,     2,:) 
     410         ELSE                                     !* closed 
     411            IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point 
     412                                         ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north 
     413         ENDIF 
     414         ! 
     415      ENDIF 
     416 
     417      ! 2. East and west directions exchange 
     418      ! ------------------------------------ 
     419      ! we play with the neigbours AND the row number because of the periodicity 
     420      ! 
     421      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
     422      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     423         iihom = nlci-nreci 
     424         DO jl = 1, jpreci 
     425            zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 
     426            zt3we(:,jl,:,1) = ptab(iihom +jl,:,:) 
     427         END DO 
     428      END SELECT 
     429      ! 
     430      !                           ! Migrations 
     431      imigr = jpreci * jpj * ipk 
     432      ! 
     433      SELECT CASE ( nbondi ) 
     434      CASE ( -1 ) 
     435         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 
     436         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
     437         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     438      CASE ( 0 ) 
     439         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
     440         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 
     441         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
     442         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
     443         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     444         IF(l_isend)   CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     445      CASE ( 1 ) 
     446         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
     447         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
     448         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     449      END SELECT 
     450      ! 
     451      !                           ! Write Dirichlet lateral conditions 
     452      iihom = nlci-jpreci 
     453      ! 
     454      SELECT CASE ( nbondi ) 
     455      CASE ( -1 ) 
     456         DO jl = 1, jpreci 
     457            ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 
     458         END DO 
     459      CASE ( 0 ) 
     460         DO jl = 1, jpreci 
     461            ptab(jl      ,:,:) = zt3we(:,jl,:,2) 
     462            ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 
     463         END DO 
     464      CASE ( 1 ) 
     465         DO jl = 1, jpreci 
     466            ptab(jl      ,:,:) = zt3we(:,jl,:,2) 
     467         END DO 
     468      END SELECT 
     469 
     470      ! 3. North and south directions 
     471      ! ----------------------------- 
     472      ! always closed : we play only with the neigbours 
     473      ! 
     474      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     475         ijhom = nlcj-nrecj 
     476         DO jl = 1, jprecj 
     477            zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 
     478            zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 
     479         END DO 
     480      ENDIF 
     481      ! 
     482      !                           ! Migrations 
     483      imigr = jprecj * jpi * ipk 
     484      ! 
     485      SELECT CASE ( nbondj ) 
     486      CASE ( -1 ) 
     487         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 
     488         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
     489         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     490      CASE ( 0 ) 
     491         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
     492         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 
     493         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
     494         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
     495         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     496         IF(l_isend)   CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     497      CASE ( 1 ) 
     498         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
     499         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
     500         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
     501      END SELECT 
     502      ! 
     503      !                           ! Write Dirichlet lateral conditions 
     504      ijhom = nlcj-jprecj 
     505      ! 
     506      SELECT CASE ( nbondj ) 
     507      CASE ( -1 ) 
     508         DO jl = 1, jprecj 
     509            ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 
     510         END DO 
     511      CASE ( 0 ) 
     512         DO jl = 1, jprecj 
     513            ptab(:,jl      ,:) = zt3sn(:,jl,:,2) 
     514            ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 
     515         END DO 
     516      CASE ( 1 ) 
     517         DO jl = 1, jprecj 
     518            ptab(:,jl,:) = zt3sn(:,jl,:,2) 
     519         END DO 
     520      END SELECT 
     521 
     522      ! 4. north fold treatment 
     523      ! ----------------------- 
     524      ! 
     525      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     526         ! 
     527         SELECT CASE ( jpni ) 
     528         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
     529         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
     530         END SELECT 
     531         ! 
     532      ENDIF 
     533      ! 
     534      DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) 
     535      ! 
     536   END SUBROUTINE mpp_lnk_3d 
     537 
     538 
     539   SUBROUTINE mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, kfld, cd_mpp, pval ) 
     540      !!---------------------------------------------------------------------- 
     541      !!                  ***  routine mpp_lnk_2d_multiple  *** 
     542      !! 
     543      !! ** Purpose :   Message passing management for multiple 2d arrays 
    337544      !! 
    338545      !! ** Method  :   Use mppsend and mpprecv function for passing mask 
     
    347554      !!                    noso   : number for local neighboring processors 
    348555      !!                    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 
     556      !!---------------------------------------------------------------------- 
     557      TYPE( arrayptr ), DIMENSION(:), INTENT(inout) ::   pt2d_array   ! pointer array of 2D fields  
     558      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! nature of pt2d_array grid-points 
     559      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! sign used across the north fold boundary 
     560      INTEGER                       , INTENT(in   ) ::   kfld         ! number of pt2d arrays 
     561      CHARACTER(len=3), OPTIONAL    , INTENT(in   ) ::   cd_mpp       ! fill the overlap area only 
     562      REAL(wp)        , OPTIONAL    , INTENT(in   ) ::   pval         ! background value (used at closed boundaries) 
     563      ! 
     564      INTEGER  ::   ji, jj, jl, jf   ! dummy loop indices 
    362565      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    363566      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    364567      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  
     568      INTEGER , DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat       ! for key_mpi_isend 
     569      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
     570      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
     571      !!---------------------------------------------------------------------- 
     572      ! 
     573      ALLOCATE( zt2ns(jpi,jprecj,2*kfld), zt2sn(jpi,jprecj,2*kfld),  & 
     574         &      zt2ew(jpj,jpreci,2*kfld), zt2we(jpj,jpreci,2*kfld)   ) 
    373575      ! 
    374576      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
     
    378580      ! 1. standard boundary treatment 
    379581      ! ------------------------------ 
    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 
     582      ! 
     583      !First Array 
     584      DO jf = 1 , kfld 
     585         IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
     586            ! 
     587            ! WARNING pt2d is defined only between nld and nle 
    384588            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) 
     589               pt2d_array(jf)%pt2d(nldi  :nlei  , jj) = pt2d_array(jf)%pt2d(nldi:nlei, nlej) 
     590               pt2d_array(jf)%pt2d(1     :nldi-1, jj) = pt2d_array(jf)%pt2d(nldi     , nlej) 
     591               pt2d_array(jf)%pt2d(nlei+1:nlci  , jj) = pt2d_array(jf)%pt2d(     nlei, nlej)  
    388592            END DO 
    389593            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) 
     594               pt2d_array(jf)%pt2d(ji, nldj  :nlej  ) = pt2d_array(jf)%pt2d(nlei, nldj:nlej) 
     595               pt2d_array(jf)%pt2d(ji, 1     :nldj-1) = pt2d_array(jf)%pt2d(nlei, nldj     ) 
     596               pt2d_array(jf)%pt2d(ji, nlej+1:jpj   ) = pt2d_array(jf)%pt2d(nlei,      nlej) 
    393597            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 
     598            ! 
     599         ELSE                              ! standard close or cyclic treatment 
     600            ! 
     601            !                                   ! East-West boundaries 
     602            IF( nbondi == 2 .AND.   &                !* Cyclic 
     603               &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
     604               pt2d_array(jf)%pt2d(  1  , : ) = pt2d_array(jf)%pt2d( jpim1, : )                             ! west 
     605               pt2d_array(jf)%pt2d( jpi , : ) = pt2d_array(jf)%pt2d(   2  , : )                             ! east 
     606            ELSE                                     !* Closed 
     607               IF( .NOT. type_array(jf) == 'F' )   pt2d_array(jf)%pt2d(            1 : jpreci,:) = zland    ! south except F-point 
     608                                                   pt2d_array(jf)%pt2d(nlci-jpreci+1 : jpi   ,:) = zland    ! north 
     609            ENDIF 
     610            !                                   ! North-South boundaries 
     611            !                                        !* Cyclic 
     612            IF( nbondj == 2 .AND. jperio == 7 ) THEN 
     613               pt2d_array(jf)%pt2d(:,  1  ) =   pt2d_array(jf)%pt2d(:, jpjm1 ) 
     614               pt2d_array(jf)%pt2d(:, jpj ) =   pt2d_array(jf)%pt2d(:,   2   )           
     615            ELSE                                     !* Closed              
     616               IF( .NOT. type_array(jf) == 'F' )   pt2d_array(jf)%pt2d(:,             1:jprecj ) = zland    ! south except F-point 
     617                                                   pt2d_array(jf)%pt2d(:, nlcj-jprecj+1:jpj    ) = zland    ! north 
     618            ENDIF 
    406619         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 
     620      END DO 
    417621 
    418622      ! 2. East and west directions exchange 
     
    420624      ! we play with the neigbours AND the row number because of the periodicity 
    421625      ! 
    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 
     626      DO jf = 1 , kfld 
     627         SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
     628         CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     629            iihom = nlci-nreci 
     630            DO jl = 1, jpreci 
     631               zt2ew( : , jl , jf ) = pt2d_array(jf)%pt2d( jpreci+jl , : ) 
     632               zt2we( : , jl , jf ) = pt2d_array(jf)%pt2d( iihom +jl , : ) 
     633            END DO 
     634         END SELECT 
     635      END DO 
    430636      ! 
    431637      !                           ! Migrations 
    432       imigr = jpreci * jpj * jpk 
     638      imigr = jpreci * jpj 
    433639      ! 
    434640      SELECT CASE ( nbondi ) 
    435641      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) 
     642         CALL mppsend( 2, zt2we(1,1,1), kfld*imigr, noea, ml_req1 ) 
     643         CALL mpprecv( 1, zt2ew(1,1,kfld+1), kfld*imigr, noea ) 
     644         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     645      CASE ( 0 ) 
     646         CALL mppsend( 1, zt2ew(1,1,1), kfld*imigr, nowe, ml_req1 ) 
     647         CALL mppsend( 2, zt2we(1,1,1), kfld*imigr, noea, ml_req2 ) 
     648         CALL mpprecv( 1, zt2ew(1,1,kfld+1), kfld*imigr, noea ) 
     649         CALL mpprecv( 2, zt2we(1,1,kfld+1), kfld*imigr, nowe ) 
     650         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     651         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
     652      CASE ( 1 ) 
     653         CALL mppsend( 1, zt2ew(1,1,1), kfld*imigr, nowe, ml_req1 ) 
     654         CALL mpprecv( 2, zt2we(1,1,kfld+1), kfld*imigr, nowe ) 
     655         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    450656      END SELECT 
    451657      ! 
    452658      !                           ! 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  
     659      iihom = nlci - jpreci 
     660      ! 
     661 
     662      DO jf = 1 , kfld 
     663         SELECT CASE ( nbondi ) 
     664         CASE ( -1 ) 
     665            DO jl = 1, jpreci 
     666               pt2d_array(jf)%pt2d( iihom+jl ,:) = zt2ew(:,jl,kfld+jf) 
     667            END DO 
     668         CASE ( 0 ) 
     669            DO jl = 1, jpreci 
     670               pt2d_array(jf)%pt2d(       jl ,:) = zt2we(:,jl,kfld+jf) 
     671               pt2d_array(jf)%pt2d( iihom+jl ,:) = zt2ew(:,jl,kfld+jf) 
     672            END DO 
     673         CASE ( 1 ) 
     674            DO jl = 1, jpreci 
     675               pt2d_array(jf)%pt2d( jl ,:)= zt2we(:,jl,kfld+jf) 
     676            END DO 
     677         END SELECT 
     678      END DO 
     679       
    471680      ! 3. North and south directions 
    472681      ! ----------------------------- 
    473682      ! always closed : we play only with the neigbours 
    474683      ! 
    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 
     684      !First Array 
     685      DO jf = 1 , kfld 
     686         IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     687            ijhom = nlcj-nrecj 
     688            DO jl = 1, jprecj 
     689               zt2sn(:,jl,jf) = pt2d_array(jf)%pt2d(:, ijhom +jl ) 
     690               zt2ns(:,jl,jf) = pt2d_array(jf)%pt2d(:, jprecj+jl ) 
     691            END DO 
     692         ENDIF 
     693      END DO 
    482694      ! 
    483695      !                           ! Migrations 
    484       imigr = jprecj * jpi * jpk 
     696      imigr = jprecj * jpi 
    485697      ! 
    486698      SELECT CASE ( nbondj ) 
    487699      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) 
     700         CALL mppsend( 4, zt2sn(1,1,     1), kfld*imigr, nono, ml_req1 ) 
     701         CALL mpprecv( 3, zt2ns(1,1,kfld+1), kfld*imigr, nono ) 
     702         IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
     703      CASE ( 0 ) 
     704         CALL mppsend( 3, zt2ns(1,1,     1), kfld*imigr, noso, ml_req1 ) 
     705         CALL mppsend( 4, zt2sn(1,1,     1), kfld*imigr, nono, ml_req2 ) 
     706         CALL mpprecv( 3, zt2ns(1,1,kfld+1), kfld*imigr, nono ) 
     707         CALL mpprecv( 4, zt2sn(1,1,kfld+1), kfld*imigr, noso ) 
     708         IF(l_isend)   CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     709         IF(l_isend)   CALL mpi_wait(ml_req2,ml_stat,ml_err) 
     710      CASE ( 1 ) 
     711         CALL mppsend( 3, zt2ns(1,1,     1), kfld*imigr, noso, ml_req1 ) 
     712         CALL mpprecv( 4, zt2sn(1,1,kfld+1), kfld*imigr, noso ) 
     713         IF(l_isend)   CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    502714      END SELECT 
    503715      ! 
    504716      !                           ! 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  
     717      ijhom = nlcj - jprecj 
     718      ! 
     719      DO jf = 1 , kfld 
     720         SELECT CASE ( nbondj ) 
     721         CASE ( -1 ) 
     722            DO jl = 1, jprecj 
     723               pt2d_array(jf)%pt2d(:, ijhom+jl ) = zt2ns(:,jl, kfld+jf ) 
     724            END DO 
     725         CASE ( 0 ) 
     726            DO jl = 1, jprecj 
     727               pt2d_array(jf)%pt2d(:,       jl ) = zt2sn(:,jl, kfld+jf ) 
     728               pt2d_array(jf)%pt2d(:, ijhom+jl ) = zt2ns(:,jl, kfld+jf ) 
     729            END DO 
     730         CASE ( 1 ) 
     731            DO jl = 1, jprecj 
     732               pt2d_array(jf)%pt2d(:,       jl ) = zt2sn(:,jl, kfld+jf ) 
     733            END DO 
     734         END SELECT 
     735      END DO 
     736       
    523737      ! 4. north fold treatment 
    524738      ! ----------------------- 
    525739      ! 
    526       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     740      IF( npolj /= 0 .AND. .NOT.PRESENT(cd_mpp) ) THEN 
    527741         ! 
    528742         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. 
     743         CASE ( 1 )   
     744            DO jf = 1, kfld   
     745               CALL lbc_nfd( pt2d_array(jf)%pt2d(:,:), type_array(jf), psgn_array(jf) )  ! only 1 northern proc, no mpp 
     746            END DO 
     747         CASE DEFAULT    
     748            CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, kfld )   ! for all northern procs. 
    531749         END SELECT 
    532750         ! 
    533751      ENDIF 
    534752      ! 
    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 
     753      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
     754      ! 
     755   END SUBROUTINE mpp_lnk_2d_multiple 
     756 
     757    
     758   SUBROUTINE load_array( pt2d, cd_type, psgn, pt2d_array, type_array, psgn_array, kfld ) 
     759      !!--------------------------------------------------------------------- 
     760      REAL(wp)        , DIMENSION(:,:), TARGET, INTENT(inout) ::   pt2d         ! 2D array on which the boundary condition is applied 
     761      CHARACTER(len=1)                        , INTENT(in   ) ::   cd_type      ! nature of ptab array grid-points 
     762      REAL(wp)                                , INTENT(in   ) ::   psgn         ! sign used across the north fold boundary 
     763      TYPE(arrayptr)  , DIMENSION(:)          , INTENT(inout) ::   pt2d_array   !  
     764      CHARACTER(len=1), DIMENSION(:)          , INTENT(inout) ::   type_array   ! nature of pt2d_array array grid-points 
     765      REAL(wp)        , DIMENSION(:)          , INTENT(inout) ::   psgn_array   ! sign used across the north fold boundary 
     766      INTEGER                                 , INTENT(inout) ::   kfld         ! 
     767      !!--------------------------------------------------------------------- 
     768      ! 
     769      kfld                  =  kfld + 1 
     770      pt2d_array(kfld)%pt2d => pt2d 
     771      type_array(kfld)      =  cd_type 
     772      psgn_array(kfld)      =  psgn 
     773      ! 
     774   END SUBROUTINE load_array 
     775    
     776    
     777   SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
     778      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
     779      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
     780      !!--------------------------------------------------------------------- 
     781      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA    ! 2D arrays on which the lbc is applied 
     782      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
     783      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI  
     784      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA ! nature of pt2D. array grid-points 
     785      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
     786      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
     787      REAL(wp)                                      , INTENT(in   ) ::   psgnA    ! sign used across the north fold 
     788      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
     789      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI    
     790      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     791      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     792      !! 
     793      INTEGER :: kfld 
     794      TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array  
     795      CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of ptab array grid-points 
     796      REAL(wp)         , DIMENSION(9) ::   psgn_array    ! sign used across the north fold boundary 
     797      !!--------------------------------------------------------------------- 
     798      ! 
     799      kfld = 0 
     800      ! 
     801      !                 ! Load the first array 
     802      CALL load_array( pt2dA, cd_typeA, psgnA, pt2d_array, type_array, psgn_array, kfld ) 
     803      ! 
     804      !                 ! Look if more arrays are added 
     805      IF( PRESENT(psgnB) )   CALL load_array( pt2dB, cd_typeB, psgnB, pt2d_array, type_array, psgn_array, kfld ) 
     806      IF( PRESENT(psgnC) )   CALL load_array( pt2dC, cd_typeC, psgnC, pt2d_array, type_array, psgn_array, kfld ) 
     807      IF( PRESENT(psgnD) )   CALL load_array( pt2dD, cd_typeD, psgnD, pt2d_array, type_array, psgn_array, kfld ) 
     808      IF( PRESENT(psgnE) )   CALL load_array( pt2dE, cd_typeE, psgnE, pt2d_array, type_array, psgn_array, kfld ) 
     809      IF( PRESENT(psgnF) )   CALL load_array( pt2dF, cd_typeF, psgnF, pt2d_array, type_array, psgn_array, kfld ) 
     810      IF( PRESENT(psgnG) )   CALL load_array( pt2dG, cd_typeG, psgnG, pt2d_array, type_array, psgn_array, kfld ) 
     811      IF( PRESENT(psgnH) )   CALL load_array( pt2dH, cd_typeH, psgnH, pt2d_array, type_array, psgn_array, kfld ) 
     812      IF( PRESENT(psgnI) )   CALL load_array( pt2dI, cd_typeI, psgnI, pt2d_array, type_array, psgn_array, kfld ) 
     813      ! 
     814      CALL mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, kfld, cd_mpp,pval ) 
     815      ! 
     816   END SUBROUTINE mpp_lnk_2d_9 
     817 
     818 
     819   SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
     820      !!---------------------------------------------------------------------- 
     821      !!                  ***  routine mpp_lnk_2d  *** 
     822      !! 
     823      !! ** Purpose :   Message passing manadgement for 2d array 
    545824      !! 
    546825      !! ** Method  :   Use mppsend and mpprecv function for passing mask 
     
    555834      !!                    noso   : number for local neighboring processors 
    556835      !!                    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) 
     836      !! 
     837      !!---------------------------------------------------------------------- 
     838      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied 
     839      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
     840      REAL(wp)                    , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
     841      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     842      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    564843      !! 
    565844      INTEGER  ::   ji, jj, jl   ! dummy loop indices 
    566       INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
    567845      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    568846      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    569       INTEGER :: num_fields 
    570       TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
    571847      REAL(wp) ::   zland 
    572       INTEGER , DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat       ! for key_mpi_isend 
     848      INTEGER, DIMENSION(MPI_STATUS_SIZE)     ::   ml_stat       ! for key_mpi_isend 
    573849      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
    574850      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)   ) 
     851      !!---------------------------------------------------------------------- 
     852      ! 
     853      ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  & 
     854         &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   ) 
    580855      ! 
    581856      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
     
    586861      ! ------------------------------ 
    587862      ! 
    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 
     863      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
     864         ! 
     865         ! WARNING pt2d is defined only between nld and nle 
     866         DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
     867            pt2d(nldi  :nlei  , jj          ) = pt2d(nldi:nlei,     nlej) 
     868            pt2d(1     :nldi-1, jj          ) = pt2d(nldi     ,     nlej) 
     869            pt2d(nlei+1:nlci  , jj          ) = pt2d(     nlei,     nlej) 
     870         END DO 
     871         DO ji = nlci+1, jpi                 ! added column(s) (full) 
     872            pt2d(ji           ,nldj  :nlej  ) = pt2d(     nlei,nldj:nlej) 
     873            pt2d(ji           ,1     :nldj-1) = pt2d(     nlei,nldj     ) 
     874            pt2d(ji           ,nlej+1:jpj   ) = pt2d(     nlei,     nlej) 
     875         END DO 
     876         ! 
     877      ELSE                              ! standard close or cyclic treatment 
     878         ! 
     879         !                                   ! East-West boundaries 
     880         IF( nbondi == 2 .AND.   &                !* cyclic 
     881            &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
     882            pt2d( 1 ,:) = pt2d(jpim1,:)                                          ! west 
     883            pt2d(jpi,:) = pt2d(  2  ,:)                                          ! east 
     884         ELSE                                     !* closed 
     885            IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point 
     886                                         pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north 
     887         ENDIF 
     888         !                                   ! North-South boundaries 
     889         !                                        !* cyclic 
     890         IF( nbondj == 2 .AND. jperio == 7 ) THEN 
     891            pt2d(:,  1 ) = pt2d(:,jpjm1) 
     892            pt2d(:, jpj) = pt2d(:,    2) 
     893         ELSE                                     !* closed 
     894            IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland    !south except F-point 
     895                                         pt2d(:,nlcj-jprecj+1:jpj   ) = zland    ! north 
     896         ENDIF 
     897      ENDIF 
    627898 
    628899      ! 2. East and west directions exchange 
     
    630901      ! we play with the neigbours AND the row number because of the periodicity 
    631902      ! 
    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 
     903      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
     904      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     905         iihom = nlci-nreci 
     906         DO jl = 1, jpreci 
     907            zt2ew(:,jl,1) = pt2d(jpreci+jl,:) 
     908            zt2we(:,jl,1) = pt2d(iihom +jl,:) 
     909         END DO 
     910      END SELECT 
    642911      ! 
    643912      !                           ! Migrations 
     
    646915      SELECT CASE ( nbondi ) 
    647916      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 ) 
     917         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 
     918         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    650919         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    651920      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 ) 
     921         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
     922         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 
     923         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
     924         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    656925         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    657926         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    658927      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 ) 
     928         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
     929         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    661930         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    662931      END SELECT 
     
    665934      iihom = nlci - jpreci 
    666935      ! 
    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        
     936      SELECT CASE ( nbondi ) 
     937      CASE ( -1 ) 
     938         DO jl = 1, jpreci 
     939            pt2d(iihom+jl,:) = zt2ew(:,jl,2) 
     940         END DO 
     941      CASE ( 0 ) 
     942         DO jl = 1, jpreci 
     943            pt2d(jl      ,:) = zt2we(:,jl,2) 
     944            pt2d(iihom+jl,:) = zt2ew(:,jl,2) 
     945         END DO 
     946      CASE ( 1 ) 
     947         DO jl = 1, jpreci 
     948            pt2d(jl      ,:) = zt2we(:,jl,2) 
     949         END DO 
     950      END SELECT 
     951 
    686952      ! 3. North and south directions 
    687953      ! ----------------------------- 
    688954      ! always closed : we play only with the neigbours 
    689955      ! 
    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 
     956      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     957         ijhom = nlcj-nrecj 
     958         DO jl = 1, jprecj 
     959            zt2sn(:,jl,1) = pt2d(:,ijhom +jl) 
     960            zt2ns(:,jl,1) = pt2d(:,jprecj+jl) 
     961         END DO 
     962      ENDIF 
    700963      ! 
    701964      !                           ! Migrations 
     
    704967      SELECT CASE ( nbondj ) 
    705968      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 ) 
     969         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 
     970         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    708971         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    709972      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 ) 
     973         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
     974         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 
     975         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
     976         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    714977         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    715978         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    716979      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 ) 
     980         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
     981         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    719982         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    720983      END SELECT 
     
    723986      ijhom = nlcj - jprecj 
    724987      ! 
    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        
     988      SELECT CASE ( nbondj ) 
     989      CASE ( -1 ) 
     990         DO jl = 1, jprecj 
     991            pt2d(:,ijhom+jl) = zt2ns(:,jl,2) 
     992         END DO 
     993      CASE ( 0 ) 
     994         DO jl = 1, jprecj 
     995            pt2d(:,jl      ) = zt2sn(:,jl,2) 
     996            pt2d(:,ijhom+jl) = zt2ns(:,jl,2) 
     997         END DO 
     998      CASE ( 1 ) 
     999         DO jl = 1, jprecj 
     1000            pt2d(:,jl      ) = zt2sn(:,jl,2) 
     1001         END DO 
     1002      END SELECT 
     1003 
    7451004      ! 4. north fold treatment 
    7461005      ! ----------------------- 
    7471006      ! 
    748          !First Array 
    7491007      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    7501008         ! 
    7511009         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. 
     1010         CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp 
     1011         CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs. 
    7571012         END SELECT 
    7581013         ! 
    7591014      ENDIF 
    760         ! 
    7611015      ! 
    7621016      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
    7631017      ! 
    764    END SUBROUTINE mpp_lnk_2d_multiple 
    765  
    766     
    767    SUBROUTINE load_array( pt2d, cd_type, psgn, pt2d_array, type_array, psgn_array, num_fields ) 
    768       !!--------------------------------------------------------------------- 
    769       REAL(wp), DIMENSION(jpi,jpj), TARGET, INTENT(inout) ::   pt2d    ! Second 2D array on which the boundary condition is applied 
    770       CHARACTER(len=1)                    , INTENT(in   ) ::   cd_type ! define the nature of ptab array grid-points 
    771       REAL(wp)                            , INTENT(in   ) ::   psgn    ! =-1 the sign change across the north fold boundary 
    772       TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array 
    773       CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of ptab array grid-points 
    774       REAL(wp)         , DIMENSION(9) ::   psgn_array    ! =-1 the sign change across the north fold boundary 
    775       INTEGER                            , INTENT (inout) :: num_fields  
    776       !!--------------------------------------------------------------------- 
    777       num_fields = num_fields + 1 
    778       pt2d_array(num_fields)%pt2d => pt2d 
    779       type_array(num_fields)      =  cd_type 
    780       psgn_array(num_fields)      =  psgn 
    781    END SUBROUTINE load_array 
    782     
    783     
    784    SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
    785       &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
    786       &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
    787       !!--------------------------------------------------------------------- 
    788       ! Second 2D array on which the boundary condition is applied 
    789       REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA     
    790       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
    791       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI  
    792       ! define the nature of ptab array grid-points 
    793       CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
    794       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
    795       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
    796       ! =-1 the sign change across the north fold boundary 
    797       REAL(wp)                                      , INTENT(in   ) ::   psgnA     
    798       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
    799       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI    
    800       CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    801       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    802       !! 
    803       TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array  
    804       CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of ptab array grid-points 
    805       !                                                         ! = T , U , V , F , W and I points 
    806       REAL(wp)         , DIMENSION(9) ::   psgn_array    ! =-1 the sign change across the north fold boundary 
    807       INTEGER :: num_fields 
    808       !!--------------------------------------------------------------------- 
    809       ! 
    810       num_fields = 0 
    811       ! 
    812       ! Load the first array 
    813       CALL load_array( pt2dA, cd_typeA, psgnA, pt2d_array, type_array, psgn_array, num_fields ) 
    814       ! 
    815       ! Look if more arrays are added 
    816       IF( PRESENT(psgnB) )   CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields) 
    817       IF( PRESENT(psgnC) )   CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields) 
    818       IF( PRESENT(psgnD) )   CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields) 
    819       IF( PRESENT(psgnE) )   CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields) 
    820       IF( PRESENT(psgnF) )   CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields) 
    821       IF( PRESENT(psgnG) )   CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields) 
    822       IF( PRESENT(psgnH) )   CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields) 
    823       IF( PRESENT(psgnI) )   CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields) 
    824       ! 
    825       CALL mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, num_fields, cd_mpp,pval ) 
    826       ! 
    827    END SUBROUTINE mpp_lnk_2d_9 
    828  
    829  
    830    SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    831       !!---------------------------------------------------------------------- 
    832       !!                  ***  routine mpp_lnk_2d  *** 
    833       !! 
    834       !! ** Purpose :   Message passing manadgement for 2d array 
     1018   END SUBROUTINE mpp_lnk_2d 
     1019 
     1020 
     1021   SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn ) 
     1022      !!---------------------------------------------------------------------- 
     1023      !!                  ***  routine mpp_lnk_3d_gather  *** 
     1024      !! 
     1025      !! ** Purpose :   Message passing manadgement for two 3D arrays 
    8351026      !! 
    8361027      !! ** Method  :   Use mppsend and mpprecv function for passing mask 
     
    8461037      !!                    nono   : number for local neighboring processors 
    8471038      !! 
    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       !! 
    10541039      !! ** Action  :   ptab1 and ptab2  with update value at its periphery 
    10551040      !! 
    10561041      !!---------------------------------------------------------------------- 
    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 
     1042      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptab1     ! 1st 3D array on which the boundary condition is applied 
     1043      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type1  ! nature of ptab1 arrays 
     1044      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptab2     ! 3nd 3D array on which the boundary condition is applied 
     1045      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type2  ! nature of ptab2 arrays 
     1046      REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across the north fold boundary 
     1047      ! 
     1048      INTEGER  ::   jl                         ! dummy loop indices 
     1049      INTEGER  ::   ipk                        ! 3rd dimension of the input array 
    10641050      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    10651051      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     
    10691055      !!---------------------------------------------------------------------- 
    10701056      ! 
    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       ! 
     1057      ipk = SIZE( ptab1, 3 ) 
     1058      ! 
     1059      ALLOCATE( zt4ns(jpi,jprecj,ipk,2,2), zt4sn(jpi,jprecj,ipk,2,2) ,    & 
     1060         &      zt4ew(jpj,jpreci,ipk,2,2), zt4we(jpj,jpreci,ipk,2,2) ) 
     1061 
    10741062      ! 1. standard boundary treatment 
    10751063      ! ------------------------------ 
    10761064      !                                      ! East-West boundaries 
    1077       !                                           !* Cyclic east-west 
     1065      !                                           !* Cyclic  
    10781066      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    10791067         ptab1( 1 ,:,:) = ptab1(jpim1,:,:) 
     
    10821070         ptab2(jpi,:,:) = ptab2(  2  ,:,:) 
    10831071      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 , :) 
     1072         IF( .NOT. cd_type1 == 'F' )   ptab1(     1       :jpreci,:,:) = 0._wp   ! south except at F-point 
     1073         IF( .NOT. cd_type2 == 'F' )   ptab2(     1       :jpreci,:,:) = 0._wp 
     1074                                       ptab1(nlci-jpreci+1:jpi   ,:,:) = 0._wp   ! north 
     1075                                       ptab2(nlci-jpreci+1:jpi   ,:,:) = 0._wp 
     1076      ENDIF 
     1077      !                                     ! North-South boundaries 
     1078      !                                           !* cyclic 
     1079      IF( nbondj == 2 .AND. jperio == 7 ) THEN 
     1080         ptab1(:,  1  ,:) = ptab1(:, jpjm1 , :) 
     1081         ptab1(:, jpj ,:) = ptab1(:,   2   , :) 
     1082         ptab2(:,  1  ,:) = ptab2(:, jpjm1 , :) 
     1083         ptab2(:, jpj ,:) = ptab2(:,   2   , :) 
    10951084      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      
     1085         !                                        !* closed 
     1086         IF( .NOT. cd_type1 == 'F' )   ptab1(:,     1       :jprecj,:) = 0._wp   ! south except at F-point 
     1087         IF( .NOT. cd_type2 == 'F' )   ptab2(:,     1       :jprecj,:) = 0._wp 
     1088                                       ptab1(:,nlcj-jprecj+1:jpj   ,:) = 0._wp   ! north 
     1089                                       ptab2(:,nlcj-jprecj+1:jpj   ,:) = 0._wp 
     1090      ENDIF 
    11021091 
    11031092      ! 2. East and west directions exchange 
     
    11171106      ! 
    11181107      !                           ! Migrations 
    1119       imigr = jpreci * jpj * jpk *2 
     1108      imigr = jpreci * jpj * ipk *2 
    11201109      ! 
    11211110      SELECT CASE ( nbondi ) 
     
    11591148         END DO 
    11601149      END SELECT 
    1161  
    11621150 
    11631151      ! 3. North and south directions 
     
    11761164      ! 
    11771165      !                           ! Migrations 
    1178       imigr = jprecj * jpi * jpk * 2 
     1166      imigr = jprecj * jpi * ipk * 2 
    11791167      ! 
    11801168      SELECT CASE ( nbondj ) 
     
    12181206         END DO 
    12191207      END SELECT 
    1220  
    12211208 
    12221209      ! 4. north fold treatment 
     
    12841271 
    12851272 
    1286       ! 1. standard boundary treatment 
     1273      ! 1. standard boundary treatment   (CAUTION: the order matters Here !!!! ) 
    12871274      ! ------------------------------ 
    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) 
     1275      !                                !== North-South boundaries 
     1276      !                                      !* cyclic 
     1277      IF( nbondj == 2 .AND. jperio == 7 ) THEN 
     1278         pt2d(:, 1-jprj:  1     ) = pt2d ( :, jpjm1-jprj:jpjm1 ) 
    12931279         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 
     1280      ELSE                                   !* closed 
     1281         IF( .NOT. cd_type == 'F' )   pt2d(:,  1-jprj   :  jprecj  ) = 0._wp     ! south except at F-point 
     1282                                      pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0._wp     ! north 
     1283      ENDIF 
     1284      !                                !== East-West boundaries 
     1285      !                                      !* Cyclic east-west 
    13031286      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  
     1287         pt2d(1-jpri:     1    ,:) = pt2d(jpim1-jpri:  jpim1 ,:)              ! east 
     1288         pt2d(   jpi  :jpi+jpri,:) = pt2d(     2      :2+jpri,:)              ! west 
     1289      ELSE                                   !* closed 
     1290         IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0._wp  ! south except at F-point 
     1291                                      pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp  ! north 
     1292      ENDIF 
     1293      ! 
    13131294      ! north fold treatment 
    1314       ! ----------------------- 
     1295      ! -------------------- 
    13151296      IF( npolj /= 0 ) THEN 
    13161297         ! 
    13171298         SELECT CASE ( jpni ) 
    13181299         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               ) 
     1300         CASE DEFAULT   ;   CALL mpp_lbc_north_e( pt2d                  , cd_type, psgn             ) 
    13201301         END SELECT 
    13211302         ! 
     
    13751356      END SELECT 
    13761357 
    1377  
    13781358      ! 3. North and south directions 
    13791359      ! ----------------------------- 
     
    14291409      ! 
    14301410   END SUBROUTINE mpp_lnk_2d_e 
     1411 
    14311412 
    14321413   SUBROUTINE mpp_lnk_sum_3d( ptab, cd_type, psgn, cd_mpp, pval ) 
     
    14521433      !!---------------------------------------------------------------------- 
    14531434      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 
     1435      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  !  nature of ptab array grid-points 
     1436      REAL(wp)                        , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
    14581437      CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    14591438      REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    1460       !! 
     1439      ! 
    14611440      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
    14621441      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
     
    14671446      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north 
    14681447      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east 
    1469  
    1470       !!---------------------------------------------------------------------- 
    1471        
     1448      !!---------------------------------------------------------------------- 
     1449      ! 
    14721450      ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   & 
    14731451         &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  ) 
    1474  
    14751452      ! 
    14761453      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    1477       ELSE                         ;   zland = 0.e0      ! zero by default 
     1454      ELSE                         ;   zland = 0._wp     ! zero by default 
    14781455      ENDIF 
    14791456 
     
    14881465      iihom = nlci-jpreci 
    14891466         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  
     1467            zt3ew(:,jl,:,1) = ptab(jl      ,:,:) ; ptab(jl      ,:,:) = 0._wp 
     1468            zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0._wp  
    14921469         END DO 
    14931470      END SELECT 
     
    15201497      CASE ( -1 ) 
    15211498         DO jl = 1, jpreci 
    1522             ptab(iihom+jl,:,:) = ptab(iihom+jl,:,:) + zt3ew(:,jl,:,2) 
     1499            ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2) 
    15231500         END DO 
    15241501      CASE ( 0 ) 
     
    15331510      END SELECT 
    15341511 
    1535  
    15361512      ! 3. North and south directions 
    15371513      ! ----------------------------- 
     
    15411517         ijhom = nlcj-jprecj 
    15421518         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 
     1519            zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:)   ;   ptab(:,ijhom+jl,:) = 0._wp 
     1520            zt3ns(:,jl,:,1) = ptab(:,jl      ,:)   ;   ptab(:,jl      ,:) = 0._wp 
    15451521         END DO 
    15461522      ENDIF 
     
    15861562      END SELECT 
    15871563 
    1588  
    15891564      ! 4. north fold treatment 
    15901565      ! ----------------------- 
     
    16021577      ! 
    16031578   END SUBROUTINE mpp_lnk_sum_3d 
     1579 
    16041580 
    16051581   SUBROUTINE mpp_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
     
    16201596      !!                    noso   : number for local neighboring processors 
    16211597      !!                    nono   : number for local neighboring processors 
    1622       !! 
    16231598      !!---------------------------------------------------------------------- 
    16241599      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 
     1600      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! nature of pt2d array grid-points 
     1601      REAL(wp)                    , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
    16291602      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    16301603      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     
    16381611      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
    16391612      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
    1640  
    1641       !!---------------------------------------------------------------------- 
    1642  
     1613      !!---------------------------------------------------------------------- 
     1614      ! 
    16431615      ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  & 
    16441616         &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   ) 
    1645  
    16461617      ! 
    16471618      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    1648       ELSE                         ;   zland = 0.e0      ! zero by default 
     1619      ELSE                         ;   zland = 0._wp     ! zero by default 
    16491620      ENDIF 
    16501621 
     
    17571728      END SELECT 
    17581729 
    1759  
    17601730      ! 4. north fold treatment 
    17611731      ! ----------------------- 
     
    17731743      ! 
    17741744   END SUBROUTINE mpp_lnk_sum_2d 
     1745 
    17751746 
    17761747   SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req ) 
     
    20151986      !!                 ***  routine mppmax_a_real  *** 
    20161987      !! 
    2017       !! ** Purpose :   Maximum 
     1988      !! ** Purpose :   Maximum of a 1D array 
    20181989      !! 
    20191990      !!---------------------------------------------------------------------- 
     
    20392010      !!                  ***  routine mppmax_real  *** 
    20402011      !! 
    2041       !! ** Purpose :   Maximum 
     2012      !! ** Purpose :   Maximum for each element of a 1D array 
    20422013      !! 
    20432014      !!---------------------------------------------------------------------- 
     
    20572028   END SUBROUTINE mppmax_real 
    20582029 
    2059    SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom  ) 
     2030 
     2031   SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom  ) 
    20602032      !!---------------------------------------------------------------------- 
    20612033      !!                  ***  routine mppmax_real  *** 
     
    20642036      !! 
    20652037      !!---------------------------------------------------------------------- 
    2066       REAL(wp), DIMENSION(:) ,  INTENT(inout)           ::   ptab   ! ??? 
    2067       INTEGER , INTENT(in   )           ::   NUM 
    2068       INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
     2038      REAL(wp), DIMENSION(kdim), INTENT(inout) ::   pt1d   ! 1D arrays 
     2039      INTEGER                  , INTENT(in   ) ::   kdim 
     2040      INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom   ! local communicator 
    20692041      !! 
    20702042      INTEGER  ::   ierror, localcomm 
    2071       REAL(wp) , POINTER , DIMENSION(:) ::   zwork 
    2072       !!---------------------------------------------------------------------- 
    2073       ! 
    2074       CALL wrk_alloc(NUM , zwork) 
     2043      !!---------------------------------------------------------------------- 
     2044      ! 
    20752045      localcomm = mpi_comm_opa 
    20762046      IF( PRESENT(kcom) )   localcomm = kcom 
    20772047      ! 
    2078       CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 
    2079       ptab = zwork 
    2080       CALL wrk_dealloc(NUM , zwork) 
     2048      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror ) 
     2049      ptab(:) = zwork(:) 
    20812050      ! 
    20822051   END SUBROUTINE mppmax_real_multiple 
     
    22512220      !!----------------------------------------------------------------------- 
    22522221      ! 
    2253       zmin  = MINVAL( ptab(:,:) , mask= pmask == 1.e0 ) 
    2254       ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 ) 
     2222      zmin  = MINVAL( ptab(:,:) , mask= pmask == 1._wp ) 
     2223      ilocs = MINLOC( ptab(:,:) , mask= pmask == 1._wp ) 
    22552224      ! 
    22562225      ki = ilocs(1) + nimpp - 1 
     
    22792248      !! 
    22802249      !!-------------------------------------------------------------------------- 
    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       !! 
     2250      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   ptab         ! Local 2D array 
     2251      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pmask        ! Local mask 
     2252      REAL(wp)                  , INTENT(  out) ::   pmin         ! Global minimum of ptab 
     2253      INTEGER                   , INTENT(  out) ::   ki, kj, kk   ! index of minimum in global frame 
     2254      ! 
    22862255      INTEGER  ::   ierror 
    22872256      REAL(wp) ::   zmin     ! local minimum 
     
    22902259      !!----------------------------------------------------------------------- 
    22912260      ! 
    2292       zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 ) 
    2293       ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 ) 
     2261      zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1._wp ) 
     2262      ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1._wp ) 
    22942263      ! 
    22952264      ki = ilocs(1) + nimpp - 1 
     
    22972266      kk = ilocs(3) 
    22982267      ! 
    2299       zain(1,:)=zmin 
    2300       zain(2,:)=ki+10000.*kj+100000000.*kk 
     2268      zain(1,:) = zmin 
     2269      zain(2,:) = ki + 10000.*kj + 100000000.*kk 
    23012270      ! 
    23022271      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror) 
     
    23312300      !!----------------------------------------------------------------------- 
    23322301      ! 
    2333       zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 ) 
    2334       ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 ) 
     2302      zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1._wp ) 
     2303      ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1._wp ) 
    23352304      ! 
    23362305      ki = ilocs(1) + nimpp - 1 
     
    23592328      !! 
    23602329      !!-------------------------------------------------------------------------- 
    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 
     2330      REAL(wp), DIMENSION (:,:,:), INTENT(in   ) ::   ptab         ! Local 2D array 
     2331      REAL(wp), DIMENSION (:,:,:), INTENT(in   ) ::   pmask        ! Local mask 
     2332      REAL(wp)                   , INTENT(  out) ::   pmax         ! Global maximum of ptab 
     2333      INTEGER                    , INTENT(  out) ::   ki, kj, kk   ! index of maximum in global frame 
     2334      ! 
     2335      INTEGER  ::   ierror   ! local integer 
     2336      REAL(wp) ::   zmax     ! local maximum 
    23672337      REAL(wp), DIMENSION(2,1) ::   zain, zaout 
    23682338      INTEGER , DIMENSION(3)   ::   ilocs 
    2369       INTEGER :: ierror 
    23702339      !!----------------------------------------------------------------------- 
    23712340      ! 
    2372       zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 ) 
    2373       ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 ) 
     2341      zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1._wp ) 
     2342      ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1._wp ) 
    23742343      ! 
    23752344      ki = ilocs(1) + nimpp - 1 
     
    23772346      kk = ilocs(3) 
    23782347      ! 
    2379       zain(1,:)=zmax 
    2380       zain(2,:)=ki+10000.*kj+100000000.*kk 
     2348      zain(1,:) = zmax 
     2349      zain(2,:) = ki + 10000.*kj + 100000000.*kk 
    23812350      ! 
    23822351      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror) 
     
    24222391 
    24232392   SUBROUTINE mpp_comm_free( kcom ) 
    2424       !!---------------------------------------------------------------------- 
    24252393      !!---------------------------------------------------------------------- 
    24262394      INTEGER, INTENT(in) ::   kcom 
     
    26922660      !!              and apply lbc north-fold on this sub array. Then we 
    26932661      !!              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 
     2662      !!---------------------------------------------------------------------- 
     2663      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the b.c. is applied 
     2664      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
     2665      REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across the north fold 
     2666      ! 
    27012667      INTEGER ::   ji, jj, jr, jk 
     2668      INTEGER ::   ipk                  ! 3rd dimension of the input array 
    27022669      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    27032670      INTEGER ::   ijpj, ijpjm1, ij, iproc 
     
    27152682      !!---------------------------------------------------------------------- 
    27162683      ! 
    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) )  
     2684      ipk = SIZE( pt3d, 3 ) 
     2685      ! 
     2686      ALLOCATE( ztab (jpiglo,4,ipk), znorthloc(jpi,4,ipk), zfoldwk(jpi,4,ipk), znorthgloio(jpi,4,ipk,jpni) ) 
     2687      ALLOCATE( ztabl(jpi   ,4,ipk), ztabr(jpi*jpmaxngh,4,ipk)   )  
    27192688 
    27202689      ijpj   = 4 
    27212690      ijpjm1 = 3 
    27222691      ! 
    2723       znorthloc(:,:,:) = 0 
    2724       DO jk = 1, jpk 
     2692      znorthloc(:,:,:) = 0._wp 
     2693      DO jk = 1, ipk 
    27252694         DO jj = nlcj - ijpj +1, nlcj          ! put in xnorthloc the last 4 jlines of pt3d 
    27262695            ij = jj - nlcj + ijpj 
     
    27302699      ! 
    27312700      !                                     ! Build in procs of ncomm_north the znorthgloio 
    2732       itaille = jpi * jpk * ijpj 
     2701      itaille = jpi * ipk * ijpj 
    27332702 
    27342703      IF ( l_north_nogather ) THEN 
    27352704         ! 
    2736         ztabr(:,:,:) = 0 
    2737         ztabl(:,:,:) = 0 
    2738  
    2739         DO jk = 1, jpk 
     2705        ztabr(:,:,:) = 0._wp 
     2706        ztabl(:,:,:) = 0._wp 
     2707 
     2708        DO jk = 1, ipk 
    27402709           DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
    27412710              ij = jj - nlcj + ijpj 
     
    27472716 
    27482717         DO jr = 1,nsndto 
    2749             IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2718            IF ((nfipproc(isendto(jr),jpnj) /= (narea-1)) .and. (nfipproc(isendto(jr),jpnj) /= -1)) THEN 
    27502719              CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 
    27512720            ENDIF 
     
    27532722         DO jr = 1,nsndto 
    27542723            iproc = nfipproc(isendto(jr),jpnj) 
    2755             IF(iproc .ne. -1) THEN 
     2724            IF(iproc /= -1) THEN 
    27562725               ilei = nleit (iproc+1) 
    27572726               ildi = nldit (iproc+1) 
    27582727               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
    27592728            ENDIF 
    2760             IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
     2729            IF((iproc /= (narea-1)) .and. (iproc /= -1)) THEN 
    27612730              CALL mpprecv(5, zfoldwk, itaille, iproc) 
    2762               DO jk = 1, jpk 
     2731              DO jk = 1, ipk 
    27632732                 DO jj = 1, ijpj 
    27642733                    DO ji = ildi, ilei 
     
    27672736                 END DO 
    27682737              END DO 
    2769            ELSE IF (iproc .eq. (narea-1)) THEN 
    2770               DO jk = 1, jpk 
     2738           ELSE IF( iproc == narea-1 ) THEN 
     2739              DO jk = 1, ipk 
    27712740                 DO jj = 1, ijpj 
    27722741                    DO ji = ildi, ilei 
     
    27792748         IF (l_isend) THEN 
    27802749            DO jr = 1,nsndto 
    2781                IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2750               IF ((nfipproc(isendto(jr),jpnj) /= (narea-1)) .and. (nfipproc(isendto(jr),jpnj) /= -1)) THEN 
    27822751                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
    27832752               ENDIF     
     
    27852754         ENDIF 
    27862755         CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition 
    2787          DO jk = 1, jpk 
     2756         DO jk = 1, ipk 
    27882757            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d 
    27892758               ij = jj - nlcj + ijpj 
     
    27942763         END DO 
    27952764         ! 
    2796  
    27972765      ELSE 
    27982766         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                & 
    27992767            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    28002768         ! 
    2801          ztab(:,:,:) = 0.e0 
     2769         ztab(:,:,:) = 0._wp 
    28022770         DO jr = 1, ndim_rank_north         ! recover the global north array 
    28032771            iproc = nrank_north(jr) + 1 
     
    28052773            ilei  = nleit (iproc) 
    28062774            iilb  = nimppt(iproc) 
    2807             DO jk = 1, jpk 
     2775            DO jk = 1, ipk 
    28082776               DO jj = 1, ijpj 
    28092777                  DO ji = ildi, ilei 
     
    28152783         CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition 
    28162784         ! 
    2817          DO jk = 1, jpk 
     2785         DO jk = 1, ipk 
    28182786            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d 
    28192787               ij = jj - nlcj + ijpj 
     
    29022870 
    29032871         DO jr = 1,nsndto 
    2904             IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2872            IF ((nfipproc(isendto(jr),jpnj) /= (narea-1)) .and. (nfipproc(isendto(jr),jpnj) /= -1)) THEN 
    29052873               CALL mppsend(5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) 
    29062874            ENDIF 
     
    29082876         DO jr = 1,nsndto 
    29092877            iproc = nfipproc(isendto(jr),jpnj) 
    2910             IF(iproc .ne. -1) THEN 
     2878            IF(iproc /= -1) THEN 
    29112879               ilei = nleit (iproc+1) 
    29122880               ildi = nldit (iproc+1) 
    29132881               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
    29142882            ENDIF 
    2915             IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
     2883            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
    29162884              CALL mpprecv(5, zfoldwk, itaille, iproc) 
    29172885              DO jj = 1, ijpj 
     
    29202888                 END DO 
    29212889              END DO 
    2922             ELSE IF (iproc .eq. (narea-1)) THEN 
     2890            ELSE IF( iproc == narea-1 ) THEN 
    29232891              DO jj = 1, ijpj 
    29242892                 DO ji = ildi, ilei 
     
    29302898         IF (l_isend) THEN 
    29312899            DO jr = 1,nsndto 
    2932                IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2900               IF ((nfipproc(isendto(jr),jpnj) /= (narea-1)) .and. (nfipproc(isendto(jr),jpnj) /= -1)) THEN 
    29332901                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
    29342902               ENDIF 
     
    29482916            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    29492917         ! 
    2950          ztab(:,:) = 0.e0 
     2918         ztab(:,:) = 0._wp 
    29512919         DO jr = 1, ndim_rank_north            ! recover the global north array 
    29522920            iproc = nrank_north(jr) + 1 
     
    29752943   END SUBROUTINE mpp_lbc_north_2d 
    29762944 
    2977    SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 
     2945 
     2946   SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, kfld ) 
    29782947      !!--------------------------------------------------------------------- 
    29792948      !!                   ***  routine mpp_lbc_north_2d  *** 
     
    29902959      !! 
    29912960      !!---------------------------------------------------------------------- 
    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 
     2961      TYPE( arrayptr ), DIMENSION(:), INTENT(inout) ::   pt2d_array   ! pointer array of 2D fields 
     2962      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type      ! nature of pt2d grid-points 
     2963      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn         ! sign used across the north fold  
     2964      INTEGER                       , INTENT(in   ) ::   kfld         ! number of variables contained in pt2d 
     2965      ! 
    29982966      INTEGER ::   ji, jj, jr, jk 
    29992967      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 
     2968      INTEGER ::   ijpj, ijpjm1, ij, iproc, iflag 
     2969      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf   ! for mpi_isend when avoiding mpi_allgather 
     2970      INTEGER                            ::   ml_err      ! for mpi_isend when avoiding mpi_allgather 
     2971      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat     ! for mpi_isend when avoiding mpi_allgather 
     2972      !                                                   ! Workspace for message transfers avoiding mpi_allgather 
     2973      INTEGER :: istatus(mpi_status_size) 
    30052974      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
    30062975      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk 
    30072976      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
    30082977      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) ) 
     2978      !!---------------------------------------------------------------------- 
     2979      ! 
     2980      ALLOCATE( ztab(jpiglo,4,kfld), znorthloc  (jpi,4,kfld),        & 
     2981         &      zfoldwk(jpi,4,kfld), znorthgloio(jpi,4,kfld,jpni),   & 
     2982         &      ztabl  (jpi,4,kfld), ztabr(jpi*jpmaxngh, 4,kfld)   ) 
    30162983      ! 
    30172984      ijpj   = 4 
     
    30192986      ! 
    30202987       
    3021       DO jk = 1, num_fields 
     2988      DO jk = 1, kfld 
    30222989         DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable) 
    30232990            ij = jj - nlcj + ijpj 
     
    30333000         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
    30343001         ! 
    3035          ztabr(:,:,:) = 0 
    3036          ztabl(:,:,:) = 0 
    3037  
    3038          DO jk = 1, num_fields 
     3002         ztabr(:,:,:) = 0._wp 
     3003         ztabl(:,:,:) = 0._wp 
     3004 
     3005         DO jk = 1, kfld 
    30393006            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
    30403007               ij = jj - nlcj + ijpj 
     
    30453012         END DO 
    30463013 
    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 
     3014         DO jr = 1, nsndto 
     3015            IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
     3016               CALL mppsend(5, znorthloc, itaille*kfld, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "kfld" times 
    30503017            ENDIF 
    30513018         END DO 
    3052          DO jr = 1,nsndto 
     3019         DO jr = 1, nsndto 
    30533020            iproc = nfipproc(isendto(jr),jpnj) 
    3054             IF(iproc .ne. -1) THEN 
     3021            IF(iproc /= -1) THEN 
    30553022               ilei = nleit (iproc+1) 
    30563023               ildi = nldit (iproc+1) 
    30573024               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
    30583025            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 
     3026            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
     3027              CALL mpprecv(5, zfoldwk, itaille*kfld, iproc) ! Buffer expanded "kfld" times 
     3028              DO jk = 1 , kfld 
    30623029                 DO jj = 1, ijpj 
    30633030                    DO ji = ildi, ilei 
     
    30663033                 END DO 
    30673034              END DO 
    3068             ELSE IF (iproc .eq. (narea-1)) THEN 
    3069               DO jk = 1, num_fields 
     3035            ELSEIF ( iproc == narea-1 ) THEN 
     3036              DO jk = 1, kfld 
    30703037                 DO jj = 1, ijpj 
    30713038                    DO ji = ildi, ilei 
     
    30763043            ENDIF 
    30773044         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 
     3045         IF( l_isend ) THEN 
     3046            DO jr = 1, nsndto 
     3047               IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    30813048                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
    30823049               ENDIF 
     
    30843051         ENDIF 
    30853052         ! 
    3086          DO ji = 1, num_fields     ! Loop to manage 3D variables 
     3053         DO ji = 1, kfld     ! Loop to manage 3D variables 
    30873054            CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition 
    30883055         END DO 
    30893056         ! 
    3090          DO jk = 1, num_fields 
     3057         DO jk = 1, kfld 
    30913058            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    30923059               ij = jj - nlcj + ijpj 
     
    31003067      ELSE 
    31013068         ! 
    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 
     3069         CALL MPI_ALLGATHER( znorthloc  , itaille*kfld, MPI_DOUBLE_PRECISION,        & 
     3070            &                znorthgloio, itaille*kfld, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     3071         ! 
     3072         ztab(:,:,:) = 0._wp 
     3073         DO jk = 1, kfld 
    31073074            DO jr = 1, ndim_rank_north            ! recover the global north array 
    31083075               iproc = nrank_north(jr) + 1 
     
    31183085         END DO 
    31193086          
    3120          DO ji = 1, num_fields 
     3087         DO ji = 1, kfld 
    31213088            CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition 
    31223089         END DO 
    31233090         ! 
    3124          DO jk = 1, num_fields 
     3091         DO jk = 1, kfld 
    31253092            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    31263093               ij = jj - nlcj + ijpj 
     
    31383105   END SUBROUTINE mpp_lbc_north_2d_multiple 
    31393106 
     3107 
    31403108   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 
    31413109      !!--------------------------------------------------------------------- 
     
    31553123      REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    31563124      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 
     3125      REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! sign used across the north fold 
     3126      ! 
    31603127      INTEGER ::   ji, jj, jr 
    31613128      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    31623129      INTEGER ::   ijpj, ij, iproc 
    3163       ! 
    31643130      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
    31653131      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e 
    3166  
    31673132      !!---------------------------------------------------------------------- 
    31683133      ! 
    31693134      ALLOCATE( ztab_e(jpiglo,4+2*jpr2dj), znorthloc_e(jpi,4+2*jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) ) 
    3170  
    31713135      ! 
    31723136      ijpj=4 
    3173       ztab_e(:,:) = 0.e0 
    3174  
    3175       ij=0 
     3137      ztab_e(:,:) = 0._wp 
     3138 
     3139      ij = 0 
    31763140      ! put in znorthloc_e the last 4 jlines of pt2d 
    31773141      DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj 
    31783142         ij = ij + 1 
    31793143         DO ji = 1, jpi 
    3180             znorthloc_e(ji,ij)=pt2d(ji,jj) 
     3144            znorthloc_e(ji,ij) = pt2d(ji,jj) 
    31813145         END DO 
    31823146      END DO 
    31833147      ! 
    31843148      itaille = jpi * ( ijpj + 2 * jpr2dj ) 
    3185       CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    & 
     3149      CALL MPI_ALLGATHER( znorthloc_e(1,1)    , itaille, MPI_DOUBLE_PRECISION,    & 
    31863150         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    31873151      ! 
    31883152      DO jr = 1, ndim_rank_north            ! recover the global north array 
    31893153         iproc = nrank_north(jr) + 1 
    3190          ildi = nldit (iproc) 
    3191          ilei = nleit (iproc) 
    3192          iilb = nimppt(iproc) 
     3154         ildi  = nldit (iproc) 
     3155         ilei  = nleit (iproc) 
     3156         iilb  = nimppt(iproc) 
    31933157         DO jj = 1, ijpj+2*jpr2dj 
    31943158            DO ji = ildi, ilei 
     
    31973161         END DO 
    31983162      END DO 
    3199  
    32003163 
    32013164      ! 2. North-Fold boundary conditions 
     
    32383201      !! 
    32393202      !!---------------------------------------------------------------------- 
    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 
     3203      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
     3204      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type  ! nature of ptab grid point 
     3205      REAL(wp)                  , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
     3206      INTEGER                   , INTENT(in   ) ::   ib_bdy   ! BDY boundary set 
    32463207      ! 
    32473208      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
     3209      INTEGER  ::   ipk                        ! 3rd dimension of the input array 
    32483210      INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    32493211      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     
    32553217      !!---------------------------------------------------------------------- 
    32563218      ! 
    3257       ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   & 
    3258          &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  ) 
     3219      ipk = SIZE( ptab, 3 ) 
     3220      !       
     3221      ALLOCATE( zt3ns(jpi,jprecj,ipk,2), zt3sn(jpi,jprecj,ipk,2),   & 
     3222         &      zt3ew(jpj,jpreci,ipk,2), zt3we(jpj,jpreci,ipk,2)  ) 
    32593223 
    32603224      zland = 0._wp 
     
    32633227      ! ------------------------------ 
    32643228      !                                   ! East-West boundaries 
    3265       !                                        !* Cyclic east-west 
     3229      !                                        !* Cyclic 
    32663230      IF( nbondi == 2) THEN 
    32673231         IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 
     
    32733237         ENDIF 
    32743238      ELSEIF(nbondi == -1) THEN 
    3275          IF( .NOT. cd_type == 'F' )   ptab(1:jpreci,:,:) = zland    ! south except F-point 
     3239         IF( .NOT. cd_type == 'F' )   ptab(1:jpreci,:,:) = zland       ! south except F-point 
    32763240      ELSEIF(nbondi == 1) THEN 
    32773241         ptab(nlci-jpreci+1:jpi,:,:) = zland    ! north 
     
    32983262      ! 
    32993263      !                           ! Migrations 
    3300       imigr = jpreci * jpj * jpk 
     3264      imigr = jpreci * jpj * ipk 
    33013265      ! 
    33023266      SELECT CASE ( nbondi_bdy(ib_bdy) ) 
     
    33483312         END DO 
    33493313      END SELECT 
    3350  
    33513314 
    33523315      ! 3. North and south directions 
     
    33633326      ! 
    33643327      !                           ! Migrations 
    3365       imigr = jprecj * jpi * jpk 
     3328      imigr = jprecj * jpi * ipk 
    33663329      ! 
    33673330      SELECT CASE ( nbondj_bdy(ib_bdy) ) 
     
    34133376         END DO 
    34143377      END SELECT 
    3415  
    34163378 
    34173379      ! 4. north fold treatment 
     
    34533415      !! 
    34543416      !!---------------------------------------------------------------------- 
    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 
     3417      REAL(wp), DIMENSION(jpi,jpj)    , INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
     3418      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
     3419      REAL(wp)                        , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
     3420      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set 
     3421      ! 
     3422      INTEGER  ::   ji, jj, jl                 ! dummy loop indices 
    34633423      INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    34643424      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     
    34783438      ! ------------------------------ 
    34793439      !                                   ! East-West boundaries 
    3480       !                                      !* Cyclic east-west 
     3440      !                                         !* Cyclic 
    34813441      IF( nbondi == 2 ) THEN 
    3482          IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 
     3442         IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 
    34833443            ptab( 1 ,:) = ptab(jpim1,:) 
    34843444            ptab(jpi,:) = ptab(  2  ,:) 
    34853445         ELSE 
    3486             IF(.NOT.cd_type == 'F' )  ptab(     1       :jpreci,:) = zland    ! south except F-point 
    3487                                       ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
     3446            IF(.NOT.cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point 
     3447                                       ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
    34883448         ENDIF 
    34893449      ELSEIF(nbondi == -1) THEN 
    3490          IF( .NOT.cd_type == 'F' )    ptab(     1       :jpreci,:) = zland    ! south except F-point 
     3450         IF(.NOT.cd_type == 'F' )      ptab(     1       :jpreci,:) = zland    ! south except F-point 
    34913451      ELSEIF(nbondi == 1) THEN 
    3492                                       ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
     3452                                       ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
    34933453      ENDIF 
    34943454      !                                      !* closed 
     
    35373497      SELECT CASE ( nbondi_bdy(ib_bdy) ) 
    35383498      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) 
     3499         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
     3500      CASE ( 0 ) 
     3501         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
     3502         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err ) 
     3503      CASE ( 1 ) 
     3504         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
    35453505      END SELECT 
    35463506      ! 
     
    36283588         END DO 
    36293589      END SELECT 
    3630  
    36313590 
    36323591      ! 4. north fold treatment 
     
    37133672      !!   This subroutine computes yddb(i) = ydda(i)+yddb(i) 
    37143673      !!--------------------------------------------------------------------- 
    3715       INTEGER, INTENT(in)                         :: ilen, itype 
    3716       COMPLEX(wp), DIMENSION(ilen), INTENT(in)     :: ydda 
    3717       COMPLEX(wp), DIMENSION(ilen), INTENT(inout)  :: yddb 
     3674      INTEGER                     , INTENT(in)    ::  ilen, itype 
     3675      COMPLEX(wp), DIMENSION(ilen), INTENT(in)    ::  ydda 
     3676      COMPLEX(wp), DIMENSION(ilen), INTENT(inout) ::  yddb 
    37183677      ! 
    37193678      REAL(wp) :: zerr, zt1, zt2    ! local work variables 
    3720       INTEGER :: ji, ztmp           ! local scalar 
     3679      INTEGER  :: ji, ztmp           ! local scalar 
     3680      !!--------------------------------------------------------------------- 
    37213681 
    37223682      ztmp = itype   ! avoid compilation warning 
     
    38413801      !!                    nono   : number for local neighboring processors 
    38423802      !!---------------------------------------------------------------------- 
     3803      REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
     3804      CHARACTER(len=1)                                    , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
     3805      REAL(wp)                                            , INTENT(in   ) ::   psgn     ! sign used across the north fold 
    38433806      INTEGER                                             , INTENT(in   ) ::   jpri 
    38443807      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 
     3808      ! 
    38503809      INTEGER  ::   jl   ! dummy loop indices 
    38513810      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
     
    38753834         ! 
    38763835      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 
     3836         IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0._wp    ! south except at F-point 
     3837                                      pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp    ! north 
    38793838      ENDIF 
    38803839      ! 
     
    39963955         END DO 
    39973956      END SELECT 
    3998  
     3957      ! 
    39993958   END SUBROUTINE mpp_lnk_2d_icb 
    40003959    
     
    40203979      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
    40213980   END INTERFACE 
     3981   INTERFACE mpp_max_multiple 
     3982      MODULE PROCEDURE mppmax_real_multiple 
     3983   END INTERFACE 
    40223984 
    40233985   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag 
     
    41914153      WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom 
    41924154   END SUBROUTINE mpp_comm_free 
     4155    
     4156   SUBROUTINE mppmax_real_multiple( ptab, kdim , kcom  ) 
     4157      REAL, DIMENSION(:) ::   ptab   !  
     4158      INTEGER            ::   kdim   !  
     4159      INTEGER, OPTIONAL  ::   kcom   !  
     4160      WRITE(*,*) 'mppmax_real_multiple: You should not have seen this print! error?', ptab(1), kdim 
     4161   END SUBROUTINE mppmax_real_multiple 
     4162 
    41934163#endif 
    41944164 
     
    42254195                               CALL FLUSH(numout    ) 
    42264196      IF( numstp     /= -1 )   CALL FLUSH(numstp    ) 
    4227       IF( numsol     /= -1 )   CALL FLUSH(numsol    ) 
     4197      IF( numrun     /= -1 )   CALL FLUSH(numrun    ) 
    42284198      IF( numevo_ice /= -1 )   CALL FLUSH(numevo_ice) 
    42294199      ! 
     
    43324302            WRITE(kout,*) 
    43334303         ENDIF 
    4334          CALL FLUSH(kout)  
     4304         CALL FLUSH( kout )  
    43354305         STOP 'ctl_opn bad opening' 
    43364306      ENDIF 
Note: See TracChangeset for help on using the changeset viewer.