Changeset 7904


Ignore:
Timestamp:
2017-04-13T09:10:07+02:00 (3 years ago)
Author:
gm
Message:

#1880 (HPC-09): phase with branch dev_r7832_HPC08_lbclnk_3rd_dim

Location:
branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/OPA_SRC
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/OPA_SRC/IOM/in_out_manager.F90

    r7646 r7904  
    126126   INTEGER ::   numoni          =   -1      !: logical unit for Output Namelist Ice 
    127127   INTEGER ::   numevo_ice      =   -1      !: logical unit for ice variables (temp. evolution) 
    128    INTEGER ::   numsol          =   -1      !: logical unit for solver statistics 
     128   INTEGER ::   numrun          =   -1      !: logical unit for run statistics 
    129129   INTEGER ::   numdct_in       =   -1      !: logical unit for transports computing 
    130130   INTEGER ::   numdct_vol      =   -1      !: logical unit for voulume transports output 
  • branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

    r6493 r7904  
    22   !!====================================================================== 
    33   !!                       ***  MODULE  lbclnk  *** 
    4    !! Ocean        : lateral boundary conditions 
     4   !! NEMO        : lateral boundary conditions 
    55   !!===================================================================== 
    66   !! History :  OPA  ! 1997-06  (G. Madec)  Original code 
     
    1010   !!            3.4  ! 2012-12  (R. Bourdalle-Badie, G. Reffray)  add a C1D case   
    1111   !!            3.6  ! 2015-06  (O. Tintó and M. Castrillo)  add lbc_lnk_multi   
     12   !!            4.0  ! 2017-03  (G. Madec) automatique allocation of array size (use with any 3rd dim size) 
     13   !!             -   ! 2017-04  (G. Madec) remove duplicated routines (lbc_lnk_2d_9, lbc_lnk_2d_multiple, lbc_lnk_3d_gather) 
    1214   !!---------------------------------------------------------------------- 
    1315#if defined key_mpp_mpi 
     
    1517   !!   'key_mpp_mpi'             MPI massively parallel processing library 
    1618   !!---------------------------------------------------------------------- 
    17    !!   lbc_lnk      : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp 
    18    !!   lbc_sum      : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d routines defined in lib_mpp 
    19    !!   lbc_lnk_e    : generic interface for mpp_lnk_2d_e routine defined in lib_mpp 
    20    !!   lbc_bdy_lnk  : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 
     19   !!           define the generic interfaces of lib_mpp routines 
     20   !!---------------------------------------------------------------------- 
     21   !!   lbc_lnk       : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp 
     22   !!   lbc_sum       : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d routines defined in lib_mpp 
     23   !!   lbc_lnk_e     : generic interface for mpp_lnk_2d_e routine defined in lib_mpp 
     24   !!   lbc_bdy_lnk   : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 
    2125   !!---------------------------------------------------------------------- 
    2226   USE lib_mpp        ! distributed memory computing library 
     
    4650   END INTERFACE 
    4751 
    48    PUBLIC   lbc_lnk       ! ocean lateral boundary conditions 
    49    PUBLIC   lbc_lnk_multi ! modified ocean lateral boundary conditions 
    50    PUBLIC   lbc_sum 
    51    PUBLIC   lbc_lnk_e     ! 
     52   PUBLIC   lbc_lnk       ! ocean/ice lateral boundary conditions 
     53   PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 
     54   PUBLIC   lbc_sum       ! sum across processors 
     55   PUBLIC   lbc_lnk_e     ! extended ocean/ice lateral boundary conditions 
    5256   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    53    PUBLIC   lbc_lnk_icb   ! 
    54  
    55    !!---------------------------------------------------------------------- 
    56    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     57   PUBLIC   lbc_lnk_icb   ! iceberg lateral boundary conditions 
     58 
     59   !!---------------------------------------------------------------------- 
     60   !! NEMO/OPA 4.0 , NEMO Consortium (2017) 
    5761   !! $Id$ 
    5862   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     
    6165   !!---------------------------------------------------------------------- 
    6266   !!   Default option                              shared memory computing 
     67   !!---------------------------------------------------------------------- 
     68   !!                routines setting the appropriate values 
     69   !!         on first and last row and column of the global domain 
    6370   !!---------------------------------------------------------------------- 
    6471   !!   lbc_sum       : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d  
     
    7077   !!   lbc_bdy_lnk   : set the lateral BDY boundary condition 
    7178   !!---------------------------------------------------------------------- 
    72    USE oce             ! ocean dynamics and tracers    
    73    USE dom_oce         ! ocean space and time domain  
    74    USE in_out_manager  ! I/O manager 
    75    USE lbcnfd          ! north fold 
     79   USE oce            ! ocean dynamics and tracers    
     80   USE dom_oce        ! ocean space and time domain  
     81   USE in_out_manager ! I/O manager 
     82   USE lbcnfd         ! north fold 
    7683 
    7784   IMPLICIT NONE 
     
    8592      MODULE PROCEDURE lbc_lnk_sum_3d, lbc_lnk_sum_2d 
    8693   END INTERFACE 
    87  
     94   ! 
    8895   INTERFACE lbc_lnk_e 
    8996      MODULE PROCEDURE lbc_lnk_2d_e 
     
    93100      MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple 
    94101   END INTERFACE 
    95  
     102   ! 
    96103   INTERFACE lbc_bdy_lnk 
    97104      MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d 
     
    105112      REAL , DIMENSION (:,:),  POINTER :: pt2d 
    106113   END TYPE arrayptr 
     114   ! 
    107115   PUBLIC   arrayptr 
    108116 
    109117   PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions 
    110118   PUBLIC   lbc_sum       ! ocean/ice  lateral boundary conditions (sum of the overlap region) 
    111    PUBLIC   lbc_lnk_e     ! 
    112    PUBLIC   lbc_lnk_multi ! modified ocean lateral boundary conditions 
     119   PUBLIC   lbc_lnk_e     ! extended ocean/ice lateral boundary conditions 
     120   PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 
    113121   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    114    PUBLIC   lbc_lnk_icb   ! 
     122   PUBLIC   lbc_lnk_icb   ! iceberg lateral boundary conditions 
    115123    
    116124   !!---------------------------------------------------------------------- 
    117    !! NEMO/OPA 3.7 , NEMO Consortium (2015) 
     125   !! NEMO/OPA 4.0 , NEMO Consortium (2017) 
    118126   !! $Id$ 
    119127   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     
    125133   !!   'key_c1d'                                          1D configuration 
    126134   !!---------------------------------------------------------------------- 
    127  
    128    SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 
    129       !!--------------------------------------------------------------------- 
    130       !!                  ***  ROUTINE lbc_lnk_3d_gather  *** 
    131       !! 
    132       !! ** Purpose :   set lateral boundary conditions on two 3D arrays (C1D case) 
    133       !! 
    134       !! ** Method  :   call lbc_lnk_3d on pt3d1 and pt3d2 
    135       !!---------------------------------------------------------------------- 
    136       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1, cd_type2   ! nature of pt3d grid-points 
    137       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d1   , pt3d2      ! 3D array on which the lbc is applied 
    138       REAL(wp)                        , INTENT(in   ) ::   psgn                 ! control of the sign  
    139       !!---------------------------------------------------------------------- 
    140       ! 
    141       CALL lbc_lnk_3d( pt3d1, cd_type1, psgn) 
    142       CALL lbc_lnk_3d( pt3d2, cd_type2, psgn) 
    143       ! 
    144    END SUBROUTINE lbc_lnk_3d_gather 
    145  
     135   !!     central point value replicated over the 8 surrounding points 
     136   !!---------------------------------------------------------------------- 
    146137 
    147138   SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 
     
    153144      !! ** Method  :   1D case, the central water column is set everywhere 
    154145      !!---------------------------------------------------------------------- 
    155       CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    156       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
    157       REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign  
    158       CHARACTER(len=3)                , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
    159       REAL(wp)                        , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
     146      REAL(wp), DIMENSION(:,:,:), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
     147      CHARACTER(len=1)          , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
     148      REAL(wp)                  , INTENT(in   )           ::   psgn      ! sign used across north fold  
     149      CHARACTER(len=3)          , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
     150      REAL(wp)                  , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
    160151      ! 
    161152      INTEGER  ::   jk     ! dummy loop index 
     
    163154      !!---------------------------------------------------------------------- 
    164155      ! 
    165       DO jk = 1, jpk 
     156      DO jk = 1, SIZE( pt3d, 3 ) 
    166157         ztab = pt3d(2,2,jk) 
    167158         pt3d(:,:,jk) = ztab 
     
    179170      !! ** Method  :   1D case, the central water column is set everywhere 
    180171      !!---------------------------------------------------------------------- 
     172      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied 
    181173      CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    182       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied 
    183       REAL(wp)                    , INTENT(in   )           ::   psgn      ! control of the sign  
     174      REAL(wp)                    , INTENT(in   )           ::   psgn      ! sign used across north fold  
    184175      CHARACTER(len=3)            , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
    185176      REAL(wp)                    , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
     
    193184   END SUBROUTINE lbc_lnk_2d 
    194185    
    195    SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 
    196       !! 
    197       INTEGER :: num_fields 
    198       TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
    199       CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
    200       !                                                               ! = T , U , V , F , W and I points 
    201       REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
    202       !                                                               ! =  1. , the sign is kept 
    203       ! 
    204       INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
    205       ! 
    206       DO ii = 1, num_fields 
    207         CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 
    208       END DO      
    209       ! 
    210    END SUBROUTINE lbc_lnk_2d_multiple 
    211  
    212    SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
    213       &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
    214       &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
    215       !!--------------------------------------------------------------------- 
    216       ! Second 2D array on which the boundary condition is applied 
    217       REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA 
    218       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
    219       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
    220       ! define the nature of ptab array grid-points 
    221       CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
    222       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
    223       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
    224       ! =-1 the sign change across the north fold boundary 
    225       REAL(wp)                                      , INTENT(in   ) ::   psgnA 
    226       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
    227       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI 
    228       CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    229       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    230       !! 
    231       !!--------------------------------------------------------------------- 
    232  
    233       !!The first array 
    234       CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
    235  
    236       !! Look if more arrays to process 
    237       IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
    238       IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
    239       IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
    240       IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
    241       IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
    242       IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
    243       IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
    244       IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
    245  
    246    END SUBROUTINE lbc_lnk_2d_9 
    247  
    248  
    249  
    250  
    251  
    252186#else 
    253187   !!---------------------------------------------------------------------- 
    254188   !!   Default option                           3D shared memory computing 
    255189   !!---------------------------------------------------------------------- 
    256  
    257    SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 
    258       !!--------------------------------------------------------------------- 
    259       !!                  ***  ROUTINE lbc_lnk_3d_gather  *** 
    260       !! 
    261       !! ** Purpose :   set lateral boundary conditions on two 3D arrays (non mpp case) 
     190   !!          routines setting land point, or east-west cyclic, 
     191   !!             or north-south cyclic, or north fold values 
     192   !!         on first and last row and column of the global domain 
     193   !!---------------------------------------------------------------------- 
     194 
     195   SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 
     196      !!--------------------------------------------------------------------- 
     197      !!                  ***  ROUTINE lbc_lnk_3d  *** 
     198      !! 
     199      !! ** Purpose :   set lateral boundary conditions on a 3D array (non mpp case) 
    262200      !! 
    263201      !! ** Method  :   psign = -1 :    change the sign across the north fold 
     
    267205      !!                             for closed boundaries. 
    268206      !!---------------------------------------------------------------------- 
    269       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1, cd_type2   ! nature of pt3d grid-points 
    270       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d1   , pt3d2      ! 3D array on which the lbc is applied 
    271       REAL(wp)                        , INTENT(in   ) ::   psgn                 ! control of the sign  
    272       !!---------------------------------------------------------------------- 
    273       ! 
    274       CALL lbc_lnk_3d( pt3d1, cd_type1, psgn) 
    275       CALL lbc_lnk_3d( pt3d2, cd_type2, psgn) 
    276       ! 
    277    END SUBROUTINE lbc_lnk_3d_gather 
    278  
    279  
    280    SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 
    281       !!--------------------------------------------------------------------- 
    282       !!                  ***  ROUTINE lbc_lnk_3d  *** 
    283       !! 
    284       !! ** Purpose :   set lateral boundary conditions on a 3D array (non mpp case) 
    285       !! 
    286       !! ** Method  :   psign = -1 :    change the sign across the north fold 
    287       !!                      =  1 : no change of the sign across the north fold 
    288       !!                      =  0 : no change of the sign across the north fold and 
    289       !!                             strict positivity preserved: use inner row/column 
    290       !!                             for closed boundaries. 
    291       !!---------------------------------------------------------------------- 
    292       CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    293       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
    294       REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign  
    295       CHARACTER(len=3)                , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
    296       REAL(wp)                        , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
    297       !! 
     207      REAL(wp), DIMENSION(:,:,:), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
     208      CHARACTER(len=1)          , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
     209      REAL(wp)                  , INTENT(in   )           ::   psgn      ! sign used across north fold  
     210      CHARACTER(len=3)          , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
     211      REAL(wp)                  , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
     212      ! 
    298213      REAL(wp) ::   zland 
    299214      !!---------------------------------------------------------------------- 
    300  
     215      ! 
    301216      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default) 
    302217      ELSE                         ;   zland = 0._wp 
    303218      ENDIF 
    304  
    305  
     219      ! 
    306220      IF( PRESENT( cd_mpp ) ) THEN 
    307221         ! only fill the overlap area and extra allows  
     
    378292      CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    379293      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied 
    380       REAL(wp)                    , INTENT(in   )           ::   psgn      ! control of the sign  
     294      REAL(wp)                    , INTENT(in   )           ::   psgn      ! sign used across north fold 
    381295      CHARACTER(len=3)            , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
    382296      REAL(wp)                    , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
     
    448362   END SUBROUTINE lbc_lnk_2d 
    449363    
    450    SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 
    451       !! 
    452       INTEGER :: num_fields 
    453       TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
    454       CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
    455       !                                                               ! = T , U , V , F , W and I points 
    456       REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
    457       !                                                               ! =  1. , the sign is kept 
    458       ! 
    459       INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
    460       ! 
    461       DO ii = 1, num_fields 
    462         CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 
     364#endif 
     365 
     366   !!---------------------------------------------------------------------- 
     367   !!   identical routines in both C1D and shared memory computing cases 
     368   !!---------------------------------------------------------------------- 
     369 
     370   SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 
     371      !!--------------------------------------------------------------------- 
     372      !!                  ***  ROUTINE lbc_lnk_3d_gather  *** 
     373      !! 
     374      !! ** Purpose :   set lateral boundary conditions on two 3D arrays (C1D case) 
     375      !! 
     376      !! ** Method  :   call lbc_lnk_3d on pt3d1 and pt3d2 
     377      !!---------------------------------------------------------------------- 
     378      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d1   , pt3d2      ! 3D array on which the lbc is applied 
     379      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type1, cd_type2   ! nature of pt3d1 & pt3d2 grid-points 
     380      REAL(wp)                  , INTENT(in   ) ::   psgn                 ! sign used across north fold  
     381      !!---------------------------------------------------------------------- 
     382      ! 
     383      CALL lbc_lnk_3d( pt3d1, cd_type1, psgn) 
     384      CALL lbc_lnk_3d( pt3d2, cd_type2, psgn) 
     385      ! 
     386   END SUBROUTINE lbc_lnk_3d_gather 
     387 
     388   
     389   SUBROUTINE lbc_lnk_2d_multiple( pt2d_array, type_array, psgn_array, kfld ) 
     390      !!--------------------------------------------------------------------- 
     391      TYPE( arrayptr ), DIMENSION(:), INTENT(inout) ::   pt2d_array   ! pointer array of 2D fields 
     392      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! nature of ptab_array grid-points 
     393      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! sign used across the north fold boundary 
     394      INTEGER                       , INTENT(in   ) ::   kfld         ! number of 2D fields 
     395      ! 
     396      INTEGER  ::   jf    !dummy loop index 
     397      !!--------------------------------------------------------------------- 
     398      ! 
     399      DO jf = 1, kfld 
     400        CALL lbc_lnk_2d( pt2d_array(jf)%pt2d, type_array(jf), psgn_array(jf) ) 
    463401      END DO      
    464402      ! 
    465403   END SUBROUTINE lbc_lnk_2d_multiple 
    466404 
    467    SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
    468       &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
    469       &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
    470       !!--------------------------------------------------------------------- 
    471       ! Second 2D array on which the boundary condition is applied 
    472       REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA 
     405 
     406   SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC,   & 
     407      &                     pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF,   & 
     408      &                     pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI,   & 
     409      &                     cd_mpp, pval ) 
     410      !!--------------------------------------------------------------------- 
     411      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA    ! 2D arrays on which the lbc is applied 
    473412      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
    474413      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
    475       ! define the nature of ptab array grid-points 
    476       CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
     414      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA ! nature of pt2D. array grid-points 
    477415      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
    478416      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
    479       ! =-1 the sign change across the north fold boundary 
    480       REAL(wp)                                      , INTENT(in   ) ::   psgnA 
     417      REAL(wp)                                      , INTENT(in   ) ::   psgnA    ! sign used across the north fold 
    481418      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
    482419      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI 
     
    485422      !! 
    486423      !!--------------------------------------------------------------------- 
    487  
    488       !!The first array 
    489       CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
    490  
    491       !! Look if more arrays to process 
    492       IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
    493       IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
    494       IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
    495       IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
    496       IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
    497       IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
    498       IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
    499       IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
    500  
     424      ! 
     425                              CALL lbc_lnk( pt2dA, cd_typeA, psgnA )    ! The first array 
     426      !           
     427      IF( PRESENT (psgnB) )   CALL lbc_lnk( pt2dB, cd_typeB, psgnB )    ! Look if more arrays to process 
     428      IF( PRESENT (psgnC) )   CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
     429      IF( PRESENT (psgnD) )   CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
     430      IF( PRESENT (psgnE) )   CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
     431      IF( PRESENT (psgnF) )   CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
     432      IF( PRESENT (psgnG) )   CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
     433      IF( PRESENT (psgnH) )   CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
     434      IF( PRESENT (psgnI) )   CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
     435      ! 
    501436   END SUBROUTINE lbc_lnk_2d_9 
     437 
     438 
     439   SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy ) 
     440      !!--------------------------------------------------------------------- 
     441      !!                  ***  ROUTINE lbc_bdy_lnk  *** 
     442      !! 
     443      !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 
     444      !!              to maintain the same interface with regards to the mpp case 
     445      !!---------------------------------------------------------------------- 
     446      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the lbc is applied 
     447      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
     448      REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across north fold  
     449      INTEGER                   , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
     450      !!---------------------------------------------------------------------- 
     451      ! 
     452      CALL lbc_lnk_3d( pt3d, cd_type, psgn) 
     453      ! 
     454   END SUBROUTINE lbc_bdy_lnk_3d 
     455 
     456 
     457   SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy ) 
     458      !!--------------------------------------------------------------------- 
     459      !!                  ***  ROUTINE lbc_bdy_lnk  *** 
     460      !! 
     461      !! ** Purpose :   wrapper rountine to 'lbc_lnk_2d'. This wrapper is used 
     462      !!              to maintain the same interface with regards to the mpp case 
     463      !!---------------------------------------------------------------------- 
     464      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 3D array on which the lbc is applied 
     465      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
     466      REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold  
     467      INTEGER                 , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
     468      !!---------------------------------------------------------------------- 
     469      ! 
     470      CALL lbc_lnk_2d( pt2d, cd_type, psgn) 
     471      ! 
     472   END SUBROUTINE lbc_bdy_lnk_2d 
     473 
     474 
     475   SUBROUTINE lbc_lnk_2d_e( pt2d, cd_type, psgn, ki, kj ) 
     476      !!--------------------------------------------------------------------- 
     477      !!                 ***  ROUTINE lbc_lnk_2d  *** 
     478      !! 
     479      !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case) 
     480      !!                special dummy routine to allow for use of halo indexing in mpp case 
     481      !!---------------------------------------------------------------------- 
     482      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the lbc is applied 
     483      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
     484      REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold  
     485      INTEGER                 , INTENT(in   ) ::   ki, kj    ! sizes of extra halo (not needed in non-mpp) 
     486      !!---------------------------------------------------------------------- 
     487      ! 
     488      CALL lbc_lnk_2d( pt2d, cd_type, psgn ) 
     489      !     
     490   END SUBROUTINE lbc_lnk_2d_e 
     491 
    502492 
    503493   SUBROUTINE lbc_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
     
    513503      CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    514504      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied 
    515       REAL(wp)                    , INTENT(in   )           ::   psgn      ! control of the sign  
     505      REAL(wp)                    , INTENT(in   )           ::   psgn      ! sign used across north fold  
    516506      CHARACTER(len=3)            , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
    517507      REAL(wp)                    , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
     
    519509      REAL(wp) ::   zland 
    520510      !!---------------------------------------------------------------------- 
    521  
     511      ! 
    522512      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default) 
    523513      ELSE                         ;   zland = 0._wp 
    524514      ENDIF 
    525  
     515      ! 
    526516      IF (PRESENT(cd_mpp)) THEN 
    527517         ! only fill the overlap area and extra allows  
     
    553543         ! 
    554544      END IF 
    555  
     545      ! 
    556546   END SUBROUTINE 
     547 
    557548 
    558549   SUBROUTINE lbc_lnk_sum_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 
     
    566557      !!                this line, nothing is done along the north fold. 
    567558      !!---------------------------------------------------------------------- 
    568       CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    569       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
    570       REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign  
    571       CHARACTER(len=3)                , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
    572       REAL(wp)                        , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
    573       !! 
     559      REAL(wp), DIMENSION(:,:,:), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
     560      CHARACTER(len=1)          , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
     561      REAL(wp)                  , INTENT(in   )           ::   psgn      ! sign used across north fold  
     562      CHARACTER(len=3)          , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
     563      REAL(wp)                  , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
     564      ! 
    574565      REAL(wp) ::   zland 
    575566      !!---------------------------------------------------------------------- 
    576  
     567      ! 
    577568      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default) 
    578569      ELSE                         ;   zland = 0._wp 
    579570      ENDIF 
    580  
    581  
     571      ! 
    582572      IF( PRESENT( cd_mpp ) ) THEN 
    583573         ! only fill the overlap area and extra allows  
     
    591581            pt3d(jpim1,:,:) = pt3d(jpim1,:,:) + pt3d( 1 ,:,:) 
    592582            pt3d(  2  ,:,:) = pt3d(  2  ,:,:) + pt3d(jpi,:,:)  
    593             pt3d( 1 ,:,:) = 0.0_wp            ! all points 
    594             pt3d(jpi,:,:) = 0.0_wp 
     583            pt3d( 1 ,:,:) = 0._wp 
     584            pt3d(jpi,:,:) = 0._wp 
    595585            ! 
    596586         CASE DEFAULT                             !**  East closed  --  West closed 
     
    609599         ! 
    610600      END IF 
     601      ! 
    611602   END SUBROUTINE 
    612  
    613  
    614 #endif 
    615  
    616    SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy ) 
    617       !!--------------------------------------------------------------------- 
    618       !!                  ***  ROUTINE lbc_bdy_lnk  *** 
    619       !! 
    620       !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 
    621       !!              to maintain the same interface with regards to the mpp case 
    622       !! 
    623       !!---------------------------------------------------------------------- 
    624       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    625       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d      ! 3D array on which the lbc is applied 
    626       REAL(wp)                        , INTENT(in   ) ::   psgn      ! control of the sign  
    627       INTEGER                         , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
    628       !!---------------------------------------------------------------------- 
    629       ! 
    630       CALL lbc_lnk_3d( pt3d, cd_type, psgn) 
    631       ! 
    632    END SUBROUTINE lbc_bdy_lnk_3d 
    633  
    634  
    635    SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy ) 
    636       !!--------------------------------------------------------------------- 
    637       !!                  ***  ROUTINE lbc_bdy_lnk  *** 
    638       !! 
    639       !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 
    640       !!              to maintain the same interface with regards to the mpp case 
    641       !! 
    642       !!---------------------------------------------------------------------- 
    643       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    644       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 3D array on which the lbc is applied 
    645       REAL(wp)                    , INTENT(in   ) ::   psgn      ! control of the sign  
    646       INTEGER                     , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
    647       !!---------------------------------------------------------------------- 
    648       ! 
    649       CALL lbc_lnk_2d( pt2d, cd_type, psgn) 
    650       ! 
    651    END SUBROUTINE lbc_bdy_lnk_2d 
    652  
    653  
    654    SUBROUTINE lbc_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj ) 
    655       !!--------------------------------------------------------------------- 
    656       !!                 ***  ROUTINE lbc_lnk_2d  *** 
    657       !! 
    658       !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case) 
    659       !!                special dummy routine to allow for use of halo indexing in mpp case 
    660       !! 
    661       !! ** Method  :   psign = -1 :    change the sign across the north fold 
    662       !!                      =  1 : no change of the sign across the north fold 
    663       !!                      =  0 : no change of the sign across the north fold and 
    664       !!                             strict positivity preserved: use inner row/column 
    665       !!                             for closed boundaries. 
    666       !!---------------------------------------------------------------------- 
    667       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    668       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 2D array on which the lbc is applied 
    669       REAL(wp)                    , INTENT(in   ) ::   psgn      ! control of the sign  
    670       INTEGER                     , INTENT(in   ) ::   jpri      ! size of extra halo (not needed in non-mpp) 
    671       INTEGER                     , INTENT(in   ) ::   jprj      ! size of extra halo (not needed in non-mpp) 
    672       !!---------------------------------------------------------------------- 
    673       ! 
    674       CALL lbc_lnk_2d( pt2d, cd_type, psgn ) 
    675       !     
    676    END SUBROUTINE lbc_lnk_2d_e 
    677603 
    678604#endif 
  • branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90

    r7646 r7904  
    55   !!====================================================================== 
    66   !! History :  3.2  ! 2009-03  (R. Benshila)  Original code  
    7    !!            3.5  ! 2013-07 (I. Epicoco, S. Mocavero - CMCC) MPP optimization  
     7   !!            3.5  ! 2013-07  (I. Epicoco, S. Mocavero - CMCC) MPP optimization 
     8   !!            4.0  ! 2017-04  (G. Madec) automatique allocation of array argument (use any 3rd dimension) 
    89   !!---------------------------------------------------------------------- 
    910 
     
    1213   !!   lbc_nfd_3d    : lateral boundary condition: North fold treatment for a 3D arrays   (lbc_nfd) 
    1314   !!   lbc_nfd_2d    : lateral boundary condition: North fold treatment for a 2D arrays   (lbc_nfd) 
    14    !!   mpp_lbc_nfd_3d    : North fold treatment for a 3D arrays optimized for MPP 
    15    !!   mpp_lbc_nfd_2d    : North fold treatment for a 2D arrays optimized for MPP 
     15   !!   mpp_lbc_nfd_3d: North fold treatment for a 3D arrays optimized for MPP 
     16   !!   mpp_lbc_nfd_2d: North fold treatment for a 2D arrays optimized for MPP 
    1617   !!---------------------------------------------------------------------- 
    1718   USE dom_oce        ! ocean space and time domain  
     
    5455      !! ** Action  :   pt3d with updated values along the north fold 
    5556      !!---------------------------------------------------------------------- 
    56       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! define the nature of ptab array grid-points 
    57       !                                                        !   = T , U , V , F , W points 
    58       REAL(wp)                  , INTENT(in   ) ::   psgn      ! control of the sign change 
    59       !                                                        !   = -1. , the sign is changed if north fold boundary 
    60       !                                                        !   =  1. , the sign is kept  if north fold boundary 
    6157      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the boundary condition is applied 
     58      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-point 
     59      REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across north fold 
    6260      ! 
    6361      INTEGER  ::   ji, jk 
    6462      INTEGER  ::   ijt, iju, ijpj, ijpjm1 
    6563      !!---------------------------------------------------------------------- 
    66  
     64      ! 
    6765      SELECT CASE ( jpni ) 
    6866      CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction 
     
    7169      ijpjm1 = ijpj-1 
    7270 
    73       DO jk = 1, jpk 
     71      DO jk = 1, SIZE( pt3d, 3 ) 
    7472         ! 
    7573         SELECT CASE ( npolj ) 
     
    155153            SELECT CASE ( cd_type) 
    156154            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    157                pt3d(:, 1  ,jk) = 0.e0 
    158                pt3d(:,ijpj,jk) = 0.e0 
     155               pt3d(:, 1  ,jk) = 0._wp 
     156               pt3d(:,ijpj,jk) = 0._wp 
    159157            CASE ( 'F' )                               ! F-point 
    160                pt3d(:,ijpj,jk) = 0.e0 
     158               pt3d(:,ijpj,jk) = 0._wp 
    161159            END SELECT 
    162160            ! 
     
    179177      !! ** Action  :   pt2d with updated values along the north fold 
    180178      !!---------------------------------------------------------------------- 
    181       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! define the nature of ptab array grid-points 
    182       !                                                      ! = T , U , V , F , W points 
    183       REAL(wp)                , INTENT(in   ) ::   psgn      ! control of the sign change 
    184       !                                                      !   = -1. , the sign is changed if north fold boundary 
    185       !                                                      !   =  1. , the sign is kept  if north fold boundary 
    186179      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the boundary condition is applied 
     180      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt2d grid-point 
     181      REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold 
    187182      INTEGER , OPTIONAL      , INTENT(in   ) ::   pr2dj     ! number of additional halos 
    188183      ! 
     
    265260               END DO 
    266261            END DO 
    267          CASE ( 'J' )                                     ! first ice U-V point 
    268             DO jl =0, ipr2dj 
    269                pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl) 
    270                DO ji = 3, jpiglo 
    271                   iju = jpiglo - ji + 3 
    272                   pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl) 
    273                END DO 
    274             END DO 
    275          CASE ( 'K' )                                     ! second ice U-V point 
    276             DO jl =0, ipr2dj 
    277                pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl) 
    278                DO ji = 3, jpiglo 
    279                   iju = jpiglo - ji + 3 
    280                   pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl) 
    281                END DO 
    282             END DO 
    283262         END SELECT 
    284263         ! 
     
    325304            END DO 
    326305         CASE ( 'I' )                                  ! ice U-V point (I-point) 
    327             pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0 
     306            pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0._wp 
    328307            DO jl = 0, ipr2dj 
    329308               DO ji = 2 , jpiglo-1 
     
    332311               END DO 
    333312            END DO 
    334          CASE ( 'J' )                                  ! first ice U-V point 
    335             pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0 
    336             DO jl = 0, ipr2dj 
    337                DO ji = 2 , jpiglo-1 
    338                   ijt = jpiglo - ji + 2 
    339                   pt2d(ji,ijpj+jl)= pt2d(ji,ijpj-1-jl) 
    340                END DO 
    341             END DO 
    342          CASE ( 'K' )                                  ! second ice U-V point 
    343             pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0 
    344             DO jl = 0, ipr2dj 
    345                DO ji = 2 , jpiglo-1 
    346                   ijt = jpiglo - ji + 2 
    347                   pt2d(ji,ijpj+jl)= pt2d(ijt,ijpj-1-jl) 
    348                END DO 
    349             END DO 
    350313         END SELECT 
    351314         ! 
     
    354317         SELECT CASE ( cd_type) 
    355318         CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points 
    356             pt2d(:, 1:1-ipr2dj     ) = 0.e0 
    357             pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 
     319            pt2d(:, 1:1-ipr2dj     ) = 0._wp 
     320            pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp 
    358321         CASE ( 'F' )                                   ! F-point 
    359             pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 
     322            pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp 
    360323         CASE ( 'I' )                                   ! ice U-V point 
    361             pt2d(:, 1:1-ipr2dj     ) = 0.e0 
    362             pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 
    363          CASE ( 'J' )                                   ! first ice U-V point 
    364             pt2d(:, 1:1-ipr2dj     ) = 0.e0 
    365             pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 
    366          CASE ( 'K' )                                   ! second ice U-V point 
    367             pt2d(:, 1:1-ipr2dj     ) = 0.e0 
    368             pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 
     324            pt2d(:, 1:1-ipr2dj     ) = 0._wp 
     325            pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp 
    369326         END SELECT 
    370327         ! 
     
    385342      !! ** Action  :   pt3d with updated values along the north fold 
    386343      !!---------------------------------------------------------------------- 
    387       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! define the nature of ptab array grid-points 
    388       !                                                        !   = T , U , V , F , W points 
    389       REAL(wp)                  , INTENT(in   ) ::   psgn      ! control of the sign change 
    390       !                                                        !   = -1. , the sign is changed if north fold boundary 
    391       !                                                        !   =  1. , the sign is kept    if north fold boundary 
    392344      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3dl     ! 3D array on which the boundary condition is applied 
    393345      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pt3dr     ! 3D array on which the boundary condition is applied 
    394       ! 
    395       INTEGER  ::   ji, jk 
     346      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d(l/r) grid-point 
     347      REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across north fold 
     348      ! 
     349      INTEGER  ::   ji, jk      ! dummy loop indices 
     350      INTEGER  ::   ipk         ! 3rd dimension of the input array 
    396351      INTEGER  ::   ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 
    397352      !!---------------------------------------------------------------------- 
     353      ! 
     354      ipk = SIZE( pt3dl, 3 ) 
    398355      ! 
    399356      SELECT CASE ( jpni ) 
     
    402359      END SELECT 
    403360      ijpjm1 = ijpj-1 
    404  
    405          ! 
    406          SELECT CASE ( npolj ) 
    407          ! 
    408          CASE ( 3 , 4 )                        ! *  North fold  T-point pivot 
    409             ! 
    410             SELECT CASE ( cd_type ) 
     361      ! 
     362      ! 
     363      SELECT CASE ( npolj ) 
     364      ! 
     365      CASE ( 3 , 4 )                        ! *  North fold  T-point pivot 
     366         ! 
     367         SELECT CASE ( cd_type ) 
    411368            CASE ( 'T' , 'W' )                         ! T-, W-point 
    412                IF (nimpp .ne. 1) THEN 
    413                  startloop = 1 
    414                ELSE 
    415                  startloop = 2 
    416                ENDIF 
    417  
    418                DO jk = 1, jpk 
     369               IF ( nimpp /= 1 ) THEN   ;   startloop = 1 
     370               ELSE                     ;   startloop = 2 
     371               ENDIF 
     372               ! 
     373               DO jk = 1, ipk 
    419374                  DO ji = startloop, nlci 
    420375                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
     
    426381               END DO 
    427382 
    428                IF(nimpp .ge. (jpiglo/2+1)) THEN 
     383               IF( nimpp >= jpiglo/2+1 ) THEN 
    429384                 startloop = 1 
    430                ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
     385               ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    431386                 startloop = jpiglo/2+1 - nimpp + 1 
    432387               ELSE 
    433388                 startloop = nlci + 1 
    434389               ENDIF 
    435                IF(startloop .le. nlci) THEN 
    436                  DO jk = 1, jpk 
     390               IF(startloop <= nlci) THEN 
     391                 DO jk = 1, ipk 
    437392                    DO ji = startloop, nlci 
    438393                       ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    439394                       jia = ji + nimpp - 1 
    440395                       ijta = jpiglo - jia + 2 
    441                        IF((ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN 
     396                       IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 
    442397                          pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijta-nimpp+1,ijpjm1,jk) 
    443398                       ELSE 
     
    447402                 END DO 
    448403               ENDIF 
    449  
    450  
     404               ! 
    451405            CASE ( 'U' )                               ! U-point 
    452                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
     406               IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    453407                  endloop = nlci 
    454408               ELSE 
    455409                  endloop = nlci - 1 
    456410               ENDIF 
    457                DO jk = 1, jpk 
     411               DO jk = 1, ipk 
    458412                  DO ji = 1, endloop 
    459413                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     
    467421                  ENDIF 
    468422               END DO 
    469  
    470                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
     423               ! 
     424               IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    471425                  endloop = nlci 
    472426               ELSE 
    473427                  endloop = nlci - 1 
    474428               ENDIF 
    475                IF(nimpp .ge. (jpiglo/2)) THEN 
     429               IF( nimpp >= jpiglo/2 ) THEN 
    476430                  startloop = 1 
    477                ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN 
     431               ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN 
    478432                  startloop = jpiglo/2 - nimpp + 1 
    479433               ELSE 
    480434                  startloop = endloop + 1 
    481435               ENDIF 
    482                IF (startloop .le. endloop) THEN 
    483                  DO jk = 1, jpk 
     436               IF( startloop <= endloop ) THEN 
     437                 DO jk = 1, ipk 
    484438                    DO ji = startloop, endloop 
    485439                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    486440                      jia = ji + nimpp - 1 
    487441                      ijua = jpiglo - jia + 1 
    488                       IF((ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN 
     442                      IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 
    489443                        pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijua-nimpp+1,ijpjm1,jk) 
    490444                      ELSE 
     
    494448                 END DO 
    495449               ENDIF 
    496  
     450               ! 
    497451            CASE ( 'V' )                               ! V-point 
    498                IF (nimpp .ne. 1) THEN 
     452               IF( nimpp /= 1 ) THEN 
    499453                  startloop = 1 
    500454               ELSE 
    501455                  startloop = 2 
    502456               ENDIF 
    503                DO jk = 1, jpk 
     457               DO jk = 1, ipk 
    504458                  DO ji = startloop, nlci 
    505459                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
     
    512466               END DO 
    513467            CASE ( 'F' )                               ! F-point 
    514                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
     468               IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    515469                  endloop = nlci 
    516470               ELSE 
    517471                  endloop = nlci - 1 
    518472               ENDIF 
    519                DO jk = 1, jpk 
     473               DO jk = 1, ipk 
    520474                  DO ji = 1, endloop 
    521475                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     
    530484                  ENDIF 
    531485               END DO 
    532             END SELECT 
    533             ! 
    534  
    535          CASE ( 5 , 6 )                        ! *  North fold  F-point pivot 
    536             ! 
    537             SELECT CASE ( cd_type ) 
     486         END SELECT 
     487         ! 
     488      CASE ( 5 , 6 )                        ! *  North fold  F-point pivot 
     489         ! 
     490         SELECT CASE ( cd_type ) 
    538491            CASE ( 'T' , 'W' )                         ! T-, W-point 
    539                DO jk = 1, jpk 
     492               DO jk = 1, ipk 
    540493                  DO ji = 1, nlci 
    541494                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     
    543496                  END DO 
    544497               END DO 
    545  
     498               ! 
    546499            CASE ( 'U' )                               ! U-point 
    547                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
     500               IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    548501                  endloop = nlci 
    549502               ELSE 
    550503                  endloop = nlci - 1 
    551504               ENDIF 
    552                DO jk = 1, jpk 
     505               DO jk = 1, ipk 
    553506                  DO ji = 1, endloop 
    554507                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
     
    559512                  ENDIF 
    560513               END DO 
    561  
     514               ! 
    562515            CASE ( 'V' )                               ! V-point 
    563                DO jk = 1, jpk 
     516               DO jk = 1, ipk 
    564517                  DO ji = 1, nlci 
    565518                     ijt = jpiglo - ji- nimpp - nfiimpp(isendto(1),jpnj) + 3 
     
    567520                  END DO 
    568521               END DO 
    569  
    570                IF(nimpp .ge. (jpiglo/2+1)) THEN 
     522               ! 
     523               IF( nimpp >= jpiglo/2+1 ) THEN 
    571524                  startloop = 1 
    572                ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
     525               ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    573526                  startloop = jpiglo/2+1 - nimpp + 1 
    574527               ELSE 
    575528                  startloop = nlci + 1 
    576529               ENDIF 
    577                IF(startloop .le. nlci) THEN 
    578                  DO jk = 1, jpk 
     530               IF( startloop <= nlci ) THEN 
     531                 DO jk = 1, ipk 
    579532                    DO ji = startloop, nlci 
    580533                       ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     
    583536                 END DO 
    584537               ENDIF 
    585  
     538               ! 
    586539            CASE ( 'F' )                               ! F-point 
    587                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
     540               IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    588541                  endloop = nlci 
    589542               ELSE 
    590543                  endloop = nlci - 1 
    591544               ENDIF 
    592                DO jk = 1, jpk 
     545               DO jk = 1, ipk 
    593546                  DO ji = 1, endloop 
    594547                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
     
    599552                  ENDIF 
    600553               END DO 
    601  
    602                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
     554               ! 
     555               IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    603556                  endloop = nlci 
    604557               ELSE 
    605558                  endloop = nlci - 1 
    606559               ENDIF 
    607                IF(nimpp .ge. (jpiglo/2+1)) THEN 
     560               IF( nimpp >= jpiglo/2+1 ) THEN 
    608561                  startloop = 1 
    609                ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
     562               ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    610563                  startloop = jpiglo/2+1 - nimpp + 1 
    611564               ELSE 
    612565                  startloop = endloop + 1 
    613566               ENDIF 
    614                IF (startloop .le. endloop) THEN 
    615                   DO jk = 1, jpk 
     567               IF( startloop <= endloop ) THEN 
     568                  DO jk = 1, ipk 
    616569                     DO ji = startloop, endloop 
    617570                        iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
     
    620573                  END DO 
    621574               ENDIF 
    622  
    623             END SELECT 
    624  
    625          CASE DEFAULT                           ! *  closed : the code probably never go through 
    626             ! 
    627             SELECT CASE ( cd_type) 
     575               ! 
     576         END SELECT 
     577         ! 
     578      CASE DEFAULT                           ! *  closed : the code probably never go through 
     579         ! 
     580         SELECT CASE ( cd_type) 
    628581            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    629                pt3dl(:, 1  ,jk) = 0.e0 
    630                pt3dl(:,ijpj,jk) = 0.e0 
     582               pt3dl(:, 1  ,jk) = 0._wp 
     583               pt3dl(:,ijpj,jk) = 0._wp 
    631584            CASE ( 'F' )                               ! F-point 
    632                pt3dl(:,ijpj,jk) = 0.e0 
    633             END SELECT 
    634             ! 
    635          END SELECT     !  npolj 
    636          ! 
     585               pt3dl(:,ijpj,jk) = 0._wp 
     586         END SELECT 
     587         ! 
     588      END SELECT     !  npolj 
    637589      ! 
    638590   END SUBROUTINE mpp_lbc_nfd_3d 
     
    644596      !! 
    645597      !! ** Purpose :   2D lateral boundary condition : North fold treatment 
    646       !!       without processor exchanges.  
     598      !!              without processor exchanges.  
    647599      !! 
    648600      !! ** Method  :    
    649601      !! 
    650       !! ** Action  :   pt2d with updated values along the north fold 
    651       !!---------------------------------------------------------------------- 
    652       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! define the nature of ptab array grid-points 
    653       !                                                      ! = T , U , V , F , W points 
    654       REAL(wp)                , INTENT(in   ) ::   psgn      ! control of the sign change 
    655       !                                                      !   = -1. , the sign is changed if north fold boundary 
    656       !                                                      !   =  1. , the sign is kept  if north fold boundary 
     602      !! ** Action  :   pt2dl with updated values along the north fold 
     603      !!---------------------------------------------------------------------- 
    657604      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2dl     ! 2D array on which the boundary condition is applied 
    658605      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   pt2dr     ! 2D array on which the boundary condition is applied 
     606      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt3d(l/r) grid-point 
     607      REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold 
    659608      ! 
    660609      INTEGER  ::   ji 
     
    668617      ! 
    669618      ijpjm1 = ijpj-1 
    670  
    671  
     619      ! 
     620      ! 
    672621      SELECT CASE ( npolj ) 
    673622      ! 
     
    677626         ! 
    678627         CASE ( 'T' , 'W' )                               ! T- , W-points 
    679             IF (nimpp .ne. 1) THEN 
     628            IF( nimpp /= 1 ) THEN 
    680629              startloop = 1 
    681630            ELSE 
     
    686635              pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 
    687636            END DO 
    688             IF (nimpp .eq. 1) THEN 
    689               pt2dl(1,ijpj)   = psgn * pt2dl(3,ijpj-2) 
    690             ENDIF 
    691  
    692             IF(nimpp .ge. (jpiglo/2+1)) THEN 
     637            IF( nimpp == 1 ) THEN 
     638              pt2dl(1,ijpj) = psgn * pt2dl(3,ijpj-2) 
     639            ENDIF 
     640            ! 
     641            IF( nimpp >= jpiglo/2+1 ) THEN 
    693642               startloop = 1 
    694             ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
     643            ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    695644               startloop = jpiglo/2+1 - nimpp + 1 
    696645            ELSE 
     
    698647            ENDIF 
    699648            DO ji = startloop, nlci 
    700                ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
     649               ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    701650               jia = ji + nimpp - 1 
    702651               ijta = jpiglo - jia + 2 
    703                IF((ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN 
     652               IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 
    704653                  pt2dl(ji,ijpjm1) = psgn * pt2dl(ijta-nimpp+1,ijpjm1) 
    705654               ELSE 
     
    707656               ENDIF 
    708657            END DO 
    709  
     658            ! 
    710659         CASE ( 'U' )                                     ! U-point 
    711             IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
     660            IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    712661               endloop = nlci 
    713662            ELSE 
     
    718667               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 
    719668            END DO 
    720  
     669            ! 
    721670            IF (nimpp .eq. 1) THEN 
    722671              pt2dl(   1  ,ijpj  ) = psgn * pt2dl(    2   ,ijpj-2) 
     
    726675              pt2dl(nlci,ijpj  ) = psgn * pt2dl(nlci-1,ijpj-2) 
    727676            ENDIF 
    728  
    729             IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
     677            ! 
     678            IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    730679               endloop = nlci 
    731680            ELSE 
    732681               endloop = nlci - 1 
    733682            ENDIF 
    734             IF(nimpp .ge. (jpiglo/2)) THEN 
     683            IF( nimpp >= jpiglo/2 ) THEN 
    735684               startloop = 1 
    736             ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN 
     685            ELSEIF( nimpp+nlci-1 >= jpiglo/2 .AND. nimpp < jpiglo/2 ) THEN 
    737686               startloop = jpiglo/2 - nimpp + 1 
    738687            ELSE 
     
    743692               jia = ji + nimpp - 1 
    744693               ijua = jpiglo - jia + 1 
    745                IF((ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN 
     694               IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 
    746695                  pt2dl(ji,ijpjm1) = psgn * pt2dl(ijua-nimpp+1,ijpjm1) 
    747696               ELSE 
     
    749698               ENDIF 
    750699            END DO 
    751  
     700            ! 
    752701         CASE ( 'V' )                                     ! V-point 
    753             IF (nimpp .ne. 1) THEN 
     702            IF( nimpp /= 1 ) THEN 
    754703              startloop = 1 
    755704            ELSE 
     
    764713              pt2dl( 1 ,ijpj)   = psgn * pt2dl( 3 ,ijpj-3)  
    765714            ENDIF 
    766  
     715            ! 
    767716         CASE ( 'F' )                                     ! F-point 
    768             IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
     717            IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    769718               endloop = nlci 
    770719            ELSE 
     
    784733              pt2dl(nlci,ijpj-1) = psgn * pt2dl(nlci-1,ijpj-2)  
    785734            ENDIF 
    786  
     735            ! 
    787736         CASE ( 'I' )                                     ! ice U-V point (I-point) 
    788             IF (nimpp .ne. 1) THEN 
     737            IF( nimpp /= 1 ) THEN 
    789738               startloop = 1 
    790739            ELSE 
     
    796745               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
    797746            END DO 
    798  
    799          CASE ( 'J' )                                     ! first ice U-V point 
    800             IF (nimpp .ne. 1) THEN 
    801                startloop = 1 
    802             ELSE 
    803                startloop = 3 
    804                pt2dl(2,ijpj) = psgn * pt2dl(3,ijpjm1) 
    805             ENDIF 
    806             DO ji = startloop, nlci 
    807                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 
    808                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
    809             END DO 
    810  
    811          CASE ( 'K' )                                     ! second ice U-V point 
    812             IF (nimpp .ne. 1) THEN 
    813                startloop = 1 
    814             ELSE 
    815                startloop = 3 
    816                pt2dl(2,ijpj) = psgn * pt2dl(3,ijpjm1) 
    817             ENDIF 
    818             DO ji = startloop, nlci 
    819                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 
    820                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
    821             END DO 
    822  
     747            ! 
    823748         END SELECT 
    824749         ! 
     
    831756               pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1) 
    832757            END DO 
    833  
     758            ! 
    834759         CASE ( 'U' )                                     ! U-point 
    835             IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
     760            IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    836761               endloop = nlci 
    837762            ELSE 
     
    845770               pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-1) 
    846771            ENDIF 
    847  
     772            ! 
    848773         CASE ( 'V' )                                     ! V-point 
    849774            DO ji = 1, nlci 
     
    851776               pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 
    852777            END DO 
    853             IF(nimpp .ge. (jpiglo/2+1)) THEN 
     778            IF( nimpp >= jpiglo/2+1 ) THEN 
    854779               startloop = 1 
    855             ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
     780            ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    856781               startloop = jpiglo/2+1 - nimpp + 1 
    857782            ELSE 
     
    862787               pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 
    863788            END DO 
    864  
     789            ! 
    865790         CASE ( 'F' )                               ! F-point 
    866             IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
     791            IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    867792               endloop = nlci 
    868793            ELSE 
     
    876801                pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-2) 
    877802            ENDIF 
    878  
    879             IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
     803            ! 
     804            IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    880805               endloop = nlci 
    881806            ELSE 
    882807               endloop = nlci - 1 
    883808            ENDIF 
    884             IF(nimpp .ge. (jpiglo/2+1)) THEN 
     809            IF( nimpp >= jpiglo/2+1 ) THEN 
    885810               startloop = 1 
    886             ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
     811            ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    887812               startloop = jpiglo/2+1 - nimpp + 1 
    888813            ELSE 
    889814               startloop = endloop + 1 
    890815            ENDIF 
    891  
     816            ! 
    892817            DO ji = startloop, endloop 
    893818               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    894819               pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 
    895820            END DO 
    896  
     821            ! 
    897822         CASE ( 'I' )                                  ! ice U-V point (I-point) 
    898                IF (nimpp .ne. 1) THEN 
     823               IF( nimpp /= 1 ) THEN 
    899824                  startloop = 1 
    900825               ELSE 
    901826                  startloop = 2 
    902827               ENDIF 
    903                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
     828               IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    904829                  endloop = nlci 
    905830               ELSE 
     
    908833               DO ji = startloop , endloop 
    909834                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    910                   pt2dl(ji,ijpj)= 0.5 * (pt2dl(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 
    911                END DO 
    912  
    913          CASE ( 'J' )                                  ! first ice U-V point 
    914                IF (nimpp .ne. 1) THEN 
    915                   startloop = 1 
    916                ELSE 
    917                   startloop = 2 
    918                ENDIF 
    919                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    920                   endloop = nlci 
    921                ELSE 
    922                   endloop = nlci - 1 
    923                ENDIF 
    924                DO ji = startloop , endloop 
    925                   ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    926                   pt2dl(ji,ijpj) = pt2dl(ji,ijpjm1) 
    927                END DO 
    928  
    929          CASE ( 'K' )                                  ! second ice U-V point 
    930                IF (nimpp .ne. 1) THEN 
    931                   startloop = 1 
    932                ELSE 
    933                   startloop = 2 
    934                ENDIF 
    935                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    936                   endloop = nlci 
    937                ELSE 
    938                   endloop = nlci - 1 
    939                ENDIF 
    940                DO ji = startloop, endloop 
    941                   ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    942                   pt2dl(ji,ijpj) = pt2dr(ijt,ijpjm1) 
    943                END DO 
    944  
     835                  pt2dl(ji,ijpj) = 0.5 * (pt2dl(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 
     836               END DO 
     837               ! 
    945838         END SELECT 
    946839         ! 
     
    949842         SELECT CASE ( cd_type) 
    950843         CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points 
    951             pt2dl(:, 1     ) = 0.e0 
    952             pt2dl(:,ijpj) = 0.e0 
     844            pt2dl(:, 1  ) = 0._wp 
     845            pt2dl(:,ijpj) = 0._wp 
    953846         CASE ( 'F' )                                   ! F-point 
    954             pt2dl(:,ijpj) = 0.e0 
     847            pt2dl(:,ijpj) = 0._wp 
    955848         CASE ( 'I' )                                   ! ice U-V point 
    956             pt2dl(:, 1     ) = 0.e0 
    957             pt2dl(:,ijpj) = 0.e0 
    958          CASE ( 'J' )                                   ! first ice U-V point 
    959             pt2dl(:, 1     ) = 0.e0 
    960             pt2dl(:,ijpj) = 0.e0 
    961          CASE ( 'K' )                                   ! second ice U-V point 
    962             pt2dl(:, 1     ) = 0.e0 
    963             pt2dl(:,ijpj) = 0.e0 
     849            pt2dl(:, 1  ) = 0._wp 
     850            pt2dl(:,ijpj) = 0._wp 
    964851         END SELECT 
    965852         ! 
  • branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r7753 r7904  
    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      ELSEIF ( 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 pt2d array grid-points 
     762      REAL(wp)                                , INTENT(in   ) ::   psgn         ! sign used across the north fold boundary 
     763      TYPE(arrayptr)  , DIMENSION(:)          , INTENT(inout) ::   pt2d_array   !  
     764      CHARACTER(len=1), DIMENSION(:)          , INTENT(inout) ::   type_array   ! nature of pt2d_array array grid-points 
     765      REAL(wp)        , DIMENSION(:)          , INTENT(inout) ::   psgn_array   ! sign used across the north fold boundary 
     766      INTEGER                                 , INTENT(inout) ::   kfld         ! 
     767      !!--------------------------------------------------------------------- 
     768      ! 
     769      kfld                  =  kfld + 1 
     770      pt2d_array(kfld)%pt2d => pt2d 
     771      type_array(kfld)      =  cd_type 
     772      psgn_array(kfld)      =  psgn 
     773      ! 
     774   END SUBROUTINE load_array 
     775    
     776    
     777   SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
     778      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
     779      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
     780      !!--------------------------------------------------------------------- 
     781      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA    ! 2D arrays on which the lbc is applied 
     782      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
     783      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI  
     784      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA ! nature of pt2D. array grid-points 
     785      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
     786      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
     787      REAL(wp)                                      , INTENT(in   ) ::   psgnA    ! sign used across the north fold 
     788      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
     789      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI    
     790      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     791      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     792      !! 
     793      INTEGER :: kfld 
     794      TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array  
     795      CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of pt2d array grid-points 
     796      REAL(wp)         , DIMENSION(9) ::   psgn_array    ! sign used across the north fold boundary 
     797      !!--------------------------------------------------------------------- 
     798      ! 
     799      kfld = 0 
     800      ! 
     801      !                 ! Load the first array 
     802      CALL load_array( pt2dA, cd_typeA, psgnA, pt2d_array, type_array, psgn_array, kfld ) 
     803      ! 
     804      !                 ! Look if more arrays are added 
     805      IF( PRESENT(psgnB) )   CALL load_array( pt2dB, cd_typeB, psgnB, pt2d_array, type_array, psgn_array, kfld ) 
     806      IF( PRESENT(psgnC) )   CALL load_array( pt2dC, cd_typeC, psgnC, pt2d_array, type_array, psgn_array, kfld ) 
     807      IF( PRESENT(psgnD) )   CALL load_array( pt2dD, cd_typeD, psgnD, pt2d_array, type_array, psgn_array, kfld ) 
     808      IF( PRESENT(psgnE) )   CALL load_array( pt2dE, cd_typeE, psgnE, pt2d_array, type_array, psgn_array, kfld ) 
     809      IF( PRESENT(psgnF) )   CALL load_array( pt2dF, cd_typeF, psgnF, pt2d_array, type_array, psgn_array, kfld ) 
     810      IF( PRESENT(psgnG) )   CALL load_array( pt2dG, cd_typeG, psgnG, pt2d_array, type_array, psgn_array, kfld ) 
     811      IF( PRESENT(psgnH) )   CALL load_array( pt2dH, cd_typeH, psgnH, pt2d_array, type_array, psgn_array, kfld ) 
     812      IF( PRESENT(psgnI) )   CALL load_array( pt2dI, cd_typeI, psgnI, pt2d_array, type_array, psgn_array, kfld ) 
     813      ! 
     814      CALL mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, kfld, cd_mpp,pval ) 
     815      ! 
     816   END SUBROUTINE mpp_lnk_2d_9 
     817 
     818 
     819   SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
     820      !!---------------------------------------------------------------------- 
     821      !!                  ***  routine mpp_lnk_2d  *** 
     822      !! 
     823      !! ** Purpose :   Message passing manadgement for 2d array 
    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 pt2d array grid-points 
     840      REAL(wp)                    , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
     841      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     842      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    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 
    2018       !! 
    2019       !!---------------------------------------------------------------------- 
    2020       INTEGER , INTENT(in   )                  ::   kdim 
    2021       REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab 
    2022       INTEGER , INTENT(in   ), OPTIONAL        ::   kcom 
     1988      !! ** Purpose :   Maximum of a 1D array 
     1989      !! 
     1990      !!---------------------------------------------------------------------- 
     1991      REAL(wp), DIMENSION(kdim), INTENT(inout) ::   ptab 
     1992      INTEGER                  , INTENT(in   ) ::   kdim 
     1993      INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom 
    20231994      ! 
    20241995      INTEGER :: ierror, localcomm 
     
    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      REAL(wp), DIMENSION(kdim) ::  zwork 
     2044      !!---------------------------------------------------------------------- 
     2045      ! 
    20752046      localcomm = mpi_comm_opa 
    20762047      IF( PRESENT(kcom) )   localcomm = kcom 
    20772048      ! 
    2078       CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 
    2079       ptab = zwork 
    2080       CALL wrk_dealloc(NUM , zwork) 
     2049      CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror ) 
     2050      pt1d(:) = zwork(:) 
    20812051      ! 
    20822052   END SUBROUTINE mppmax_real_multiple 
     
    22432213      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask   ! Local mask 
    22442214      REAL(wp)                     , INTENT(  out) ::   pmin    ! Global minimum of ptab 
    2245       INTEGER                      , INTENT(  out) ::   ki, kj   ! index of minimum in global frame 
     2215      INTEGER                      , INTENT(  out) ::   ki, kj  ! index of minimum in global frame 
    22462216      ! 
    22472217      INTEGER :: ierror 
     
    22512221      !!----------------------------------------------------------------------- 
    22522222      ! 
    2253       zmin  = MINVAL( ptab(:,:) , mask= pmask == 1.e0 ) 
    2254       ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 ) 
     2223      zmin  = MINVAL( ptab(:,:) , mask= pmask == 1._wp ) 
     2224      ilocs = MINLOC( ptab(:,:) , mask= pmask == 1._wp ) 
    22552225      ! 
    22562226      ki = ilocs(1) + nimpp - 1 
     
    22792249      !! 
    22802250      !!-------------------------------------------------------------------------- 
    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       !! 
     2251      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   ptab         ! Local 2D array 
     2252      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pmask        ! Local mask 
     2253      REAL(wp)                  , INTENT(  out) ::   pmin         ! Global minimum of ptab 
     2254      INTEGER                   , INTENT(  out) ::   ki, kj, kk   ! index of minimum in global frame 
     2255      ! 
    22862256      INTEGER  ::   ierror 
    22872257      REAL(wp) ::   zmin     ! local minimum 
     
    22902260      !!----------------------------------------------------------------------- 
    22912261      ! 
    2292       zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 ) 
    2293       ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 ) 
     2262      zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1._wp ) 
     2263      ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1._wp ) 
    22942264      ! 
    22952265      ki = ilocs(1) + nimpp - 1 
     
    22972267      kk = ilocs(3) 
    22982268      ! 
    2299       zain(1,:)=zmin 
    2300       zain(2,:)=ki+10000.*kj+100000000.*kk 
     2269      zain(1,:) = zmin 
     2270      zain(2,:) = ki + 10000.*kj + 100000000.*kk 
    23012271      ! 
    23022272      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror) 
     
    23312301      !!----------------------------------------------------------------------- 
    23322302      ! 
    2333       zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 ) 
    2334       ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 ) 
     2303      zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1._wp ) 
     2304      ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1._wp ) 
    23352305      ! 
    23362306      ki = ilocs(1) + nimpp - 1 
     
    23592329      !! 
    23602330      !!-------------------------------------------------------------------------- 
    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 
     2331      REAL(wp), DIMENSION (:,:,:), INTENT(in   ) ::   ptab         ! Local 2D array 
     2332      REAL(wp), DIMENSION (:,:,:), INTENT(in   ) ::   pmask        ! Local mask 
     2333      REAL(wp)                   , INTENT(  out) ::   pmax         ! Global maximum of ptab 
     2334      INTEGER                    , INTENT(  out) ::   ki, kj, kk   ! index of maximum in global frame 
     2335      ! 
     2336      INTEGER  ::   ierror   ! local integer 
     2337      REAL(wp) ::   zmax     ! local maximum 
    23672338      REAL(wp), DIMENSION(2,1) ::   zain, zaout 
    23682339      INTEGER , DIMENSION(3)   ::   ilocs 
    2369       INTEGER :: ierror 
    23702340      !!----------------------------------------------------------------------- 
    23712341      ! 
    2372       zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 ) 
    2373       ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 ) 
     2342      zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1._wp ) 
     2343      ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1._wp ) 
    23742344      ! 
    23752345      ki = ilocs(1) + nimpp - 1 
     
    23772347      kk = ilocs(3) 
    23782348      ! 
    2379       zain(1,:)=zmax 
    2380       zain(2,:)=ki+10000.*kj+100000000.*kk 
     2349      zain(1,:) = zmax 
     2350      zain(2,:) = ki + 10000.*kj + 100000000.*kk 
    23812351      ! 
    23822352      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror) 
     
    24222392 
    24232393   SUBROUTINE mpp_comm_free( kcom ) 
    2424       !!---------------------------------------------------------------------- 
    24252394      !!---------------------------------------------------------------------- 
    24262395      INTEGER, INTENT(in) ::   kcom 
     
    26922661      !!              and apply lbc north-fold on this sub array. Then we 
    26932662      !!              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 
     2663      !!---------------------------------------------------------------------- 
     2664      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the b.c. is applied 
     2665      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
     2666      REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across the north fold 
     2667      ! 
    27012668      INTEGER ::   ji, jj, jr, jk 
     2669      INTEGER ::   ipk                  ! 3rd dimension of the input array 
    27022670      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    27032671      INTEGER ::   ijpj, ijpjm1, ij, iproc 
     
    27152683      !!---------------------------------------------------------------------- 
    27162684      ! 
    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) )  
     2685      ipk = SIZE( pt3d, 3 ) 
     2686      ! 
     2687      ALLOCATE( ztab (jpiglo,4,ipk), znorthloc(jpi,4,ipk), zfoldwk(jpi,4,ipk), znorthgloio(jpi,4,ipk,jpni) ) 
     2688      ALLOCATE( ztabl(jpi   ,4,ipk), ztabr(jpi*jpmaxngh,4,ipk)   )  
    27192689 
    27202690      ijpj   = 4 
    27212691      ijpjm1 = 3 
    27222692      ! 
    2723       znorthloc(:,:,:) = 0 
    2724       DO jk = 1, jpk 
     2693      znorthloc(:,:,:) = 0._wp 
     2694      DO jk = 1, ipk 
    27252695         DO jj = nlcj - ijpj +1, nlcj          ! put in xnorthloc the last 4 jlines of pt3d 
    27262696            ij = jj - nlcj + ijpj 
     
    27302700      ! 
    27312701      !                                     ! Build in procs of ncomm_north the znorthgloio 
    2732       itaille = jpi * jpk * ijpj 
     2702      itaille = jpi * ipk * ijpj 
    27332703 
    27342704      IF ( l_north_nogather ) THEN 
    27352705         ! 
    2736         ztabr(:,:,:) = 0 
    2737         ztabl(:,:,:) = 0 
    2738  
    2739         DO jk = 1, jpk 
     2706        ztabr(:,:,:) = 0._wp 
     2707        ztabl(:,:,:) = 0._wp 
     2708 
     2709        DO jk = 1, ipk 
    27402710           DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
    27412711              ij = jj - nlcj + ijpj 
     
    27472717 
    27482718         DO jr = 1,nsndto 
    2749             IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2719            IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    27502720              CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 
    27512721            ENDIF 
     
    27532723         DO jr = 1,nsndto 
    27542724            iproc = nfipproc(isendto(jr),jpnj) 
    2755             IF(iproc .ne. -1) THEN 
     2725            IF(iproc /= -1) THEN 
    27562726               ilei = nleit (iproc+1) 
    27572727               ildi = nldit (iproc+1) 
    27582728               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
    27592729            ENDIF 
    2760             IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
     2730            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
    27612731              CALL mpprecv(5, zfoldwk, itaille, iproc) 
    2762               DO jk = 1, jpk 
     2732              DO jk = 1, ipk 
    27632733                 DO jj = 1, ijpj 
    27642734                    DO ji = ildi, ilei 
     
    27672737                 END DO 
    27682738              END DO 
    2769            ELSE IF (iproc .eq. (narea-1)) THEN 
    2770               DO jk = 1, jpk 
     2739           ELSE IF( iproc == narea-1 ) THEN 
     2740              DO jk = 1, ipk 
    27712741                 DO jj = 1, ijpj 
    27722742                    DO ji = ildi, ilei 
     
    27792749         IF (l_isend) THEN 
    27802750            DO jr = 1,nsndto 
    2781                IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
    2782                   CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     2751               IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
     2752                  CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 
    27832753               ENDIF     
    27842754            END DO 
    27852755         ENDIF 
    27862756         CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition 
    2787          DO jk = 1, jpk 
     2757         DO jk = 1, ipk 
    27882758            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d 
    27892759               ij = jj - nlcj + ijpj 
     
    27942764         END DO 
    27952765         ! 
    2796  
    27972766      ELSE 
    27982767         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                & 
    27992768            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    28002769         ! 
    2801          ztab(:,:,:) = 0.e0 
     2770         ztab(:,:,:) = 0._wp 
    28022771         DO jr = 1, ndim_rank_north         ! recover the global north array 
    28032772            iproc = nrank_north(jr) + 1 
     
    28052774            ilei  = nleit (iproc) 
    28062775            iilb  = nimppt(iproc) 
    2807             DO jk = 1, jpk 
     2776            DO jk = 1, ipk 
    28082777               DO jj = 1, ijpj 
    28092778                  DO ji = ildi, ilei 
     
    28152784         CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition 
    28162785         ! 
    2817          DO jk = 1, jpk 
     2786         DO jk = 1, ipk 
    28182787            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d 
    28192788               ij = jj - nlcj + ijpj 
     
    29022871 
    29032872         DO jr = 1,nsndto 
    2904             IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
    2905                CALL mppsend(5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) 
     2873            IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
     2874               CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 
    29062875            ENDIF 
    29072876         END DO 
    29082877         DO jr = 1,nsndto 
    29092878            iproc = nfipproc(isendto(jr),jpnj) 
    2910             IF(iproc .ne. -1) THEN 
     2879            IF( iproc /= -1 ) THEN 
    29112880               ilei = nleit (iproc+1) 
    29122881               ildi = nldit (iproc+1) 
    29132882               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
    29142883            ENDIF 
    2915             IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
     2884            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
    29162885              CALL mpprecv(5, zfoldwk, itaille, iproc) 
    29172886              DO jj = 1, ijpj 
     
    29202889                 END DO 
    29212890              END DO 
    2922             ELSE IF (iproc .eq. (narea-1)) THEN 
     2891            ELSEIF( iproc == narea-1 ) THEN 
    29232892              DO jj = 1, ijpj 
    29242893                 DO ji = ildi, ilei 
     
    29282897            ENDIF 
    29292898         END DO 
    2930          IF (l_isend) THEN 
     2899         IF(l_isend) THEN 
    29312900            DO jr = 1,nsndto 
    2932                IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2901               IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    29332902                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
    29342903               ENDIF 
     
    29482917            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    29492918         ! 
    2950          ztab(:,:) = 0.e0 
     2919         ztab(:,:) = 0._wp 
    29512920         DO jr = 1, ndim_rank_north            ! recover the global north array 
    29522921            iproc = nrank_north(jr) + 1 
     
    29752944   END SUBROUTINE mpp_lbc_north_2d 
    29762945 
    2977    SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 
     2946 
     2947   SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, kfld ) 
    29782948      !!--------------------------------------------------------------------- 
    29792949      !!                   ***  routine mpp_lbc_north_2d  *** 
     
    29902960      !! 
    29912961      !!---------------------------------------------------------------------- 
    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 
     2962      TYPE( arrayptr ), DIMENSION(:), INTENT(inout) ::   pt2d_array   ! pointer array of 2D fields 
     2963      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type      ! nature of pt2d grid-points 
     2964      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn         ! sign used across the north fold  
     2965      INTEGER                       , INTENT(in   ) ::   kfld         ! number of variables contained in pt2d 
     2966      ! 
    29982967      INTEGER ::   ji, jj, jr, jk 
    29992968      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 
     2969      INTEGER ::   ijpj, ijpjm1, ij, iproc, iflag 
     2970      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf   ! for mpi_isend when avoiding mpi_allgather 
     2971      INTEGER                            ::   ml_err      ! for mpi_isend when avoiding mpi_allgather 
     2972      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat     ! for mpi_isend when avoiding mpi_allgather 
     2973      !                                                   ! Workspace for message transfers avoiding mpi_allgather 
     2974      INTEGER :: istatus(mpi_status_size) 
    30052975      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
    30062976      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk 
    30072977      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
    30082978      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) ) 
     2979      !!---------------------------------------------------------------------- 
     2980      ! 
     2981      ALLOCATE( ztab(jpiglo,4,kfld), znorthloc  (jpi,4,kfld),        & 
     2982         &      zfoldwk(jpi,4,kfld), znorthgloio(jpi,4,kfld,jpni),   & 
     2983         &      ztabl  (jpi,4,kfld), ztabr(jpi*jpmaxngh, 4,kfld)   ) 
    30162984      ! 
    30172985      ijpj   = 4 
     
    30192987      ! 
    30202988       
    3021       DO jk = 1, num_fields 
     2989      DO jk = 1, kfld 
    30222990         DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable) 
    30232991            ij = jj - nlcj + ijpj 
     
    30333001         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
    30343002         ! 
    3035          ztabr(:,:,:) = 0 
    3036          ztabl(:,:,:) = 0 
    3037  
    3038          DO jk = 1, num_fields 
     3003         ztabr(:,:,:) = 0._wp 
     3004         ztabl(:,:,:) = 0._wp 
     3005 
     3006         DO jk = 1, kfld 
    30393007            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
    30403008               ij = jj - nlcj + ijpj 
     
    30453013         END DO 
    30463014 
    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 
     3015         DO jr = 1, nsndto 
     3016            IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
     3017               CALL mppsend(5, znorthloc, itaille*kfld, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "kfld" times 
    30503018            ENDIF 
    30513019         END DO 
    3052          DO jr = 1,nsndto 
     3020         DO jr = 1, nsndto 
    30533021            iproc = nfipproc(isendto(jr),jpnj) 
    3054             IF(iproc .ne. -1) THEN 
     3022            IF( iproc /= -1 ) THEN 
    30553023               ilei = nleit (iproc+1) 
    30563024               ildi = nldit (iproc+1) 
    30573025               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
    30583026            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 
     3027            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
     3028              CALL mpprecv(5, zfoldwk, itaille*kfld, iproc) ! Buffer expanded "kfld" times 
     3029              DO jk = 1 , kfld 
    30623030                 DO jj = 1, ijpj 
    30633031                    DO ji = ildi, ilei 
     
    30663034                 END DO 
    30673035              END DO 
    3068             ELSE IF (iproc .eq. (narea-1)) THEN 
    3069               DO jk = 1, num_fields 
     3036            ELSEIF ( iproc == narea-1 ) THEN 
     3037              DO jk = 1, kfld 
    30703038                 DO jj = 1, ijpj 
    30713039                    DO ji = ildi, ilei 
     
    30763044            ENDIF 
    30773045         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 
     3046         IF( l_isend ) THEN 
     3047            DO jr = 1, nsndto 
     3048               IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    30813049                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
    30823050               ENDIF 
     
    30843052         ENDIF 
    30853053         ! 
    3086          DO ji = 1, num_fields     ! Loop to manage 3D variables 
     3054         DO ji = 1, kfld     ! Loop to manage 3D variables 
    30873055            CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition 
    30883056         END DO 
    30893057         ! 
    3090          DO jk = 1, num_fields 
     3058         DO jk = 1, kfld 
    30913059            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    30923060               ij = jj - nlcj + ijpj 
     
    31003068      ELSE 
    31013069         ! 
    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 
     3070         CALL MPI_ALLGATHER( znorthloc  , itaille*kfld, MPI_DOUBLE_PRECISION,        & 
     3071            &                znorthgloio, itaille*kfld, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     3072         ! 
     3073         ztab(:,:,:) = 0._wp 
     3074         DO jk = 1, kfld 
    31073075            DO jr = 1, ndim_rank_north            ! recover the global north array 
    31083076               iproc = nrank_north(jr) + 1 
     
    31183086         END DO 
    31193087          
    3120          DO ji = 1, num_fields 
     3088         DO ji = 1, kfld 
    31213089            CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition 
    31223090         END DO 
    31233091         ! 
    3124          DO jk = 1, num_fields 
     3092         DO jk = 1, kfld 
    31253093            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    31263094               ij = jj - nlcj + ijpj 
     
    31383106   END SUBROUTINE mpp_lbc_north_2d_multiple 
    31393107 
     3108 
    31403109   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 
    31413110      !!--------------------------------------------------------------------- 
     
    31553124      REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    31563125      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 
     3126      REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! sign used across the north fold 
     3127      ! 
    31603128      INTEGER ::   ji, jj, jr 
    31613129      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    31623130      INTEGER ::   ijpj, ij, iproc 
    3163       ! 
    31643131      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
    31653132      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e 
    3166  
    31673133      !!---------------------------------------------------------------------- 
    31683134      ! 
    31693135      ALLOCATE( ztab_e(jpiglo,4+2*jpr2dj), znorthloc_e(jpi,4+2*jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) ) 
    3170  
    31713136      ! 
    31723137      ijpj=4 
    3173       ztab_e(:,:) = 0.e0 
    3174  
    3175       ij=0 
     3138      ztab_e(:,:) = 0._wp 
     3139 
     3140      ij = 0 
    31763141      ! put in znorthloc_e the last 4 jlines of pt2d 
    31773142      DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj 
    31783143         ij = ij + 1 
    31793144         DO ji = 1, jpi 
    3180             znorthloc_e(ji,ij)=pt2d(ji,jj) 
     3145            znorthloc_e(ji,ij) = pt2d(ji,jj) 
    31813146         END DO 
    31823147      END DO 
    31833148      ! 
    31843149      itaille = jpi * ( ijpj + 2 * jpr2dj ) 
    3185       CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    & 
     3150      CALL MPI_ALLGATHER( znorthloc_e(1,1)    , itaille, MPI_DOUBLE_PRECISION,    & 
    31863151         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    31873152      ! 
    31883153      DO jr = 1, ndim_rank_north            ! recover the global north array 
    31893154         iproc = nrank_north(jr) + 1 
    3190          ildi = nldit (iproc) 
    3191          ilei = nleit (iproc) 
    3192          iilb = nimppt(iproc) 
     3155         ildi  = nldit (iproc) 
     3156         ilei  = nleit (iproc) 
     3157         iilb  = nimppt(iproc) 
    31933158         DO jj = 1, ijpj+2*jpr2dj 
    31943159            DO ji = ildi, ilei 
     
    31973162         END DO 
    31983163      END DO 
    3199  
    32003164 
    32013165      ! 2. North-Fold boundary conditions 
     
    32383202      !! 
    32393203      !!---------------------------------------------------------------------- 
    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 
     3204      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
     3205      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type  ! nature of ptab grid point 
     3206      REAL(wp)                  , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
     3207      INTEGER                   , INTENT(in   ) ::   ib_bdy   ! BDY boundary set 
    32463208      ! 
    32473209      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
     3210      INTEGER  ::   ipk                        ! 3rd dimension of the input array 
    32483211      INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    32493212      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     
    32553218      !!---------------------------------------------------------------------- 
    32563219      ! 
    3257       ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   & 
    3258          &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  ) 
     3220      ipk = SIZE( ptab, 3 ) 
     3221      !       
     3222      ALLOCATE( zt3ns(jpi,jprecj,ipk,2), zt3sn(jpi,jprecj,ipk,2),   & 
     3223         &      zt3ew(jpj,jpreci,ipk,2), zt3we(jpj,jpreci,ipk,2)  ) 
    32593224 
    32603225      zland = 0._wp 
     
    32633228      ! ------------------------------ 
    32643229      !                                   ! East-West boundaries 
    3265       !                                        !* Cyclic east-west 
     3230      !                                        !* Cyclic 
    32663231      IF( nbondi == 2) THEN 
    32673232         IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 
     
    32733238         ENDIF 
    32743239      ELSEIF(nbondi == -1) THEN 
    3275          IF( .NOT. cd_type == 'F' )   ptab(1:jpreci,:,:) = zland    ! south except F-point 
     3240         IF( .NOT. cd_type == 'F' )   ptab(1:jpreci,:,:) = zland       ! south except F-point 
    32763241      ELSEIF(nbondi == 1) THEN 
    32773242         ptab(nlci-jpreci+1:jpi,:,:) = zland    ! north 
     
    32983263      ! 
    32993264      !                           ! Migrations 
    3300       imigr = jpreci * jpj * jpk 
     3265      imigr = jpreci * jpj * ipk 
    33013266      ! 
    33023267      SELECT CASE ( nbondi_bdy(ib_bdy) ) 
     
    33483313         END DO 
    33493314      END SELECT 
    3350  
    33513315 
    33523316      ! 3. North and south directions 
     
    33633327      ! 
    33643328      !                           ! Migrations 
    3365       imigr = jprecj * jpi * jpk 
     3329      imigr = jprecj * jpi * ipk 
    33663330      ! 
    33673331      SELECT CASE ( nbondj_bdy(ib_bdy) ) 
     
    34133377         END DO 
    34143378      END SELECT 
    3415  
    34163379 
    34173380      ! 4. north fold treatment 
     
    34533416      !! 
    34543417      !!---------------------------------------------------------------------- 
    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 
     3418      REAL(wp), DIMENSION(jpi,jpj)    , INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
     3419      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
     3420      REAL(wp)                        , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
     3421      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set 
     3422      ! 
     3423      INTEGER  ::   ji, jj, jl                 ! dummy loop indices 
    34633424      INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    34643425      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     
    34783439      ! ------------------------------ 
    34793440      !                                   ! East-West boundaries 
    3480       !                                      !* Cyclic east-west 
     3441      !                                         !* Cyclic 
    34813442      IF( nbondi == 2 ) THEN 
    3482          IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 
     3443         IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 
    34833444            ptab( 1 ,:) = ptab(jpim1,:) 
    34843445            ptab(jpi,:) = ptab(  2  ,:) 
    34853446         ELSE 
    3486             IF(.NOT.cd_type == 'F' )  ptab(     1       :jpreci,:) = zland    ! south except F-point 
    3487                                       ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
     3447            IF(.NOT.cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point 
     3448                                       ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
    34883449         ENDIF 
    34893450      ELSEIF(nbondi == -1) THEN 
    3490          IF( .NOT.cd_type == 'F' )    ptab(     1       :jpreci,:) = zland    ! south except F-point 
     3451         IF(.NOT.cd_type == 'F' )      ptab(     1       :jpreci,:) = zland    ! south except F-point 
    34913452      ELSEIF(nbondi == 1) THEN 
    3492                                       ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
     3453                                       ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
    34933454      ENDIF 
    34943455      !                                      !* closed 
     
    35373498      SELECT CASE ( nbondi_bdy(ib_bdy) ) 
    35383499      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) 
     3500         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
     3501      CASE ( 0 ) 
     3502         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
     3503         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err ) 
     3504      CASE ( 1 ) 
     3505         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
    35453506      END SELECT 
    35463507      ! 
     
    36023563      SELECT CASE ( nbondj_bdy(ib_bdy) ) 
    36033564      CASE ( -1 ) 
    3604          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3605       CASE ( 0 ) 
    3606          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3607          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    3608       CASE ( 1 ) 
    3609          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3565         IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
     3566      CASE ( 0 ) 
     3567         IF(l_isend) CALL mpi_wait (ml_req1, ml_stat, ml_err ) 
     3568         IF(l_isend) CALL mpi_wait( ml_req2, ml_stat, ml_err ) 
     3569      CASE ( 1 ) 
     3570         IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    36103571      END SELECT 
    36113572      ! 
     
    36283589         END DO 
    36293590      END SELECT 
    3630  
    36313591 
    36323592      ! 4. north fold treatment 
     
    37133673      !!   This subroutine computes yddb(i) = ydda(i)+yddb(i) 
    37143674      !!--------------------------------------------------------------------- 
    3715       INTEGER, INTENT(in)                         :: ilen, itype 
    3716       COMPLEX(wp), DIMENSION(ilen), INTENT(in)     :: ydda 
    3717       COMPLEX(wp), DIMENSION(ilen), INTENT(inout)  :: yddb 
     3675      INTEGER                     , INTENT(in)    ::  ilen, itype 
     3676      COMPLEX(wp), DIMENSION(ilen), INTENT(in)    ::  ydda 
     3677      COMPLEX(wp), DIMENSION(ilen), INTENT(inout) ::  yddb 
    37183678      ! 
    37193679      REAL(wp) :: zerr, zt1, zt2    ! local work variables 
    3720       INTEGER :: ji, ztmp           ! local scalar 
     3680      INTEGER  :: ji, ztmp           ! local scalar 
     3681      !!--------------------------------------------------------------------- 
    37213682 
    37223683      ztmp = itype   ! avoid compilation warning 
     
    38413802      !!                    nono   : number for local neighboring processors 
    38423803      !!---------------------------------------------------------------------- 
     3804      REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
     3805      CHARACTER(len=1)                                    , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
     3806      REAL(wp)                                            , INTENT(in   ) ::   psgn     ! sign used across the north fold 
    38433807      INTEGER                                             , INTENT(in   ) ::   jpri 
    38443808      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 
     3809      ! 
    38503810      INTEGER  ::   jl   ! dummy loop indices 
    38513811      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
     
    38753835         ! 
    38763836      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 
     3837         IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0._wp    ! south except at F-point 
     3838                                      pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp    ! north 
    38793839      ENDIF 
    38803840      ! 
     
    39963956         END DO 
    39973957      END SELECT 
    3998  
     3958      ! 
    39993959   END SUBROUTINE mpp_lnk_2d_icb 
    40003960    
     
    40203980      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
    40213981   END INTERFACE 
     3982   INTERFACE mpp_max_multiple 
     3983      MODULE PROCEDURE mppmax_real_multiple 
     3984   END INTERFACE 
    40223985 
    40233986   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag 
     
    41914154      WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom 
    41924155   END SUBROUTINE mpp_comm_free 
     4156    
     4157   SUBROUTINE mppmax_real_multiple( ptab, kdim , kcom  ) 
     4158      REAL, DIMENSION(:) ::   ptab   !  
     4159      INTEGER            ::   kdim   !  
     4160      INTEGER, OPTIONAL  ::   kcom   !  
     4161      WRITE(*,*) 'mppmax_real_multiple: You should not have seen this print! error?', ptab(1), kdim 
     4162   END SUBROUTINE mppmax_real_multiple 
     4163 
    41934164#endif 
    41944165 
     
    42254196                               CALL FLUSH(numout    ) 
    42264197      IF( numstp     /= -1 )   CALL FLUSH(numstp    ) 
    4227       IF( numsol     /= -1 )   CALL FLUSH(numsol    ) 
     4198      IF( numrun     /= -1 )   CALL FLUSH(numrun    ) 
    42284199      IF( numevo_ice /= -1 )   CALL FLUSH(numevo_ice) 
    42294200      ! 
     
    43324303            WRITE(kout,*) 
    43334304         ENDIF 
    4334          CALL FLUSH(kout)  
     4305         CALL FLUSH( kout )  
    43354306         STOP 'ctl_opn bad opening' 
    43364307      ENDIF 
  • branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r7761 r7904  
    622622      ! 
    623623      IF( numstp          /= -1 )   CLOSE( numstp          )   ! time-step file 
    624       IF( numsol          /= -1 )   CLOSE( numsol          )   ! solver file 
     624      IF( numrun          /= -1 )   CLOSE( numrun          )   ! run statistics file 
    625625      IF( numnam_ref      /= -1 )   CLOSE( numnam_ref      )   ! oce reference namelist 
    626626      IF( numnam_cfg      /= -1 )   CLOSE( numnam_cfg      )   ! oce configuration namelist 
  • branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/OPA_SRC/stpctl.F90

    r7852 r7904  
    99   !!   NEMO     1.0  ! 2002-06  (G. Madec)  F90: Free form and module 
    1010   !!            2.0  ! 2009-07  (G. Madec)  Add statistic for time-spliting 
     11   !!            3.7  ! 2016-09  (G. Madec)  Remove solver 
     12   !!            4.0  ! 2017-04  (G. Madec)  regroup global communications 
    1113   !!---------------------------------------------------------------------- 
    1214 
     
    2123   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    2224   USE lib_mpp         ! distributed memory computing 
    23    USE lib_fortran     ! Fortran routines library  
    2425 
    2526   IMPLICIT NONE 
     
    2829   PUBLIC stp_ctl           ! routine called by step.F90 
    2930   !!---------------------------------------------------------------------- 
    30    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     31   !! NEMO/OPA 4.0 , NEMO Consortium (2017) 
    3132   !! $Id$ 
    3233   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     
    4243      !! ** Method  : - Save the time step in numstp 
    4344      !!              - Print it each 50 time steps 
    44       !!              - Stop the run IF problem ( indic < 0 ) 
     45      !!              - Stop the run IF problem encountered by setting indic=-3 
     46      !!                Problems checked: |ssh| maximum larger than 10 m 
     47      !!                                  |U|   maximum larger than 10 m/s  
     48      !!                                  negative sea surface salinity 
    4549      !! 
    46       !! ** Actions :   'time.step' file containing the last ocean time-step 
    47       !!                 
     50      !! ** Actions :   "time.step" file = last ocean time-step 
     51      !!                "run.stat"  file = run statistics 
    4852      !!---------------------------------------------------------------------- 
    4953      INTEGER, INTENT(in   ) ::   kt       ! ocean time-step index 
     
    5155      !! 
    5256      INTEGER  ::   ji, jj, jk             ! dummy loop indices 
    53       INTEGER  ::   ii, ij, ik             ! local integers 
    54       REAL(wp) ::   zumax, zsmin, zssh2, zsshmax    ! local scalars 
    55       INTEGER, DIMENSION(3) ::   ilocu     !  
    56       INTEGER, DIMENSION(2) ::   ilocs     !  
     57      INTEGER  ::   iih, ijh               ! local integers 
     58      INTEGER  ::   iiu, iju, iku          !   -       - 
     59      INTEGER  ::   iis, ijs               !   -       - 
     60      REAL(wp) ::   zzz                    ! local real  
     61      INTEGER , DIMENSION(3) ::   ilocu 
     62      INTEGER , DIMENSION(2) ::   ilocs, iloch 
     63      REAL(wp), DIMENSION(3) ::   zmax 
    5764      !!---------------------------------------------------------------------- 
    5865      ! 
     
    6168         WRITE(numout,*) 'stp_ctl : time-stepping control' 
    6269         WRITE(numout,*) '~~~~~~~' 
    63          ! open time.step file 
     70         !                                ! open time.step file 
    6471         CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
     72         !                                ! open run.stat file 
     73         CALL ctl_opn( numrun, 'run.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
    6574      ENDIF 
    6675      ! 
    67       IF(lwp) WRITE ( numstp, '(1x, i8)' )   kt      !* save the current time step in numstp 
    68       IF(lwp) REWIND( numstp )                       !  -------------------------- 
     76      IF(lwp) THEN                        !==  current time step  ==!   ("time.step" file) 
     77         WRITE ( numstp, '(1x, i8)' )   kt 
     78         REWIND( numstp ) 
     79      ENDIF 
    6980      ! 
    70       !                                              !* Test maximum of velocity (zonal only) 
    71       !                                              !  ------------------------ 
    72       !! zumax = MAXVAL( ABS( un(:,:,:) ) )                ! slower than the following loop on NEC SX5 
    73       zumax = 0.e0 
    74       DO jk = 1, jpk 
    75          DO jj = 1, jpj 
    76             DO ji = 1, jpi 
    77                zumax = MAX(zumax,ABS(un(ji,jj,jk))) 
    78           END DO  
    79         END DO  
    80       END DO         
    81       IF( lk_mpp )   CALL mpp_max( zumax )                 ! max over the global domain 
     81      !                                   !==  test of extrema  ==! 
     82      zmax(1) = MAXVAL(  ABS( sshn(:,:) )  )                                  ! ssh max 
     83      zmax(2) = MAXVAL(  ABS( un(:,:,:) )  )                                  ! velocity max (zonal only) 
     84      zmax(3) = MAXVAL( -tsn(:,:,1,jp_sal) , mask = tmask(:,:,1) == 1._wp )   ! minus surface salinity max 
    8285      ! 
    83       IF( MOD( kt, nwrite ) == 1 .AND. lwp )   WRITE(numout,*) ' ==>> time-step= ',kt,' abs(U) max: ', zumax 
     86      IF( lk_mpp )   CALL mpp_max_multiple( zmax(:), 3 ) ! max over the global domain 
    8487      ! 
    85       IF( zumax > 20.e0 ) THEN 
     88      IF( MOD( kt, nwrite ) == 1 .AND. lwp ) THEN 
     89         WRITE(numout,*) ' ==>> time-step= ',kt,' |U| max: ', zmax(1), ' SSS min:', - zmax(2) 
     90      ENDIF 
     91      ! 
     92      IF ( zmax(1) > 10._wp .OR.   &                     ! too large sea surface height ( > 10 m) 
     93         & zmax(2) > 10._wp .OR.   &                     ! too large velocity ( > 10 m/s) 
     94         & zmax(3) >  0._wp ) THEN                       ! negative sea surface salinity 
    8695         IF( lk_mpp ) THEN 
    87             CALL mpp_maxloc(ABS(un),umask,zumax,ii,ij,ik) 
     96            CALL mpp_maxloc( ABS(sshn)        , tmask(:,:,1), zzz, iih, ijh ) 
     97            CALL mpp_maxloc( ABS(un)          , umask       , zzz, iiu, iju, iku ) 
     98            CALL mpp_minloc( tsn(:,:,1,jp_sal), tmask(:,:,1), zzz, iis, ijs ) 
    8899         ELSE 
     100            iloch = MINLOC( ABS( sshn(:,:) ) ) 
    89101            ilocu = MAXLOC( ABS( un(:,:,:) ) ) 
    90             ii = ilocu(1) + nimpp - 1 
    91             ij = ilocu(2) + njmpp - 1 
    92             ik = ilocu(3) 
     102            ilocs = MINLOC( tsn(:,:,1,jp_sal), mask = tmask(:,:,1) == 1._wp ) 
     103            iih = iloch(1) + nimpp - 1   ;   ijh = iloch(2) + njmpp - 1 
     104            iiu = ilocu(1) + nimpp - 1   ;   iju = ilocu(2) + njmpp - 1   ;   iku = ilocu(3) 
     105            iis = ilocs(1) + nimpp - 1   ;   ijs = ilocs(2) + njmpp - 1 
    93106         ENDIF 
    94107         IF(lwp) THEN 
    95108            WRITE(numout,cform_err) 
    96             WRITE(numout,*) ' stpctl: the zonal velocity is larger than 20 m/s' 
     109            WRITE(numout,*) ' stpctl: |ssh| > 10 m   or   |U| > 10 m/s   or   SSS < 0' 
    97110            WRITE(numout,*) ' ====== ' 
    98             WRITE(numout,9400) kt, zumax, ii, ij, ik 
     111            WRITE(numout,9100) kt,   zmax(1), iih, ijh 
     112            WRITE(numout,9200) kt,   zmax(2), iiu, iju, iku 
     113            WRITE(numout,9300) kt, - zmax(3), iis, ijs 
    99114            WRITE(numout,*) 
    100             WRITE(numout,*) '          output of last fields in numwso' 
     115            WRITE(numout,*) '          output of last computed fields in output.abort.nc file' 
    101116         ENDIF 
    102117         kindic = -3 
    103118      ENDIF 
    104 9400  FORMAT (' kt=',i6,' max abs(U): ',1pg11.4,', i j k: ',3i5) 
     1199100  FORMAT (' kt=',i8,'   |ssh| max: ',1pg11.4,', at  i j  : ',2i5) 
     1209200  FORMAT (' kt=',i8,'   |U|   max: ',1pg11.4,', at  i j k: ',3i5) 
     1219300  FORMAT (' kt=',i8,'   SSS   min: ',1pg11.4,', at  i j  : ',2i5) 
    105122      ! 
    106       !                                              !* Test minimum of salinity 
    107       !                                              !  ------------------------ 
    108       !! zsmin = MINVAL( tsn(:,:,1,jp_sal), mask = tmask(:,:,1) == 1.e0 )  slower than the following loop on NEC SX5 
    109       zsmin = 100._wp 
    110       DO jj = 2, jpjm1 
    111          DO ji = 1, jpi 
    112             IF( tmask(ji,jj,1) == 1) zsmin = MIN(zsmin,tsn(ji,jj,1,jp_sal)) 
    113          END DO 
    114       END DO 
    115       IF( lk_mpp )   CALL mpp_min( zsmin )                ! min over the global domain 
     123      !                                            !==  run statistics  ==!   ("run.stat" file) 
     124      IF(lwp) WRITE(numrun,9400) kt, zmax(1), zmax(2), - zmax(3) 
    116125      ! 
    117       IF( MOD( kt, nwrite ) == 1 .AND. lwp )   WRITE(numout,*) ' ==>> time-step= ',kt,' SSS min:', zsmin 
    118       ! 
    119       IF( zsmin < 0.) THEN  
    120          IF (lk_mpp) THEN 
    121             CALL mpp_minloc ( tsn(:,:,1,jp_sal),tmask(:,:,1), zsmin, ii,ij ) 
    122          ELSE 
    123             ilocs = MINLOC( tsn(:,:,1,jp_sal), mask = tmask(:,:,1) == 1.e0 ) 
    124             ii = ilocs(1) + nimpp - 1 
    125             ij = ilocs(2) + njmpp - 1 
    126          ENDIF 
    127          ! 
    128          IF(lwp) THEN 
    129             WRITE(numout,cform_err) 
    130             WRITE(numout,*) 'stp_ctl : NEGATIVE sea surface salinity' 
    131             WRITE(numout,*) '======= ' 
    132             WRITE(numout,9500) kt, zsmin, ii, ij 
    133             WRITE(numout,*) 
    134             WRITE(numout,*) '          output of last fields in numwso' 
    135          ENDIF 
    136          kindic = -3 
    137       ENDIF 
    138 9500  FORMAT (' kt=',i6,' min SSS: ',1pg11.4,', i j: ',2i5) 
    139       ! 
    140       ! 
    141       IF( lk_c1d )  RETURN          ! No log file in case of 1D vertical configuration 
    142  
    143       ! log file (ssh statistics) 
    144       ! --------                                   !* ssh statistics (and others...) 
    145       IF( kt == nit000 .AND. lwp ) THEN   ! open ssh statistics file (put in solver.stat file) 
    146          CALL ctl_opn( numsol, 'solver.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
    147       ENDIF 
    148       ! 
    149       zsshmax = 0.e0 
    150       DO jj = 1, jpj 
    151          DO ji = 1, jpi 
    152             IF( tmask(ji,jj,1) == 1) zsshmax = MAX( zsshmax, ABS(sshn(ji,jj)) ) 
    153          END DO 
    154       END DO 
    155       IF( lk_mpp )   CALL mpp_max( zsshmax )                ! min over the global domain 
    156       ! 
    157       IF( MOD( kt, nwrite ) == 1 .AND. lwp )   WRITE(numout,*) ' ==>> time-step= ',kt,' ssh max:', zsshmax 
    158       ! 
    159       IF( zsshmax > 10.e0 ) THEN  
    160          IF (lk_mpp) THEN 
    161             CALL mpp_maxloc( ABS(sshn(:,:)),tmask(:,:,1),zsshmax,ii,ij) 
    162          ELSE 
    163             ilocs = MAXLOC( ABS(sshn(:,:)) ) 
    164             ii = ilocs(1) + nimpp - 1 
    165             ij = ilocs(2) + njmpp - 1 
    166          ENDIF 
    167          ! 
    168          IF(lwp) THEN 
    169             WRITE(numout,cform_err) 
    170             WRITE(numout,*) 'stp_ctl : the ssh is larger than 10m' 
    171             WRITE(numout,*) '======= ' 
    172             WRITE(numout,9600) kt, zsshmax, ii, ij 
    173             WRITE(numout,*) 
    174             WRITE(numout,*) '          output of last fields in numwso' 
    175          ENDIF 
    176          kindic = -3 
    177       ENDIF 
    178 9600  FORMAT (' kt=',i6,' max ssh: ',1pg11.4,', i j: ',2i5) 
    179       ! 
    180       zssh2 = glob_sum( sshn(:,:) * sshn(:,:) ) 
    181       ! 
    182       IF(lwp) WRITE(numsol,9700) kt, zssh2, zumax, zsmin      ! ssh statistics 
    183       ! 
    184 9700  FORMAT(' it :', i8, ' ssh2: ', d23.16, ' Umax: ',d23.16,' Smin: ',d23.16) 
     1269400  FORMAT(' it :', i8, '    |ssh|_max: ', e16.10, ' |U|_max: ',e16.10,' SSS_min: ',e16.10) 
    185127      ! 
    186128   END SUBROUTINE stp_ctl 
Note: See TracChangeset for help on using the changeset viewer.