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

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 11822 for NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LBC – NEMO

Ignore:
Timestamp:
2019-10-29T11:41:36+01:00 (5 years ago)
Author:
acc
Message:

Branch 2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps. Sette tested updates to branch to align with trunk changes between 10721 and 11740. Sette tests are passing but results differ from branch before these changes (except for GYRE_PISCES and VORTEX) and branch results already differed from trunk because of algorithmic fixes. Will need more checks to confirm correctness.

Location:
NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LBC
Files:
2 deleted
8 edited

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LBC/lbc_lnk_multi_generic.h90

    r10425 r11822  
    1414#   define PTR_ptab              pt4d 
    1515#endif 
    16    SUBROUTINE ROUTINE_MULTI( cdname                                                    & 
    17       &                    , pt1, cdna1, psgn1, pt2, cdna2, psgn2, pt3, cdna3, psgn3   & 
    18       &                    , pt4, cdna4, psgn4, pt5, cdna5, psgn5, pt6, cdna6, psgn6   & 
    19       &                    , pt7, cdna7, psgn7, pt8, cdna8, psgn8, pt9, cdna9, psgn9, cd_mpp, pval) 
     16 
     17   SUBROUTINE ROUTINE_MULTI( cdname                                                                             & 
     18      &                    , pt1, cdna1, psgn1, pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4, cdna4, psgn4   & 
     19      &                    , pt5, cdna5, psgn5, pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8, cdna8, psgn8   & 
     20      &                    , pt9, cdna9, psgn9, pt10, cdna10, psgn10, pt11, cdna11, psgn11                      & 
     21      &                    , kfillmode, pfillval, lsend, lrecv, ihlcom ) 
    2022      !!--------------------------------------------------------------------- 
    21       CHARACTER(len=*)   ,                   INTENT(in   ) ::   cdname  ! name of the calling subroutine 
    22       ARRAY_TYPE(:,:,:,:)          , TARGET, INTENT(inout) ::   pt1     ! arrays on which the lbc is applied 
    23       ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) ::   pt2  ,  pt3  , pt4  , pt5  , pt6  , pt7  , pt8  , pt9 
    24       CHARACTER(len=1)                     , INTENT(in   ) ::   cdna1   ! nature of pt2D. array grid-points 
    25       CHARACTER(len=1)   , OPTIONAL        , INTENT(in   ) ::   cdna2,  cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9 
    26       REAL(wp)                             , INTENT(in   ) ::   psgn1   ! sign used across the north fold 
    27       REAL(wp)           , OPTIONAL        , INTENT(in   ) ::   psgn2,  psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9    
    28       CHARACTER(len=3)   , OPTIONAL        , INTENT(in   ) ::   cd_mpp  ! fill the overlap area only 
    29       REAL(wp)           , OPTIONAL        , INTENT(in   ) ::   pval    ! background value (used at closed boundaries) 
     23      CHARACTER(len=*)   ,                   INTENT(in   ) :: cdname  ! name of the calling subroutine 
     24      ARRAY_TYPE(:,:,:,:)          , TARGET, INTENT(inout) :: pt1     ! arrays on which the lbc is applied 
     25      ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) :: pt2  , pt3  , pt4  , pt5  , pt6  , pt7  , pt8  , pt9  , pt10  , pt11 
     26      CHARACTER(len=1)                     , INTENT(in   ) :: cdna1   ! nature of pt2D. array grid-points 
     27      CHARACTER(len=1)   , OPTIONAL        , INTENT(in   ) :: cdna2, cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9, cdna10, cdna11 
     28      REAL(wp)                             , INTENT(in   ) :: psgn1   ! sign used across the north fold 
     29      REAL(wp)           , OPTIONAL        , INTENT(in   ) :: psgn2, psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9, psgn10, psgn11 
     30      INTEGER            , OPTIONAL        , INTENT(in   ) :: kfillmode   ! filling method for halo over land (default = constant) 
     31      REAL(wp)           , OPTIONAL        , INTENT(in   ) :: pfillval    ! background value (used at closed boundaries) 
     32      LOGICAL, DIMENSION(4), OPTIONAL      , INTENT(in   ) :: lsend, lrecv   ! indicate how communications are to be carried out 
     33      INTEGER            , OPTIONAL        , INTENT(in   ) :: ihlcom         ! number of ranks and rows to be communicated 
    3034      !! 
    31       INTEGER                         ::   kfld        ! number of elements that will be attributed 
    32       PTR_TYPE         , DIMENSION(9) ::   ptab_ptr    ! pointer array 
    33       CHARACTER(len=1) , DIMENSION(9) ::   cdna_ptr    ! nature of ptab_ptr grid-points 
    34       REAL(wp)         , DIMENSION(9) ::   psgn_ptr    ! sign used across the north fold boundary 
     35      INTEGER                          ::   kfld        ! number of elements that will be attributed 
     36      PTR_TYPE         , DIMENSION(11) ::   ptab_ptr    ! pointer array 
     37      CHARACTER(len=1) , DIMENSION(11) ::   cdna_ptr    ! nature of ptab_ptr grid-points 
     38      REAL(wp)         , DIMENSION(11) ::   psgn_ptr    ! sign used across the north fold boundary 
    3539      !!--------------------------------------------------------------------- 
    3640      ! 
    … …  
    4145      ! 
    4246      !                 ! Look if more arrays are added 
    43       IF( PRESENT(psgn2) )   CALL ROUTINE_LOAD( pt2, cdna2, psgn2, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    44       IF( PRESENT(psgn3) )   CALL ROUTINE_LOAD( pt3, cdna3, psgn3, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    45       IF( PRESENT(psgn4) )   CALL ROUTINE_LOAD( pt4, cdna4, psgn4, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    46       IF( PRESENT(psgn5) )   CALL ROUTINE_LOAD( pt5, cdna5, psgn5, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    47       IF( PRESENT(psgn6) )   CALL ROUTINE_LOAD( pt6, cdna6, psgn6, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    48       IF( PRESENT(psgn7) )   CALL ROUTINE_LOAD( pt7, cdna7, psgn7, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    49       IF( PRESENT(psgn8) )   CALL ROUTINE_LOAD( pt8, cdna8, psgn8, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    50       IF( PRESENT(psgn9) )   CALL ROUTINE_LOAD( pt9, cdna9, psgn9, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     47      IF( PRESENT(psgn2 ) )   CALL ROUTINE_LOAD( pt2 , cdna2 , psgn2 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     48      IF( PRESENT(psgn3 ) )   CALL ROUTINE_LOAD( pt3 , cdna3 , psgn3 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     49      IF( PRESENT(psgn4 ) )   CALL ROUTINE_LOAD( pt4 , cdna4 , psgn4 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     50      IF( PRESENT(psgn5 ) )   CALL ROUTINE_LOAD( pt5 , cdna5 , psgn5 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     51      IF( PRESENT(psgn6 ) )   CALL ROUTINE_LOAD( pt6 , cdna6 , psgn6 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     52      IF( PRESENT(psgn7 ) )   CALL ROUTINE_LOAD( pt7 , cdna7 , psgn7 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     53      IF( PRESENT(psgn8 ) )   CALL ROUTINE_LOAD( pt8 , cdna8 , psgn8 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     54      IF( PRESENT(psgn9 ) )   CALL ROUTINE_LOAD( pt9 , cdna9 , psgn9 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     55      IF( PRESENT(psgn10) )   CALL ROUTINE_LOAD( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     56      IF( PRESENT(psgn11) )   CALL ROUTINE_LOAD( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    5157      ! 
    52       CALL lbc_lnk_ptr( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, cd_mpp, pval ) 
     58      CALL lbc_lnk_ptr    ( cdname,               ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv, ihlcom ) 
    5359      ! 
    5460   END SUBROUTINE ROUTINE_MULTI 
    … …  
    7278      ! 
    7379   END SUBROUTINE ROUTINE_LOAD 
     80 
    7481#undef ARRAY_TYPE 
    7582#undef PTR_TYPE 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LBC/lbc_nfd_nogather_generic.h90

    r10425 r11822  
    7474      ! 
    7575      ! Security check for further developments 
    76       IF ( ipf > 1 ) THEN 
    77         write(6,*) 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation'  
    78         write(6,*) 'You should not be there...'  
    79         STOP 
    80       ENDIF 
     76      IF ( ipf > 1 ) CALL ctl_stop( 'STOP', 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation...' ) 
    8177      ! 
    8278      ijpj   = 1    ! index of first modified line  

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LBC/lbclnk.F90

    r10425 r11822  
    1414   !!             -   ! 2017-05  (G. Madec) create generic.h90 files to generate all lbc and north fold routines 
    1515   !!---------------------------------------------------------------------- 
    16 #if defined key_mpp_mpi 
    17    !!---------------------------------------------------------------------- 
    18    !!   'key_mpp_mpi'             MPI massively parallel processing library 
    19    !!---------------------------------------------------------------------- 
    2016   !!           define the generic interfaces of lib_mpp routines 
    2117   !!---------------------------------------------------------------------- 
    … …  
    2319   !!   lbc_bdy_lnk   : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 
    2420   !!---------------------------------------------------------------------- 
    25    USE par_oce        ! ocean dynamics and tracers    
     21   USE dom_oce        ! ocean space and time domain 
    2622   USE lib_mpp        ! distributed memory computing library 
    2723   USE lbcnfd         ! north fold 
     24   USE in_out_manager ! I/O manager 
     25 
     26   IMPLICIT NONE 
     27   PRIVATE 
    2828 
    2929   INTERFACE lbc_lnk 
    … …  
    3737   END INTERFACE 
    3838   ! 
    39    INTERFACE lbc_bdy_lnk 
    40       MODULE PROCEDURE mpp_lnk_bdy_2d, mpp_lnk_bdy_3d, mpp_lnk_bdy_4d 
    41    END INTERFACE 
    42    ! 
    4339   INTERFACE lbc_lnk_icb 
    4440      MODULE PROCEDURE mpp_lnk_2d_icb 
    4541   END INTERFACE 
    4642 
     43   INTERFACE mpp_nfd 
     44      MODULE PROCEDURE   mpp_nfd_2d    , mpp_nfd_3d    , mpp_nfd_4d 
     45      MODULE PROCEDURE   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 
     46   END INTERFACE 
     47 
    4748   PUBLIC   lbc_lnk       ! ocean/ice lateral boundary conditions 
    4849   PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 
    49    PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    5050   PUBLIC   lbc_lnk_icb   ! iceberg lateral boundary conditions 
     51 
     52#if   defined key_mpp_mpi 
     53!$AGRIF_DO_NOT_TREAT 
     54   INCLUDE 'mpif.h' 
     55!$AGRIF_END_DO_NOT_TREAT 
     56#endif 
     57 
     58   INTEGER, PUBLIC, PARAMETER ::   jpfillnothing = 1 
     59   INTEGER, PUBLIC, PARAMETER ::   jpfillcst     = 2 
     60   INTEGER, PUBLIC, PARAMETER ::   jpfillcopy    = 3 
     61   INTEGER, PUBLIC, PARAMETER ::   jpfillperio   = 4 
     62   INTEGER, PUBLIC, PARAMETER ::   jpfillmpi     = 5 
    5163 
    5264   !!---------------------------------------------------------------------- 
    … …  
    5668   !!---------------------------------------------------------------------- 
    5769CONTAINS 
    58  
    59 #else 
    60    !!---------------------------------------------------------------------- 
    61    !!   Default option                              shared memory computing 
    62    !!---------------------------------------------------------------------- 
    63    !!                routines setting the appropriate values 
    64    !!         on first and last row and column of the global domain 
    65    !!---------------------------------------------------------------------- 
    66    !!   lbc_lnk_sum_3d: compute sum over the halos on a 3D variable on ocean mesh 
    67    !!   lbc_lnk_sum_3d: compute sum over the halos on a 2D variable on ocean mesh 
    68    !!   lbc_lnk       : generic interface for lbc_lnk_3d and lbc_lnk_2d 
    69    !!   lbc_lnk_3d    : set the lateral boundary condition on a 3D variable on ocean mesh 
    70    !!   lbc_lnk_2d    : set the lateral boundary condition on a 2D variable on ocean mesh 
    71    !!   lbc_bdy_lnk   : set the lateral BDY boundary condition 
    72    !!---------------------------------------------------------------------- 
    73    USE oce            ! ocean dynamics and tracers    
    74    USE dom_oce        ! ocean space and time domain  
    75    USE in_out_manager ! I/O manager 
    76    USE lbcnfd         ! north fold 
    77  
    78    IMPLICIT NONE 
    79    PRIVATE 
    80  
    81    INTERFACE lbc_lnk 
    82       MODULE PROCEDURE   lbc_lnk_2d      , lbc_lnk_3d      , lbc_lnk_4d 
    83    END INTERFACE 
    84    INTERFACE lbc_lnk_ptr 
    85       MODULE PROCEDURE   lbc_lnk_2d_ptr  , lbc_lnk_3d_ptr  , lbc_lnk_4d_ptr 
    86    END INTERFACE 
    87    INTERFACE lbc_lnk_multi 
    88       MODULE PROCEDURE   lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 
    89    END INTERFACE 
    90    ! 
    91    INTERFACE lbc_bdy_lnk 
    92       MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d, lbc_bdy_lnk_4d 
    93    END INTERFACE 
    94    ! 
    95    INTERFACE lbc_lnk_icb 
    96       MODULE PROCEDURE lbc_lnk_2d_icb 
    97    END INTERFACE 
    98     
    99    PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions 
    100    PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 
    101    PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    102    PUBLIC   lbc_lnk_icb   ! iceberg lateral boundary conditions 
    103     
    104    !!---------------------------------------------------------------------- 
    105    !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    106    !! $Id$ 
    107    !! Software governed by the CeCILL license (see ./LICENSE) 
    108    !!---------------------------------------------------------------------- 
    109 CONTAINS 
    110  
    111    !!====================================================================== 
    112    !!   Default option                           3D shared memory computing 
    113    !!====================================================================== 
    114    !!          routines setting land point, or east-west cyclic, 
    115    !!             or north-south cyclic, or north fold values 
    116    !!         on first and last row and column of the global domain 
    117    !!---------------------------------------------------------------------- 
    118  
    119    !!---------------------------------------------------------------------- 
    120    !!                   ***  routine lbc_lnk_(2,3,4)d  *** 
    121    !! 
    122    !!   * Argument : dummy argument use in lbc_lnk_... routines 
    123    !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
    124    !!                cd_nat :   nature of array grid-points 
    125    !!                psgn   :   sign used across the north fold boundary 
    126    !!                kfld   :   optional, number of pt3d arrays 
    127    !!                cd_mpp :   optional, fill the overlap area only 
    128    !!                pval   :   optional, background value (used at closed boundaries) 
    129    !!---------------------------------------------------------------------- 
    130    ! 
    131    !                       !==  2D array and array of 2D pointer  ==! 
    132    ! 
    133 #  define DIM_2d 
    134 #     define ROUTINE_LNK           lbc_lnk_2d 
    135 #     include "lbc_lnk_generic.h90" 
    136 #     undef ROUTINE_LNK 
    137 #     define MULTI 
    138 #     define ROUTINE_LNK           lbc_lnk_2d_ptr 
    139 #     include "lbc_lnk_generic.h90" 
    140 #     undef ROUTINE_LNK 
    141 #     undef MULTI 
    142 #  undef DIM_2d 
    143    ! 
    144    !                       !==  3D array and array of 3D pointer  ==! 
    145    ! 
    146 #  define DIM_3d 
    147 #     define ROUTINE_LNK           lbc_lnk_3d 
    148 #     include "lbc_lnk_generic.h90" 
    149 #     undef ROUTINE_LNK 
    150 #     define MULTI 
    151 #     define ROUTINE_LNK           lbc_lnk_3d_ptr 
    152 #     include "lbc_lnk_generic.h90" 
    153 #     undef ROUTINE_LNK 
    154 #     undef MULTI 
    155 #  undef DIM_3d 
    156    ! 
    157    !                       !==  4D array and array of 4D pointer  ==! 
    158    ! 
    159 #  define DIM_4d 
    160 #     define ROUTINE_LNK           lbc_lnk_4d 
    161 #     include "lbc_lnk_generic.h90" 
    162 #     undef ROUTINE_LNK 
    163 #     define MULTI 
    164 #     define ROUTINE_LNK           lbc_lnk_4d_ptr 
    165 #     include "lbc_lnk_generic.h90" 
    166 #     undef ROUTINE_LNK 
    167 #     undef MULTI 
    168 #  undef DIM_4d 
    169     
    170    !!====================================================================== 
    171    !!   identical routines in both C1D and shared memory computing 
    172    !!====================================================================== 
    173  
    174    !!---------------------------------------------------------------------- 
    175    !!                   ***  routine lbc_bdy_lnk_(2,3,4)d  *** 
    176    !! 
    177    !!   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 
    178    !!   to maintain the same interface with regards to the mpp case 
    179    !!---------------------------------------------------------------------- 
    180     
    181    SUBROUTINE lbc_bdy_lnk_4d( cdname, pt4d, cd_type, psgn, ib_bdy ) 
    182       !!---------------------------------------------------------------------- 
    183       CHARACTER(len=*)          , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    184       REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pt4d      ! 3D array on which the lbc is applied 
    185       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    186       REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across north fold  
    187       INTEGER                   , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
    188       !!---------------------------------------------------------------------- 
    189       CALL lbc_lnk_4d( cdname, pt4d, cd_type, psgn) 
    190    END SUBROUTINE lbc_bdy_lnk_4d 
    191  
    192    SUBROUTINE lbc_bdy_lnk_3d( cdname, pt3d, cd_type, psgn, ib_bdy ) 
    193       !!---------------------------------------------------------------------- 
    194       CHARACTER(len=*)          , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    195       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the lbc is applied 
    196       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    197       REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across north fold  
    198       INTEGER                   , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
    199       !!---------------------------------------------------------------------- 
    200       CALL lbc_lnk_3d( cdname, pt3d, cd_type, psgn) 
    201    END SUBROUTINE lbc_bdy_lnk_3d 
    202  
    203  
    204    SUBROUTINE lbc_bdy_lnk_2d( cdname, pt2d, cd_type, psgn, ib_bdy ) 
    205       !!---------------------------------------------------------------------- 
    206       CHARACTER(len=*)        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    207       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 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       INTEGER                 , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
    211       !!---------------------------------------------------------------------- 
    212       CALL lbc_lnk_2d( cdname, pt2d, cd_type, psgn) 
    213    END SUBROUTINE lbc_bdy_lnk_2d 
    214  
    215  
    216 !!gm  This routine should be removed with an optional halos size added in argument of generic routines 
    217  
    218    SUBROUTINE lbc_lnk_2d_icb( cdname, pt2d, cd_type, psgn, ki, kj ) 
    219       !!---------------------------------------------------------------------- 
    220       CHARACTER(len=*)        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    221       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the lbc is applied 
    222       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    223       REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold  
    224       INTEGER                 , INTENT(in   ) ::   ki, kj    ! sizes of extra halo (not needed in non-mpp) 
    225       !!---------------------------------------------------------------------- 
    226       CALL lbc_lnk_2d( cdname, pt2d, cd_type, psgn ) 
    227    END SUBROUTINE lbc_lnk_2d_icb 
    228 !!gm end 
    229  
    230 #endif 
    231  
    232    !!====================================================================== 
    233    !!   identical routines in both distributed and shared memory computing 
    234    !!====================================================================== 
    23570 
    23671   !!---------------------------------------------------------------------- 
    … …  
    25691 
    25792#  define DIM_2d 
     93#     define ROUTINE_LOAD           load_ptr_2d 
    25894#     define ROUTINE_MULTI          lbc_lnk_2d_multi 
    259 #     define ROUTINE_LOAD           load_ptr_2d 
    26095#     include "lbc_lnk_multi_generic.h90" 
    26196#     undef ROUTINE_MULTI 
    … …  
    26398#  undef DIM_2d 
    26499 
    265  
    266100#  define DIM_3d 
     101#     define ROUTINE_LOAD           load_ptr_3d 
    267102#     define ROUTINE_MULTI          lbc_lnk_3d_multi 
    268 #     define ROUTINE_LOAD           load_ptr_3d 
    269103#     include "lbc_lnk_multi_generic.h90" 
    270104#     undef ROUTINE_MULTI 
    … …  
    272106#  undef DIM_3d 
    273107 
    274  
    275108#  define DIM_4d 
     109#     define ROUTINE_LOAD           load_ptr_4d 
    276110#     define ROUTINE_MULTI          lbc_lnk_4d_multi 
    277 #     define ROUTINE_LOAD           load_ptr_4d 
    278111#     include "lbc_lnk_multi_generic.h90" 
    279112#     undef ROUTINE_MULTI 
    … …  
    281114#  undef DIM_4d 
    282115 
     116   !!---------------------------------------------------------------------- 
     117   !!                   ***  routine mpp_lnk_(2,3,4)d  *** 
     118   !! 
     119   !!   * Argument : dummy argument use in mpp_lnk_... routines 
     120   !!                ptab      :   array or pointer of arrays on which the boundary condition is applied 
     121   !!                cd_nat    :   nature of array grid-points 
     122   !!                psgn      :   sign used across the north fold boundary 
     123   !!                kfld      :   optional, number of pt3d arrays 
     124   !!                kfillmode :   optional, method to be use to fill the halos (see jpfill* variables) 
     125   !!                pfillval  :   optional, background value (used with jpfillcopy) 
     126   !!---------------------------------------------------------------------- 
     127   ! 
     128   !                       !==  2D array and array of 2D pointer  ==! 
     129   ! 
     130#  define DIM_2d 
     131#     define ROUTINE_LNK           mpp_lnk_2d 
     132#     include "mpp_lnk_generic.h90" 
     133#     undef ROUTINE_LNK 
     134#     define MULTI 
     135#     define ROUTINE_LNK           mpp_lnk_2d_ptr 
     136#     include "mpp_lnk_generic.h90" 
     137#     undef ROUTINE_LNK 
     138#     undef MULTI 
     139#  undef DIM_2d 
     140   ! 
     141   !                       !==  3D array and array of 3D pointer  ==! 
     142   ! 
     143#  define DIM_3d 
     144#     define ROUTINE_LNK           mpp_lnk_3d 
     145#     include "mpp_lnk_generic.h90" 
     146#     undef ROUTINE_LNK 
     147#     define MULTI 
     148#     define ROUTINE_LNK           mpp_lnk_3d_ptr 
     149#     include "mpp_lnk_generic.h90" 
     150#     undef ROUTINE_LNK 
     151#     undef MULTI 
     152#  undef DIM_3d 
     153   ! 
     154   !                       !==  4D array and array of 4D pointer  ==! 
     155   ! 
     156#  define DIM_4d 
     157#     define ROUTINE_LNK           mpp_lnk_4d 
     158#     include "mpp_lnk_generic.h90" 
     159#     undef ROUTINE_LNK 
     160#     define MULTI 
     161#     define ROUTINE_LNK           mpp_lnk_4d_ptr 
     162#     include "mpp_lnk_generic.h90" 
     163#     undef ROUTINE_LNK 
     164#     undef MULTI 
     165#  undef DIM_4d 
     166 
     167   !!---------------------------------------------------------------------- 
     168   !!                   ***  routine mpp_nfd_(2,3,4)d  *** 
     169   !! 
     170   !!   * Argument : dummy argument use in mpp_nfd_... routines 
     171   !!                ptab      :   array or pointer of arrays on which the boundary condition is applied 
     172   !!                cd_nat    :   nature of array grid-points 
     173   !!                psgn      :   sign used across the north fold boundary 
     174   !!                kfld      :   optional, number of pt3d arrays 
     175   !!                kfillmode :   optional, method to be use to fill the halos (see jpfill* variables) 
     176   !!                pfillval  :   optional, background value (used with jpfillcopy) 
     177   !!---------------------------------------------------------------------- 
     178   ! 
     179   !                       !==  2D array and array of 2D pointer  ==! 
     180   ! 
     181#  define DIM_2d 
     182#     define ROUTINE_NFD           mpp_nfd_2d 
     183#     include "mpp_nfd_generic.h90" 
     184#     undef ROUTINE_NFD 
     185#     define MULTI 
     186#     define ROUTINE_NFD           mpp_nfd_2d_ptr 
     187#     include "mpp_nfd_generic.h90" 
     188#     undef ROUTINE_NFD 
     189#     undef MULTI 
     190#  undef DIM_2d 
     191   ! 
     192   !                       !==  3D array and array of 3D pointer  ==! 
     193   ! 
     194#  define DIM_3d 
     195#     define ROUTINE_NFD           mpp_nfd_3d 
     196#     include "mpp_nfd_generic.h90" 
     197#     undef ROUTINE_NFD 
     198#     define MULTI 
     199#     define ROUTINE_NFD           mpp_nfd_3d_ptr 
     200#     include "mpp_nfd_generic.h90" 
     201#     undef ROUTINE_NFD 
     202#     undef MULTI 
     203#  undef DIM_3d 
     204   ! 
     205   !                       !==  4D array and array of 4D pointer  ==! 
     206   ! 
     207#  define DIM_4d 
     208#     define ROUTINE_NFD           mpp_nfd_4d 
     209#     include "mpp_nfd_generic.h90" 
     210#     undef ROUTINE_NFD 
     211#     define MULTI 
     212#     define ROUTINE_NFD           mpp_nfd_4d_ptr 
     213#     include "mpp_nfd_generic.h90" 
     214#     undef ROUTINE_NFD 
     215#     undef MULTI 
     216#  undef DIM_4d 
     217 
     218 
    283219   !!====================================================================== 
     220 
     221 
     222 
     223   SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 
     224      !!--------------------------------------------------------------------- 
     225      !!                   ***  routine mpp_lbc_north_icb  *** 
     226      !! 
     227      !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
     228      !!              in mpp configuration in case of jpn1 > 1 and for 2d 
     229      !!              array with outer extra halo 
     230      !! 
     231      !! ** Method  :   North fold condition and mpp with more than one proc 
     232      !!              in i-direction require a specific treatment. We gather 
     233      !!              the 4+kextj northern lines of the global domain on 1 
     234      !!              processor and apply lbc north-fold on this sub array. 
     235      !!              Then we scatter the north fold array back to the processors. 
     236      !!              This routine accounts for an extra halo with icebergs 
     237      !!              and assumes ghost rows and columns have been suppressed. 
     238      !! 
     239      !!---------------------------------------------------------------------- 
     240      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
     241      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points 
     242      !                                                     !   = T ,  U , V , F or W -points 
     243      REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
     244      !!                                                    ! north fold, =  1. otherwise 
     245      INTEGER                 , INTENT(in   ) ::   kextj    ! Extra halo width at north fold 
     246      ! 
     247      INTEGER ::   ji, jj, jr 
     248      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
     249      INTEGER ::   ipj, ij, iproc 
     250      ! 
     251      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
     252      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e 
     253      !!---------------------------------------------------------------------- 
     254#if defined key_mpp_mpi 
     255      ! 
     256      ipj=4 
     257      ALLOCATE(        ztab_e(jpiglo, 1-kextj:ipj+kextj)       ,       & 
     258     &            znorthloc_e(jpimax, 1-kextj:ipj+kextj)       ,       & 
     259     &          znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni)    ) 
     260      ! 
     261      ztab_e(:,:)      = 0._wp 
     262      znorthloc_e(:,:) = 0._wp 
     263      ! 
     264      ij = 1 - kextj 
     265      ! put the last ipj+2*kextj lines of pt2d into znorthloc_e  
     266      DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
     267         znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 
     268         ij = ij + 1 
     269      END DO 
     270      ! 
     271      itaille = jpimax * ( ipj + 2*kextj ) 
     272      ! 
     273      IF( ln_timing ) CALL tic_tac(.TRUE.) 
     274      CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj)    , itaille, MPI_DOUBLE_PRECISION,    & 
     275         &                znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION,    & 
     276         &                ncomm_north, ierr ) 
     277      ! 
     278      IF( ln_timing ) CALL tic_tac(.FALSE.) 
     279      ! 
     280      DO jr = 1, ndim_rank_north            ! recover the global north array 
     281         iproc = nrank_north(jr) + 1 
     282         ildi = nldit (iproc) 
     283         ilei = nleit (iproc) 
     284         iilb = nimppt(iproc) 
     285         DO jj = 1-kextj, ipj+kextj 
     286            DO ji = ildi, ilei 
     287               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 
     288            END DO 
     289         END DO 
     290      END DO 
     291 
     292      ! 2. North-Fold boundary conditions 
     293      ! ---------------------------------- 
     294      CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) 
     295 
     296      ij = 1 - kextj 
     297      !! Scatter back to pt2d 
     298      DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
     299         DO ji= 1, jpi 
     300            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 
     301         END DO 
     302         ij  = ij +1 
     303      END DO 
     304      ! 
     305      DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 
     306      ! 
     307#endif 
     308   END SUBROUTINE mpp_lbc_north_icb 
     309 
     310 
     311   SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj ) 
     312      !!---------------------------------------------------------------------- 
     313      !!                  ***  routine mpp_lnk_2d_icb  *** 
     314      !! 
     315      !! ** Purpose :   Message passing management for 2d array (with extra halo for icebergs) 
     316      !!                This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) 
     317      !!                array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. 
     318      !! 
     319      !! ** Method  :   Use mppsend and mpprecv function for passing mask 
     320      !!      between processors following neighboring subdomains. 
     321      !!            domain parameters 
     322      !!                    jpi    : first dimension of the local subdomain 
     323      !!                    jpj    : second dimension of the local subdomain 
     324      !!                    kexti  : number of columns for extra outer halo 
     325      !!                    kextj  : number of rows for extra outer halo 
     326      !!                    nbondi : mark for "east-west local boundary" 
     327      !!                    nbondj : mark for "north-south local boundary" 
     328      !!                    noea   : number for local neighboring processors 
     329      !!                    nowe   : number for local neighboring processors 
     330      !!                    noso   : number for local neighboring processors 
     331      !!                    nono   : number for local neighboring processors 
     332      !!---------------------------------------------------------------------- 
     333      CHARACTER(len=*)                                        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
     334      REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
     335      CHARACTER(len=1)                                        , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
     336      REAL(wp)                                                , INTENT(in   ) ::   psgn     ! sign used across the north fold 
     337      INTEGER                                                 , INTENT(in   ) ::   kexti    ! extra i-halo width 
     338      INTEGER                                                 , INTENT(in   ) ::   kextj    ! extra j-halo width 
     339      ! 
     340      INTEGER  ::   jl   ! dummy loop indices 
     341      INTEGER  ::   imigr, iihom, ijhom        ! local integers 
     342      INTEGER  ::   ipreci, iprecj             !   -       - 
     343      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     344      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
     345      !! 
     346      REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) ::   r2dns, r2dsn 
     347      REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) ::   r2dwe, r2dew 
     348      !!---------------------------------------------------------------------- 
     349 
     350      ipreci = nn_hls + kexti      ! take into account outer extra 2D overlap area 
     351      iprecj = nn_hls + kextj 
     352 
     353      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) 
     354 
     355      ! 1. standard boundary treatment 
     356      ! ------------------------------ 
     357      ! Order matters Here !!!! 
     358      ! 
     359      !                                      ! East-West boundaries 
     360      !                                           !* Cyclic east-west 
     361      IF( l_Iperio ) THEN 
     362         pt2d(1-kexti:     1   ,:) = pt2d(jpim1-kexti: jpim1 ,:)       ! east 
     363         pt2d(  jpi  :jpi+kexti,:) = pt2d(     2     :2+kexti,:)       ! west 
     364         ! 
     365      ELSE                                        !* closed 
     366         IF( .NOT. cd_type == 'F' )   pt2d(  1-kexti   :nn_hls   ,:) = 0._wp    ! east except at F-point 
     367                                      pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp    ! west 
     368      ENDIF 
     369      !                                      ! North-South boundaries 
     370      IF( l_Jperio ) THEN                         !* cyclic (only with no mpp j-split) 
     371         pt2d(:,1-kextj:     1   ) = pt2d(:,jpjm1-kextj:  jpjm1)       ! north 
     372         pt2d(:,  jpj  :jpj+kextj) = pt2d(:,     2     :2+kextj)       ! south 
     373      ELSE                                        !* closed 
     374         IF( .NOT. cd_type == 'F' )   pt2d(:,  1-kextj   :nn_hls   ) = 0._wp    ! north except at F-point 
     375                                      pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp    ! south 
     376      ENDIF 
     377      ! 
     378 
     379      ! north fold treatment 
     380      ! ----------------------- 
     381      IF( npolj /= 0 ) THEN 
     382         ! 
     383         SELECT CASE ( jpni ) 
     384                   CASE ( 1 )     ;   CALL lbc_nfd          ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
     385                   CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
     386         END SELECT 
     387         ! 
     388      ENDIF 
     389 
     390      ! 2. East and west directions exchange 
     391      ! ------------------------------------ 
     392      ! we play with the neigbours AND the row number because of the periodicity 
     393      ! 
     394      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
     395      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     396         iihom = jpi-nreci-kexti 
     397         DO jl = 1, ipreci 
     398            r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 
     399            r2dwe(:,jl,1) = pt2d(iihom +jl,:) 
     400         END DO 
     401      END SELECT 
     402      ! 
     403      !                           ! Migrations 
     404      imigr = ipreci * ( jpj + 2*kextj ) 
     405      ! 
     406      IF( ln_timing ) CALL tic_tac(.TRUE.) 
     407      ! 
     408      SELECT CASE ( nbondi ) 
     409      CASE ( -1 ) 
     410         CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 
     411         CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
     412         CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     413      CASE ( 0 ) 
     414         CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
     415         CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 
     416         CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
     417         CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
     418         CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     419         CALL mpi_wait(ml_req2,ml_stat,ml_err) 
     420      CASE ( 1 ) 
     421         CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
     422         CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
     423         CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     424      END SELECT 
     425      ! 
     426      IF( ln_timing ) CALL tic_tac(.FALSE.) 
     427      ! 
     428      !                           ! Write Dirichlet lateral conditions 
     429      iihom = jpi - nn_hls 
     430      ! 
     431      SELECT CASE ( nbondi ) 
     432      CASE ( -1 ) 
     433         DO jl = 1, ipreci 
     434            pt2d(iihom+jl,:) = r2dew(:,jl,2) 
     435         END DO 
     436      CASE ( 0 ) 
     437         DO jl = 1, ipreci 
     438            pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
     439            pt2d(iihom+jl,:) = r2dew(:,jl,2) 
     440         END DO 
     441      CASE ( 1 ) 
     442         DO jl = 1, ipreci 
     443            pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
     444         END DO 
     445      END SELECT 
     446 
     447 
     448      ! 3. North and south directions 
     449      ! ----------------------------- 
     450      ! always closed : we play only with the neigbours 
     451      ! 
     452      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     453         ijhom = jpj-nrecj-kextj 
     454         DO jl = 1, iprecj 
     455            r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 
     456            r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 
     457         END DO 
     458      ENDIF 
     459      ! 
     460      !                           ! Migrations 
     461      imigr = iprecj * ( jpi + 2*kexti ) 
     462      ! 
     463      IF( ln_timing ) CALL tic_tac(.TRUE.) 
     464      ! 
     465      SELECT CASE ( nbondj ) 
     466      CASE ( -1 ) 
     467         CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 
     468         CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
     469         CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     470      CASE ( 0 ) 
     471         CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
     472         CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 
     473         CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
     474         CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
     475         CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     476         CALL mpi_wait(ml_req2,ml_stat,ml_err) 
     477      CASE ( 1 ) 
     478         CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
     479         CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
     480         CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     481      END SELECT 
     482      ! 
     483      IF( ln_timing ) CALL tic_tac(.FALSE.) 
     484      ! 
     485      !                           ! Write Dirichlet lateral conditions 
     486      ijhom = jpj - nn_hls 
     487      ! 
     488      SELECT CASE ( nbondj ) 
     489      CASE ( -1 ) 
     490         DO jl = 1, iprecj 
     491            pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
     492         END DO 
     493      CASE ( 0 ) 
     494         DO jl = 1, iprecj 
     495            pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
     496            pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
     497         END DO 
     498      CASE ( 1 ) 
     499         DO jl = 1, iprecj 
     500            pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
     501         END DO 
     502      END SELECT 
     503      ! 
     504   END SUBROUTINE mpp_lnk_2d_icb 
     505    
    284506END MODULE lbclnk 
    285507 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LBC/lbcnfd.F90

    r10425 r11822  
    2020   USE dom_oce        ! ocean space and time domain  
    2121   USE in_out_manager ! I/O manager 
     22   USE lib_mpp        ! MPP library 
    2223 
    2324   IMPLICIT NONE 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LBC/lib_mpp.F90

    r11504 r11822  
    3232   !!   ctl_opn       : Open file and check if required file is available. 
    3333   !!   ctl_nam       : Prints informations when an error occurs while reading a namelist 
    34    !!   get_unit      : give the index of an unused logical unit 
    35    !!---------------------------------------------------------------------- 
    36 #if   defined key_mpp_mpi 
    37    !!---------------------------------------------------------------------- 
    38    !!   'key_mpp_mpi'             MPI massively parallel processing library 
    39    !!---------------------------------------------------------------------- 
    40    !!   lib_mpp_alloc : allocate mpp arrays 
    41    !!   mynode        : indentify the processor unit 
     34   !!---------------------------------------------------------------------- 
     35   !!---------------------------------------------------------------------- 
     36   !!   mpp_start     : get local communicator its size and rank 
    4237   !!   mpp_lnk       : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 
    4338   !!   mpp_lnk_icb   : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 
    … …  
    5752   !!---------------------------------------------------------------------- 
    5853   USE dom_oce        ! ocean space and time domain 
    59    USE lbcnfd         ! north fold treatment 
    6054   USE in_out_manager ! I/O manager 
    6155 
    6256   IMPLICIT NONE 
    6357   PRIVATE 
    64  
    65    INTERFACE mpp_nfd 
    66       MODULE PROCEDURE   mpp_nfd_2d    , mpp_nfd_3d    , mpp_nfd_4d 
    67       MODULE PROCEDURE   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 
    68    END INTERFACE 
    69  
    70    ! Interface associated to the mpp_lnk_... routines is defined in lbclnk 
    71    PUBLIC   mpp_lnk_2d    , mpp_lnk_3d    , mpp_lnk_4d 
    72    PUBLIC   mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr 
    7358   ! 
    74 !!gm  this should be useless 
    75    PUBLIC   mpp_nfd_2d    , mpp_nfd_3d    , mpp_nfd_4d 
    76    PUBLIC   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 
    77 !!gm end 
    78    ! 
    79    PUBLIC   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 
    80    PUBLIC   mynode, mppstop, mppsync, mpp_comm_free 
     59   PUBLIC   ctl_stop, ctl_warn, ctl_opn, ctl_nam 
     60   PUBLIC   mpp_start, mppstop, mppsync, mpp_comm_free 
    8161   PUBLIC   mpp_ini_north 
    82    PUBLIC   mpp_lnk_2d_icb 
    83    PUBLIC   mpp_lbc_north_icb 
    8462   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
    8563   PUBLIC   mpp_delay_max, mpp_delay_sum, mpp_delay_rcv 
    … …  
    8765   PUBLIC   mpp_ini_znl 
    8866   PUBLIC   mppsend, mpprecv                          ! needed by TAM and ICB routines 
    89    PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d, mpp_lnk_bdy_4d 
     67   PUBLIC   mpp_report 
     68   PUBLIC   tic_tac 
     69#if ! defined key_mpp_mpi 
     70   PUBLIC MPI_Wtime 
     71#endif 
    9072    
    9173   !! * Interfaces 
    … …  
    11395   !!  MPI  variable definition !! 
    11496   !! ========================= !! 
     97#if   defined key_mpp_mpi 
    11598!$AGRIF_DO_NOT_TREAT 
    11699   INCLUDE 'mpif.h' 
    117100!$AGRIF_END_DO_NOT_TREAT 
    118  
    119101   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .TRUE.    !: mpp flag 
     102#else    
     103   INTEGER, PUBLIC, PARAMETER ::   MPI_STATUS_SIZE = 1 
     104   INTEGER, PUBLIC, PARAMETER ::   MPI_DOUBLE_PRECISION = 8 
     105   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.    !: mpp flag 
     106#endif 
    120107 
    121108   INTEGER, PARAMETER         ::   nprocmax = 2**10   ! maximun dimension (required to be a power of 2) 
    … …  
    146133   INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_north   !: dimension ndim_rank_north 
    147134 
    148    ! Type of send : standard, buffered, immediate 
    149    CHARACTER(len=1), PUBLIC ::   cn_mpi_send        !: type od mpi send/recieve (S=standard, B=bsend, I=isend) 
    150    LOGICAL         , PUBLIC ::   l_isend = .FALSE.  !: isend use indicator (T if cn_mpi_send='I') 
    151    INTEGER         , PUBLIC ::   nn_buffer          !: size of the buffer in case of mpi_bsend 
    152  
    153135   ! Communications summary report 
    154136   CHARACTER(len=128), DIMENSION(:), ALLOCATABLE ::   crname_lbc                   !: names of lbc_lnk calling routines 
    … …  
    159141   INTEGER, PUBLIC                               ::   ncom_freq                    !: frequency of comm diagnostic 
    160142   INTEGER, PUBLIC , DIMENSION(:,:), ALLOCATABLE ::   ncomm_sequence               !: size of communicated arrays (halos) 
    161    INTEGER, PARAMETER, PUBLIC                    ::   ncom_rec_max = 3000          !: max number of communication record 
     143   INTEGER, PARAMETER, PUBLIC                    ::   ncom_rec_max = 5000          !: max number of communication record 
    162144   INTEGER, PUBLIC                               ::   n_sequence_lbc = 0           !: # of communicated arraysvia lbc 
    163145   INTEGER, PUBLIC                               ::   n_sequence_glb = 0           !: # of global communications 
    … …  
    175157      COMPLEX(wp), POINTER, DIMENSION(:) ::  y1d => NULL() 
    176158   END TYPE DELAYARR 
    177    TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC  ::   todelay               
    178    INTEGER,          DIMENSION(nbdelay), PUBLIC  ::   ndelayid = -1     !: mpi request id of the delayed operations 
     159   TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC, SAVE  ::   todelay         !: must have SAVE for default initialization of DELAYARR 
     160   INTEGER,          DIMENSION(nbdelay), PUBLIC        ::   ndelayid = -1   !: mpi request id of the delayed operations 
    179161 
    180162   ! timing summary report 
    … …  
    186168   LOGICAL, PUBLIC ::   ln_nnogather                !: namelist control of northfold comms 
    187169   LOGICAL, PUBLIC ::   l_north_nogather = .FALSE.  !: internal control of northfold comms 
    188  
     170    
    189171   !!---------------------------------------------------------------------- 
    190172   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    194176CONTAINS 
    195177 
    196    FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm ) 
    197       !!---------------------------------------------------------------------- 
    198       !!                  ***  routine mynode  *** 
    199       !! 
    200       !! ** Purpose :   Find processor unit 
    201       !!---------------------------------------------------------------------- 
    202       CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt        ! 
    203       CHARACTER(len=*)             , INTENT(in   ) ::   ldname       ! 
    204       INTEGER                      , INTENT(in   ) ::   kumnam_ref   ! logical unit for reference namelist 
    205       INTEGER                      , INTENT(in   ) ::   kumnam_cfg   ! logical unit for configuration namelist 
    206       INTEGER                      , INTENT(inout) ::   kumond       ! logical unit for namelist output 
    207       INTEGER                      , INTENT(inout) ::   kstop        ! stop indicator 
     178   SUBROUTINE mpp_start( localComm ) 
     179      !!---------------------------------------------------------------------- 
     180      !!                  ***  routine mpp_start  *** 
     181      !! 
     182      !! ** Purpose :   get mpi_comm_oce, mpprank and mppsize 
     183      !!---------------------------------------------------------------------- 
    208184      INTEGER         , OPTIONAL   , INTENT(in   ) ::   localComm    ! 
    209185      ! 
    210       INTEGER ::   mynode, ierr, code, ji, ii, ios 
    211       LOGICAL ::   mpi_was_called 
    212       ! 
    213       NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, ln_nnogather 
    214       !!---------------------------------------------------------------------- 
    215       ! 
    216       ii = 1 
    217       WRITE(ldtxt(ii),*)                                                                  ;   ii = ii + 1 
    218       WRITE(ldtxt(ii),*) 'mynode : mpi initialisation'                                    ;   ii = ii + 1 
    219       WRITE(ldtxt(ii),*) '~~~~~~ '                                                        ;   ii = ii + 1 
    220       ! 
    221       REWIND( kumnam_ref )              ! Namelist nammpp in reference namelist: mpi variables 
    222       READ  ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901) 
    223 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp ) 
    224       ! 
    225       REWIND( kumnam_cfg )              ! Namelist nammpp in configuration namelist: mpi variables 
    226       READ  ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 
    227 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp ) 
    228       ! 
    229       !                              ! control print 
    230       WRITE(ldtxt(ii),*) '   Namelist nammpp'                                             ;   ii = ii + 1 
    231       WRITE(ldtxt(ii),*) '      mpi send type          cn_mpi_send = ', cn_mpi_send       ;   ii = ii + 1 
    232       WRITE(ldtxt(ii),*) '      size exported buffer   nn_buffer   = ', nn_buffer,' bytes';   ii = ii + 1 
    233       ! 
    234       IF( jpni < 1 .OR. jpnj < 1  ) THEN 
    235          WRITE(ldtxt(ii),*) '      jpni and jpnj will be calculated automatically' ;   ii = ii + 1 
    236       ELSE 
    237          WRITE(ldtxt(ii),*) '      processor grid extent in i         jpni = ',jpni       ;   ii = ii + 1 
    238          WRITE(ldtxt(ii),*) '      processor grid extent in j         jpnj = ',jpnj       ;   ii = ii + 1 
    239       ENDIF 
    240  
    241       WRITE(ldtxt(ii),*) '      avoid use of mpi_allgather at the north fold  ln_nnogather = ', ln_nnogather  ; ii = ii + 1 
    242  
    243       CALL mpi_initialized ( mpi_was_called, code ) 
    244       IF( code /= MPI_SUCCESS ) THEN 
    245          DO ji = 1, SIZE(ldtxt) 
    246             IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    247          END DO 
    248          WRITE(*, cform_err) 
    249          WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' 
    250          CALL mpi_abort( mpi_comm_world, code, ierr ) 
    251       ENDIF 
    252  
    253       IF( mpi_was_called ) THEN 
    254          ! 
    255          SELECT CASE ( cn_mpi_send ) 
    256          CASE ( 'S' )                ! Standard mpi send (blocking) 
    257             WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'             ;   ii = ii + 1 
    258          CASE ( 'B' )                ! Buffer mpi send (blocking) 
    259             WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'              ;   ii = ii + 1 
    260             IF( Agrif_Root() )   CALL mpi_init_oce( ldtxt, ii, ierr ) 
    261          CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    262             WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'           ;   ii = ii + 1 
    263             l_isend = .TRUE. 
    264          CASE DEFAULT 
    265             WRITE(ldtxt(ii),cform_err)                                                    ;   ii = ii + 1 
    266             WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send     ;   ii = ii + 1 
    267             kstop = kstop + 1 
    268          END SELECT 
    269          ! 
    270       ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN 
    271          WRITE(ldtxt(ii),cform_err)                                                    ;   ii = ii + 1 
    272          WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator '          ;   ii = ii + 1 
    273          WRITE(ldtxt(ii),*) '          without calling MPI_Init before ! '                ;   ii = ii + 1 
    274          kstop = kstop + 1 
    275       ELSE 
    276          SELECT CASE ( cn_mpi_send ) 
    277          CASE ( 'S' )                ! Standard mpi send (blocking) 
    278             WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'             ;   ii = ii + 1 
    279             CALL mpi_init( ierr ) 
    280          CASE ( 'B' )                ! Buffer mpi send (blocking) 
    281             WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'              ;   ii = ii + 1 
    282             IF( Agrif_Root() )   CALL mpi_init_oce( ldtxt, ii, ierr ) 
    283          CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    284             WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'           ;   ii = ii + 1 
    285             l_isend = .TRUE. 
    286             CALL mpi_init( ierr ) 
    287          CASE DEFAULT 
    288             WRITE(ldtxt(ii),cform_err)                                                    ;   ii = ii + 1 
    289             WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send     ;   ii = ii + 1 
    290             kstop = kstop + 1 
    291          END SELECT 
    292          ! 
    293       ENDIF 
    294  
     186      INTEGER ::   ierr 
     187      LOGICAL ::   llmpi_init 
     188      !!---------------------------------------------------------------------- 
     189#if defined key_mpp_mpi 
     190      ! 
     191      CALL mpi_initialized ( llmpi_init, ierr ) 
     192      IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_initialized' ) 
     193 
     194      IF( .NOT. llmpi_init ) THEN 
     195         IF( PRESENT(localComm) ) THEN 
     196            WRITE(ctmp1,*) ' lib_mpp: You cannot provide a local communicator ' 
     197            WRITE(ctmp2,*) '          without calling MPI_Init before ! ' 
     198            CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) 
     199         ENDIF 
     200         CALL mpi_init( ierr ) 
     201         IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_init' ) 
     202      ENDIF 
     203        
    295204      IF( PRESENT(localComm) ) THEN 
    296205         IF( Agrif_Root() ) THEN 
    … …  
    298207         ENDIF 
    299208      ELSE 
    300          CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code) 
    301          IF( code /= MPI_SUCCESS ) THEN 
    302             DO ji = 1, SIZE(ldtxt) 
    303                IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    304             END DO 
    305             WRITE(*, cform_err) 
    306             WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 
    307             CALL mpi_abort( mpi_comm_world, code, ierr ) 
    308          ENDIF 
    309       ENDIF 
    310  
    311 #if defined key_agrif 
     209         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, ierr) 
     210         IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_comm_dup' ) 
     211      ENDIF 
     212 
     213# if defined key_agrif 
    312214      IF( Agrif_Root() ) THEN 
    313215         CALL Agrif_MPI_Init(mpi_comm_oce) 
    … …  
    315217         CALL Agrif_MPI_set_grid_comm(mpi_comm_oce) 
    316218      ENDIF 
    317 #endif 
     219# endif 
    318220 
    319221      CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr ) 
    320222      CALL mpi_comm_size( mpi_comm_oce, mppsize, ierr ) 
    321       mynode = mpprank 
    322  
    323       IF( mynode == 0 ) THEN 
    324          CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
    325          WRITE(kumond, nammpp)       
    326       ENDIF 
    327223      ! 
    328224      CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) 
    329225      ! 
    330    END FUNCTION mynode 
    331  
    332    !!---------------------------------------------------------------------- 
    333    !!                   ***  routine mpp_lnk_(2,3,4)d  *** 
    334    !! 
    335    !!   * Argument : dummy argument use in mpp_lnk_... routines 
    336    !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
    337    !!                cd_nat :   nature of array grid-points 
    338    !!                psgn   :   sign used across the north fold boundary 
    339    !!                kfld   :   optional, number of pt3d arrays 
    340    !!                cd_mpp :   optional, fill the overlap area only 
    341    !!                pval   :   optional, background value (used at closed boundaries) 
    342    !!---------------------------------------------------------------------- 
    343    ! 
    344    !                       !==  2D array and array of 2D pointer  ==! 
    345    ! 
    346 #  define DIM_2d 
    347 #     define ROUTINE_LNK           mpp_lnk_2d 
    348 #     include "mpp_lnk_generic.h90" 
    349 #     undef ROUTINE_LNK 
    350 #     define MULTI 
    351 #     define ROUTINE_LNK           mpp_lnk_2d_ptr 
    352 #     include "mpp_lnk_generic.h90" 
    353 #     undef ROUTINE_LNK 
    354 #     undef MULTI 
    355 #  undef DIM_2d 
    356    ! 
    357    !                       !==  3D array and array of 3D pointer  ==! 
    358    ! 
    359 #  define DIM_3d 
    360 #     define ROUTINE_LNK           mpp_lnk_3d 
    361 #     include "mpp_lnk_generic.h90" 
    362 #     undef ROUTINE_LNK 
    363 #     define MULTI 
    364 #     define ROUTINE_LNK           mpp_lnk_3d_ptr 
    365 #     include "mpp_lnk_generic.h90" 
    366 #     undef ROUTINE_LNK 
    367 #     undef MULTI 
    368 #  undef DIM_3d 
    369    ! 
    370    !                       !==  4D array and array of 4D pointer  ==! 
    371    ! 
    372 #  define DIM_4d 
    373 #     define ROUTINE_LNK           mpp_lnk_4d 
    374 #     include "mpp_lnk_generic.h90" 
    375 #     undef ROUTINE_LNK 
    376 #     define MULTI 
    377 #     define ROUTINE_LNK           mpp_lnk_4d_ptr 
    378 #     include "mpp_lnk_generic.h90" 
    379 #     undef ROUTINE_LNK 
    380 #     undef MULTI 
    381 #  undef DIM_4d 
    382  
    383    !!---------------------------------------------------------------------- 
    384    !!                   ***  routine mpp_nfd_(2,3,4)d  *** 
    385    !! 
    386    !!   * Argument : dummy argument use in mpp_nfd_... routines 
    387    !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
    388    !!                cd_nat :   nature of array grid-points 
    389    !!                psgn   :   sign used across the north fold boundary 
    390    !!                kfld   :   optional, number of pt3d arrays 
    391    !!                cd_mpp :   optional, fill the overlap area only 
    392    !!                pval   :   optional, background value (used at closed boundaries) 
    393    !!---------------------------------------------------------------------- 
    394    ! 
    395    !                       !==  2D array and array of 2D pointer  ==! 
    396    ! 
    397 #  define DIM_2d 
    398 #     define ROUTINE_NFD           mpp_nfd_2d 
    399 #     include "mpp_nfd_generic.h90" 
    400 #     undef ROUTINE_NFD 
    401 #     define MULTI 
    402 #     define ROUTINE_NFD           mpp_nfd_2d_ptr 
    403 #     include "mpp_nfd_generic.h90" 
    404 #     undef ROUTINE_NFD 
    405 #     undef MULTI 
    406 #  undef DIM_2d 
    407    ! 
    408    !                       !==  3D array and array of 3D pointer  ==! 
    409    ! 
    410 #  define DIM_3d 
    411 #     define ROUTINE_NFD           mpp_nfd_3d 
    412 #     include "mpp_nfd_generic.h90" 
    413 #     undef ROUTINE_NFD 
    414 #     define MULTI 
    415 #     define ROUTINE_NFD           mpp_nfd_3d_ptr 
    416 #     include "mpp_nfd_generic.h90" 
    417 #     undef ROUTINE_NFD 
    418 #     undef MULTI 
    419 #  undef DIM_3d 
    420    ! 
    421    !                       !==  4D array and array of 4D pointer  ==! 
    422    ! 
    423 #  define DIM_4d 
    424 #     define ROUTINE_NFD           mpp_nfd_4d 
    425 #     include "mpp_nfd_generic.h90" 
    426 #     undef ROUTINE_NFD 
    427 #     define MULTI 
    428 #     define ROUTINE_NFD           mpp_nfd_4d_ptr 
    429 #     include "mpp_nfd_generic.h90" 
    430 #     undef ROUTINE_NFD 
    431 #     undef MULTI 
    432 #  undef DIM_4d 
    433  
    434  
    435    !!---------------------------------------------------------------------- 
    436    !!                   ***  routine mpp_lnk_bdy_(2,3,4)d  *** 
    437    !! 
    438    !!   * Argument : dummy argument use in mpp_lnk_... routines 
    439    !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
    440    !!                cd_nat :   nature of array grid-points 
    441    !!                psgn   :   sign used across the north fold boundary 
    442    !!                kb_bdy :   BDY boundary set 
    443    !!                kfld   :   optional, number of pt3d arrays 
    444    !!---------------------------------------------------------------------- 
    445    ! 
    446    !                       !==  2D array and array of 2D pointer  ==! 
    447    ! 
    448 #  define DIM_2d 
    449 #     define ROUTINE_BDY           mpp_lnk_bdy_2d 
    450 #     include "mpp_bdy_generic.h90" 
    451 #     undef ROUTINE_BDY 
    452 #  undef DIM_2d 
    453    ! 
    454    !                       !==  3D array and array of 3D pointer  ==! 
    455    ! 
    456 #  define DIM_3d 
    457 #     define ROUTINE_BDY           mpp_lnk_bdy_3d 
    458 #     include "mpp_bdy_generic.h90" 
    459 #     undef ROUTINE_BDY 
    460 #  undef DIM_3d 
    461    ! 
    462    !                       !==  4D array and array of 4D pointer  ==! 
    463    ! 
    464 #  define DIM_4d 
    465 #     define ROUTINE_BDY           mpp_lnk_bdy_4d 
    466 #     include "mpp_bdy_generic.h90" 
    467 #     undef ROUTINE_BDY 
    468 #  undef DIM_4d 
    469  
    470    !!---------------------------------------------------------------------- 
    471    !! 
    472    !!   load_array  &   mpp_lnk_2d_9    à generaliser a 3D et 4D 
    473     
    474     
    475    !!    mpp_lnk_sum_2d et 3D   ====>>>>>>   à virer du code !!!! 
    476     
    477     
    478    !!---------------------------------------------------------------------- 
    479  
     226#else 
     227      IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 
     228      mppsize = 1 
     229      mpprank = 0 
     230#endif 
     231   END SUBROUTINE mpp_start 
    480232 
    481233 
    … …  
    496248      !!---------------------------------------------------------------------- 
    497249      ! 
    498       SELECT CASE ( cn_mpi_send ) 
    499       CASE ( 'S' )                ! Standard mpi send (blocking) 
    500          CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce        , iflag ) 
    501       CASE ( 'B' )                ! Buffer mpi send (blocking) 
    502          CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce        , iflag ) 
    503       CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    504          ! be carefull, one more argument here : the mpi request identifier.. 
    505          CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
    506       END SELECT 
     250#if defined key_mpp_mpi 
     251      CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
     252#endif 
    507253      ! 
    508254   END SUBROUTINE mppsend 
    … …  
    526272      !!---------------------------------------------------------------------- 
    527273      ! 
     274#if defined key_mpp_mpi 
    528275      ! If a specific process number has been passed to the receive call, 
    529276      ! use that one. Default is to use mpi_any_source 
    … …  
    532279      ! 
    533280      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 
     281#endif 
    534282      ! 
    535283   END SUBROUTINE mpprecv 
    … …  
    552300      ! 
    553301      itaille = jpi * jpj 
     302#if defined key_mpp_mpi 
    554303      CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille     ,   & 
    555304         &                            mpi_double_precision, kp , mpi_comm_oce, ierror ) 
     305#else 
     306      pio(:,:,1) = ptab(:,:) 
     307#endif 
    556308      ! 
    557309   END SUBROUTINE mppgather 
    … …  
    575327      itaille = jpi * jpj 
    576328      ! 
     329#if defined key_mpp_mpi 
    577330      CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille     ,   & 
    578331         &                            mpi_double_precision, kp  , mpi_comm_oce, ierror ) 
     332#else 
     333      ptab(:,:) = pio(:,:,1) 
     334#endif 
    579335      ! 
    580336   END SUBROUTINE mppscatter 
    … …  
    600356      COMPLEX(wp), ALLOCATABLE, DIMENSION(:) ::   ytmp 
    601357      !!---------------------------------------------------------------------- 
     358#if defined key_mpp_mpi 
    602359      ilocalcomm = mpi_comm_oce 
    603360      IF( PRESENT(kcom) )   ilocalcomm = kcom 
    … …  
    638395 
    639396      ! send y_in into todelay(idvar)%y1d with a non-blocking communication 
    640 #if defined key_mpi2 
     397# if defined key_mpi2 
    641398      IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 
    642399      CALL  mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 
    643400      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
     401# else 
     402      CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 
     403# endif 
    644404#else 
    645       CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 
     405      pout(:) = REAL(y_in(:), wp) 
    646406#endif 
    647407 
    … …  
    667427      INTEGER ::   ierr, ilocalcomm 
    668428      !!---------------------------------------------------------------------- 
     429#if defined key_mpp_mpi 
    669430      ilocalcomm = mpi_comm_oce 
    670431      IF( PRESENT(kcom) )   ilocalcomm = kcom 
    … …  
    701462 
    702463      ! send p_in into todelay(idvar)%z1d with a non-blocking communication 
    703 #if defined key_mpi2 
     464# if defined key_mpi2 
    704465      IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 
    705466      CALL  mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
    706467      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
     468# else 
     469      CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
     470# endif 
    707471#else 
    708       CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
     472      pout(:) = p_in(:) 
    709473#endif 
    710474 
    … …  
    722486      INTEGER ::   ierr 
    723487      !!---------------------------------------------------------------------- 
     488#if defined key_mpp_mpi 
    724489      IF( ndelayid(kid) /= -2 ) THEN   
    725490#if ! defined key_mpi2 
    … …  
    731496         ndelayid(kid) = -2   ! add flag to know that mpi_wait was already called on kid 
    732497      ENDIF 
     498#endif 
    733499   END SUBROUTINE mpp_delay_rcv 
    734500 
    … …  
    889655      !!----------------------------------------------------------------------- 
    890656      ! 
     657#if defined key_mpp_mpi 
    891658      CALL mpi_barrier( mpi_comm_oce, ierror ) 
     659#endif 
    892660      ! 
    893661   END SUBROUTINE mppsync 
    894662 
    895663 
    896    SUBROUTINE mppstop( ldfinal, ld_force_abort )  
     664   SUBROUTINE mppstop( ld_abort )  
    897665      !!---------------------------------------------------------------------- 
    898666      !!                  ***  routine mppstop  *** 
    … …  
    901669      !! 
    902670      !!---------------------------------------------------------------------- 
    903       LOGICAL, OPTIONAL, INTENT(in) :: ldfinal    ! source process number 
    904       LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort    ! source process number 
    905       LOGICAL ::   llfinal, ll_force_abort 
     671      LOGICAL, OPTIONAL, INTENT(in) :: ld_abort    ! source process number 
     672      LOGICAL ::   ll_abort 
    906673      INTEGER ::   info 
    907674      !!---------------------------------------------------------------------- 
    908       llfinal = .FALSE. 
    909       IF( PRESENT(ldfinal) ) llfinal = ldfinal 
    910       ll_force_abort = .FALSE. 
    911       IF( PRESENT(ld_force_abort) ) ll_force_abort = ld_force_abort 
    912       ! 
    913       IF(ll_force_abort) THEN 
     675      ll_abort = .FALSE. 
     676      IF( PRESENT(ld_abort) ) ll_abort = ld_abort 
     677      ! 
     678#if defined key_mpp_mpi 
     679      IF(ll_abort) THEN 
    914680         CALL mpi_abort( MPI_COMM_WORLD ) 
    915681      ELSE 
    … …  
    917683         CALL mpi_finalize( info ) 
    918684      ENDIF 
    919       IF( .NOT. llfinal ) STOP 123456 
     685#endif 
     686      IF( ll_abort ) STOP 123 
    920687      ! 
    921688   END SUBROUTINE mppstop 
    … …  
    929696      !!---------------------------------------------------------------------- 
    930697      ! 
     698#if defined key_mpp_mpi 
    931699      CALL MPI_COMM_FREE(kcom, ierr) 
     700#endif 
    932701      ! 
    933702   END SUBROUTINE mpp_comm_free 
    … …  
    959728      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kwork 
    960729      !!---------------------------------------------------------------------- 
     730#if defined key_mpp_mpi 
    961731      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world     : ', ngrp_world 
    962732      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world 
    … …  
    964734      ! 
    965735      ALLOCATE( kwork(jpnij), STAT=ierr ) 
    966       IF( ierr /= 0 ) THEN 
    967          WRITE(kumout, cform_err) 
    968          WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij' 
    969          CALL mppstop 
    970       ENDIF 
     736      IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_ini_znl : failed to allocate 1D array of length jpnij') 
    971737 
    972738      IF( jpnj == 1 ) THEN 
    … …  
    1030796 
    1031797      DEALLOCATE(kwork) 
     798#endif 
    1032799 
    1033800   END SUBROUTINE mpp_ini_znl 
    … …  
    1061828      !!---------------------------------------------------------------------- 
    1062829      ! 
     830#if defined key_mpp_mpi 
    1063831      njmppmax = MAXVAL( njmppt ) 
    1064832      ! 
    … …  
    1092860      CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr ) 
    1093861      ! 
     862#endif 
    1094863   END SUBROUTINE mpp_ini_north 
    1095  
    1096  
    1097    SUBROUTINE mpi_init_oce( ldtxt, ksft, code ) 
    1098       !!--------------------------------------------------------------------- 
    1099       !!                   ***  routine mpp_init.opa  *** 
    1100       !! 
    1101       !! ** Purpose :: export and attach a MPI buffer for bsend 
    1102       !! 
    1103       !! ** Method  :: define buffer size in namelist, if 0 no buffer attachment 
    1104       !!            but classical mpi_init 
    1105       !! 
    1106       !! History :: 01/11 :: IDRIS initial version for IBM only 
    1107       !!            08/04 :: R. Benshila, generalisation 
    1108       !!--------------------------------------------------------------------- 
    1109       CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt 
    1110       INTEGER                      , INTENT(inout) ::   ksft 
    1111       INTEGER                      , INTENT(  out) ::   code 
    1112       INTEGER                                      ::   ierr, ji 
    1113       LOGICAL                                      ::   mpi_was_called 
    1114       !!--------------------------------------------------------------------- 
    1115       ! 
    1116       CALL mpi_initialized( mpi_was_called, code )      ! MPI initialization 
    1117       IF ( code /= MPI_SUCCESS ) THEN 
    1118          DO ji = 1, SIZE(ldtxt) 
    1119             IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    1120          END DO 
    1121          WRITE(*, cform_err) 
    1122          WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized' 
    1123          CALL mpi_abort( mpi_comm_world, code, ierr ) 
    1124       ENDIF 
    1125       ! 
    1126       IF( .NOT. mpi_was_called ) THEN 
    1127          CALL mpi_init( code ) 
    1128          CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code ) 
    1129          IF ( code /= MPI_SUCCESS ) THEN 
    1130             DO ji = 1, SIZE(ldtxt) 
    1131                IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    1132             END DO 
    1133             WRITE(*, cform_err) 
    1134             WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 
    1135             CALL mpi_abort( mpi_comm_world, code, ierr ) 
    1136          ENDIF 
    1137       ENDIF 
    1138       ! 
    1139       IF( nn_buffer > 0 ) THEN 
    1140          WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of  : ', nn_buffer   ;   ksft = ksft + 1 
    1141          ! Buffer allocation and attachment 
    1142          ALLOCATE( tampon(nn_buffer), stat = ierr ) 
    1143          IF( ierr /= 0 ) THEN 
    1144             DO ji = 1, SIZE(ldtxt) 
    1145                IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    1146             END DO 
    1147             WRITE(*, cform_err) 
    1148             WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr 
    1149             CALL mpi_abort( mpi_comm_world, code, ierr ) 
    1150          END IF 
    1151          CALL mpi_buffer_attach( tampon, nn_buffer, code ) 
    1152       ENDIF 
    1153       ! 
    1154    END SUBROUTINE mpi_init_oce 
    1155864 
    1156865 
    … …  
    1186895 
    1187896 
    1188    SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 
    1189       !!--------------------------------------------------------------------- 
    1190       !!                   ***  routine mpp_lbc_north_icb  *** 
    1191       !! 
    1192       !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    1193       !!              in mpp configuration in case of jpn1 > 1 and for 2d 
    1194       !!              array with outer extra halo 
    1195       !! 
    1196       !! ** Method  :   North fold condition and mpp with more than one proc 
    1197       !!              in i-direction require a specific treatment. We gather 
    1198       !!              the 4+kextj northern lines of the global domain on 1 
    1199       !!              processor and apply lbc north-fold on this sub array. 
    1200       !!              Then we scatter the north fold array back to the processors. 
    1201       !!              This routine accounts for an extra halo with icebergs 
    1202       !!              and assumes ghost rows and columns have been suppressed. 
    1203       !! 
    1204       !!---------------------------------------------------------------------- 
    1205       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    1206       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points 
    1207       !                                                     !   = T ,  U , V , F or W -points 
    1208       REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
    1209       !!                                                    ! north fold, =  1. otherwise 
    1210       INTEGER                 , INTENT(in   ) ::   kextj    ! Extra halo width at north fold 
    1211       ! 
    1212       INTEGER ::   ji, jj, jr 
    1213       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    1214       INTEGER ::   ipj, ij, iproc 
    1215       ! 
    1216       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
    1217       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e 
    1218       !!---------------------------------------------------------------------- 
    1219       ! 
    1220       ipj=4 
    1221       ALLOCATE(        ztab_e(jpiglo, 1-kextj:ipj+kextj)       ,       & 
    1222      &            znorthloc_e(jpimax, 1-kextj:ipj+kextj)       ,       & 
    1223      &          znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni)    ) 
    1224       ! 
    1225       ztab_e(:,:)      = 0._wp 
    1226       znorthloc_e(:,:) = 0._wp 
    1227       ! 
    1228       ij = 1 - kextj 
    1229       ! put the last ipj+2*kextj lines of pt2d into znorthloc_e  
    1230       DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
    1231          znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 
    1232          ij = ij + 1 
    1233       END DO 
    1234       ! 
    1235       itaille = jpimax * ( ipj + 2*kextj ) 
    1236       ! 
    1237       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    1238       CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj)    , itaille, MPI_DOUBLE_PRECISION,    & 
    1239          &                znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION,    & 
    1240          &                ncomm_north, ierr ) 
    1241       ! 
    1242       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    1243       ! 
    1244       DO jr = 1, ndim_rank_north            ! recover the global north array 
    1245          iproc = nrank_north(jr) + 1 
    1246          ildi = nldit (iproc) 
    1247          ilei = nleit (iproc) 
    1248          iilb = nimppt(iproc) 
    1249          DO jj = 1-kextj, ipj+kextj 
    1250             DO ji = ildi, ilei 
    1251                ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 
    1252             END DO 
    1253          END DO 
    1254       END DO 
    1255  
    1256       ! 2. North-Fold boundary conditions 
    1257       ! ---------------------------------- 
    1258       CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) 
    1259  
    1260       ij = 1 - kextj 
    1261       !! Scatter back to pt2d 
    1262       DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
    1263          DO ji= 1, jpi 
    1264             pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 
    1265          END DO 
    1266          ij  = ij +1 
    1267       END DO 
    1268       ! 
    1269       DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 
    1270       ! 
    1271    END SUBROUTINE mpp_lbc_north_icb 
    1272  
    1273  
    1274    SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj ) 
    1275       !!---------------------------------------------------------------------- 
    1276       !!                  ***  routine mpp_lnk_2d_icb  *** 
    1277       !! 
    1278       !! ** Purpose :   Message passing management for 2d array (with extra halo for icebergs) 
    1279       !!                This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) 
    1280       !!                array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. 
    1281       !! 
    1282       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1283       !!      between processors following neighboring subdomains. 
    1284       !!            domain parameters 
    1285       !!                    jpi    : first dimension of the local subdomain 
    1286       !!                    jpj    : second dimension of the local subdomain 
    1287       !!                    kexti  : number of columns for extra outer halo 
    1288       !!                    kextj  : number of rows for extra outer halo 
    1289       !!                    nbondi : mark for "east-west local boundary" 
    1290       !!                    nbondj : mark for "north-south local boundary" 
    1291       !!                    noea   : number for local neighboring processors 
    1292       !!                    nowe   : number for local neighboring processors 
    1293       !!                    noso   : number for local neighboring processors 
    1294       !!                    nono   : number for local neighboring processors 
    1295       !!---------------------------------------------------------------------- 
    1296       CHARACTER(len=*)                                        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    1297       REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    1298       CHARACTER(len=1)                                        , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
    1299       REAL(wp)                                                , INTENT(in   ) ::   psgn     ! sign used across the north fold 
    1300       INTEGER                                                 , INTENT(in   ) ::   kexti    ! extra i-halo width 
    1301       INTEGER                                                 , INTENT(in   ) ::   kextj    ! extra j-halo width 
    1302       ! 
    1303       INTEGER  ::   jl   ! dummy loop indices 
    1304       INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    1305       INTEGER  ::   ipreci, iprecj             !   -       - 
    1306       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1307       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    1308       !! 
    1309       REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) ::   r2dns, r2dsn 
    1310       REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) ::   r2dwe, r2dew 
    1311       !!---------------------------------------------------------------------- 
    1312  
    1313       ipreci = nn_hls + kexti      ! take into account outer extra 2D overlap area 
    1314       iprecj = nn_hls + kextj 
    1315  
    1316       IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) 
    1317  
    1318       ! 1. standard boundary treatment 
    1319       ! ------------------------------ 
    1320       ! Order matters Here !!!! 
    1321       ! 
    1322       !                                      ! East-West boundaries 
    1323       !                                           !* Cyclic east-west 
    1324       IF( l_Iperio ) THEN 
    1325          pt2d(1-kexti:     1   ,:) = pt2d(jpim1-kexti: jpim1 ,:)       ! east 
    1326          pt2d(  jpi  :jpi+kexti,:) = pt2d(     2     :2+kexti,:)       ! west 
    1327          ! 
    1328       ELSE                                        !* closed 
    1329          IF( .NOT. cd_type == 'F' )   pt2d(  1-kexti   :nn_hls   ,:) = 0._wp    ! east except at F-point 
    1330                                       pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp    ! west 
    1331       ENDIF 
    1332       !                                      ! North-South boundaries 
    1333       IF( l_Jperio ) THEN                         !* cyclic (only with no mpp j-split) 
    1334          pt2d(:,1-kextj:     1   ) = pt2d(:,jpjm1-kextj:  jpjm1)       ! north 
    1335          pt2d(:,  jpj  :jpj+kextj) = pt2d(:,     2     :2+kextj)       ! south 
    1336       ELSE                                        !* closed 
    1337          IF( .NOT. cd_type == 'F' )   pt2d(:,  1-kextj   :nn_hls   ) = 0._wp    ! north except at F-point 
    1338                                       pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp    ! south 
    1339       ENDIF 
    1340       ! 
    1341  
    1342       ! north fold treatment 
    1343       ! ----------------------- 
    1344       IF( npolj /= 0 ) THEN 
    1345          ! 
    1346          SELECT CASE ( jpni ) 
    1347                    CASE ( 1 )     ;   CALL lbc_nfd          ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
    1348                    CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
    1349          END SELECT 
    1350          ! 
    1351       ENDIF 
    1352  
    1353       ! 2. East and west directions exchange 
    1354       ! ------------------------------------ 
    1355       ! we play with the neigbours AND the row number because of the periodicity 
    1356       ! 
    1357       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    1358       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1359          iihom = jpi-nreci-kexti 
    1360          DO jl = 1, ipreci 
    1361             r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 
    1362             r2dwe(:,jl,1) = pt2d(iihom +jl,:) 
    1363          END DO 
    1364       END SELECT 
    1365       ! 
    1366       !                           ! Migrations 
    1367       imigr = ipreci * ( jpj + 2*kextj ) 
    1368       ! 
    1369       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    1370       ! 
    1371       SELECT CASE ( nbondi ) 
    1372       CASE ( -1 ) 
    1373          CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 
    1374          CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
    1375          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1376       CASE ( 0 ) 
    1377          CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
    1378          CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 
    1379          CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
    1380          CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    1381          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1382          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1383       CASE ( 1 ) 
    1384          CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
    1385          CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    1386          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1387       END SELECT 
    1388       ! 
    1389       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    1390       ! 
    1391       !                           ! Write Dirichlet lateral conditions 
    1392       iihom = jpi - nn_hls 
    1393       ! 
    1394       SELECT CASE ( nbondi ) 
    1395       CASE ( -1 ) 
    1396          DO jl = 1, ipreci 
    1397             pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    1398          END DO 
    1399       CASE ( 0 ) 
    1400          DO jl = 1, ipreci 
    1401             pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
    1402             pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    1403          END DO 
    1404       CASE ( 1 ) 
    1405          DO jl = 1, ipreci 
    1406             pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
    1407          END DO 
    1408       END SELECT 
    1409  
    1410  
    1411       ! 3. North and south directions 
    1412       ! ----------------------------- 
    1413       ! always closed : we play only with the neigbours 
    1414       ! 
    1415       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    1416          ijhom = jpj-nrecj-kextj 
    1417          DO jl = 1, iprecj 
    1418             r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 
    1419             r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 
    1420          END DO 
    1421       ENDIF 
    1422       ! 
    1423       !                           ! Migrations 
    1424       imigr = iprecj * ( jpi + 2*kexti ) 
    1425       ! 
    1426       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    1427       ! 
    1428       SELECT CASE ( nbondj ) 
    1429       CASE ( -1 ) 
    1430          CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 
    1431          CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
    1432          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1433       CASE ( 0 ) 
    1434          CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
    1435          CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 
    1436          CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
    1437          CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    1438          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1439          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1440       CASE ( 1 ) 
    1441          CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
    1442          CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    1443          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1444       END SELECT 
    1445       ! 
    1446       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    1447       ! 
    1448       !                           ! Write Dirichlet lateral conditions 
    1449       ijhom = jpj - nn_hls 
    1450       ! 
    1451       SELECT CASE ( nbondj ) 
    1452       CASE ( -1 ) 
    1453          DO jl = 1, iprecj 
    1454             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    1455          END DO 
    1456       CASE ( 0 ) 
    1457          DO jl = 1, iprecj 
    1458             pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
    1459             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    1460          END DO 
    1461       CASE ( 1 ) 
    1462          DO jl = 1, iprecj 
    1463             pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
    1464          END DO 
    1465       END SELECT 
    1466       ! 
    1467    END SUBROUTINE mpp_lnk_2d_icb 
    1468  
    1469  
    1470897   SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb, ld_dlg ) 
    1471898      !!---------------------------------------------------------------------- 
    … …  
    1479906      LOGICAL         , OPTIONAL, INTENT(in   ) ::   ld_lbc, ld_glb, ld_dlg 
    1480907      !! 
     908      CHARACTER(len=128)                        ::   ccountname  ! name of a subroutine to count communications 
    1481909      LOGICAL ::   ll_lbc, ll_glb, ll_dlg 
    1482       INTEGER ::    ji,  jj,  jk,  jh, jf   ! dummy loop indices 
    1483       !!---------------------------------------------------------------------- 
     910      INTEGER ::    ji,  jj,  jk,  jh, jf, jcount   ! dummy loop indices 
     911      !!---------------------------------------------------------------------- 
     912#if defined key_mpp_mpi 
    1484913      ! 
    1485914      ll_lbc = .FALSE. 
    … …  
    1536965         WRITE(numcom,*) ' ' 
    1537966         WRITE(numcom,*) ' lbc_lnk called' 
    1538          jj = 1 
    1539          DO ji = 2, n_sequence_lbc 
    1540             IF( crname_lbc(ji-1) /= crname_lbc(ji) ) THEN 
    1541                WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(ji-1)) 
    1542                jj = 0 
     967         DO ji = 1, n_sequence_lbc - 1 
     968            IF ( crname_lbc(ji) /= 'already counted' ) THEN 
     969               ccountname = crname_lbc(ji) 
     970               crname_lbc(ji) = 'already counted' 
     971               jcount = 1 
     972               DO jj = ji + 1, n_sequence_lbc 
     973                  IF ( ccountname ==  crname_lbc(jj) ) THEN 
     974                     jcount = jcount + 1 
     975                     crname_lbc(jj) = 'already counted' 
     976                  END IF 
     977               END DO 
     978               WRITE(numcom,'(A, I4, A, A)') ' - ', jcount,' times by subroutine ', TRIM(ccountname) 
    1543979            END IF 
    1544             jj = jj + 1  
    1545980         END DO 
    1546          WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(n_sequence_lbc)) 
     981         IF ( crname_lbc(n_sequence_lbc) /= 'already counted' ) THEN 
     982            WRITE(numcom,'(A, I4, A, A)') ' - ', 1,' times by subroutine ', TRIM(crname_lbc(ncom_rec_max)) 
     983         END IF 
    1547984         WRITE(numcom,*) ' ' 
    1548985         IF ( n_sequence_glb > 0 ) THEN 
    … …  
    15831020         DEALLOCATE(crname_lbc) 
    15841021      ENDIF 
     1022#endif 
    15851023   END SUBROUTINE mpp_report 
    15861024 
    … …  
    15931031    REAL(wp),               SAVE :: tic_ct = 0._wp 
    15941032    INTEGER :: ii 
     1033#if defined key_mpp_mpi 
    15951034 
    15961035    IF( ncom_stp <= nit000 ) RETURN 
    … …  
    16081047       tic_ct = MPI_Wtime()                                                        ! start count tac->tic (waiting time) 
    16091048    ENDIF 
     1049#endif 
    16101050     
    16111051   END SUBROUTINE tic_tac 
    16121052 
     1053#if ! defined key_mpp_mpi 
     1054   SUBROUTINE mpi_wait(request, status, ierror) 
     1055      INTEGER                            , INTENT(in   ) ::   request 
     1056      INTEGER, DIMENSION(MPI_STATUS_SIZE), INTENT(  out) ::   status 
     1057      INTEGER                            , INTENT(  out) ::   ierror 
     1058   END SUBROUTINE mpi_wait 
     1059 
    16131060    
    1614 #else 
    1615    !!---------------------------------------------------------------------- 
    1616    !!   Default case:            Dummy module        share memory computing 
    1617    !!---------------------------------------------------------------------- 
    1618    USE in_out_manager 
    1619  
    1620    INTERFACE mpp_sum 
    1621       MODULE PROCEDURE mppsum_int, mppsum_a_int, mppsum_real, mppsum_a_real, mppsum_realdd, mppsum_a_realdd 
    1622    END INTERFACE 
    1623    INTERFACE mpp_max 
    1624       MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real 
    1625    END INTERFACE 
    1626    INTERFACE mpp_min 
    1627       MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 
    1628    END INTERFACE 
    1629    INTERFACE mpp_minloc 
    1630       MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 
    1631    END INTERFACE 
    1632    INTERFACE mpp_maxloc 
    1633       MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
    1634    END INTERFACE 
    1635  
    1636    LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag 
    1637    LOGICAL, PUBLIC            ::   ln_nnogather          !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 
    1638    INTEGER, PUBLIC            ::   mpi_comm_oce          ! opa local communicator 
    1639  
    1640    INTEGER, PARAMETER, PUBLIC               ::   nbdelay = 0   ! make sure we don't enter loops: DO ji = 1, nbdelay 
    1641    CHARACTER(len=32), DIMENSION(1), PUBLIC  ::   c_delaylist = 'empty' 
    1642    CHARACTER(len=32), DIMENSION(1), PUBLIC  ::   c_delaycpnt = 'empty' 
    1643    LOGICAL, PUBLIC                          ::   l_full_nf_update = .TRUE. 
    1644    TYPE ::   DELAYARR 
    1645       REAL(   wp), POINTER, DIMENSION(:) ::  z1d => NULL() 
    1646       COMPLEX(wp), POINTER, DIMENSION(:) ::  y1d => NULL() 
    1647    END TYPE DELAYARR 
    1648    TYPE( DELAYARR ), DIMENSION(1), PUBLIC  ::   todelay               
    1649    INTEGER,  PUBLIC, DIMENSION(1)           ::   ndelayid = -1 
    1650    !!---------------------------------------------------------------------- 
    1651 CONTAINS 
    1652  
    1653    INTEGER FUNCTION lib_mpp_alloc(kumout)          ! Dummy function 
    1654       INTEGER, INTENT(in) ::   kumout 
    1655       lib_mpp_alloc = 0 
    1656    END FUNCTION lib_mpp_alloc 
    1657  
    1658    FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg,  kumond , kstop, localComm ) RESULT (function_value) 
    1659       INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm 
    1660       CHARACTER(len=*),DIMENSION(:) ::   ldtxt 
    1661       CHARACTER(len=*) ::   ldname 
    1662       INTEGER ::   kumnam_ref, knumnam_cfg , kumond , kstop 
    1663       IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 
    1664       function_value = 0 
    1665       IF( .FALSE. )   ldtxt(:) = 'never done' 
    1666       CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
    1667    END FUNCTION mynode 
    1668  
    1669    SUBROUTINE mppsync                       ! Dummy routine 
    1670    END SUBROUTINE mppsync 
    1671  
    1672    !!---------------------------------------------------------------------- 
    1673    !!    ***  mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real  *** 
    1674    !!    
    1675    !!---------------------------------------------------------------------- 
    1676    !! 
    1677 #  define OPERATION_MAX 
    1678 #  define INTEGER_TYPE 
    1679 #  define DIM_0d 
    1680 #     define ROUTINE_ALLREDUCE           mppmax_int 
    1681 #     include "mpp_allreduce_generic.h90" 
    1682 #     undef ROUTINE_ALLREDUCE 
    1683 #  undef DIM_0d 
    1684 #  define DIM_1d 
    1685 #     define ROUTINE_ALLREDUCE           mppmax_a_int 
    1686 #     include "mpp_allreduce_generic.h90" 
    1687 #     undef ROUTINE_ALLREDUCE 
    1688 #  undef DIM_1d 
    1689 #  undef INTEGER_TYPE 
    1690 ! 
    1691 #  define REAL_TYPE 
    1692 #  define DIM_0d 
    1693 #     define ROUTINE_ALLREDUCE           mppmax_real 
    1694 #     include "mpp_allreduce_generic.h90" 
    1695 #     undef ROUTINE_ALLREDUCE 
    1696 #  undef DIM_0d 
    1697 #  define DIM_1d 
    1698 #     define ROUTINE_ALLREDUCE           mppmax_a_real 
    1699 #     include "mpp_allreduce_generic.h90" 
    1700 #     undef ROUTINE_ALLREDUCE 
    1701 #  undef DIM_1d 
    1702 #  undef REAL_TYPE 
    1703 #  undef OPERATION_MAX 
    1704    !!---------------------------------------------------------------------- 
    1705    !!    ***  mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real  *** 
    1706    !!    
    1707    !!---------------------------------------------------------------------- 
    1708    !! 
    1709 #  define OPERATION_MIN 
    1710 #  define INTEGER_TYPE 
    1711 #  define DIM_0d 
    1712 #     define ROUTINE_ALLREDUCE           mppmin_int 
    1713 #     include "mpp_allreduce_generic.h90" 
    1714 #     undef ROUTINE_ALLREDUCE 
    1715 #  undef DIM_0d 
    1716 #  define DIM_1d 
    1717 #     define ROUTINE_ALLREDUCE           mppmin_a_int 
    1718 #     include "mpp_allreduce_generic.h90" 
    1719 #     undef ROUTINE_ALLREDUCE 
    1720 #  undef DIM_1d 
    1721 #  undef INTEGER_TYPE 
    1722 ! 
    1723 #  define REAL_TYPE 
    1724 #  define DIM_0d 
    1725 #     define ROUTINE_ALLREDUCE           mppmin_real 
    1726 #     include "mpp_allreduce_generic.h90" 
    1727 #     undef ROUTINE_ALLREDUCE 
    1728 #  undef DIM_0d 
    1729 #  define DIM_1d 
    1730 #     define ROUTINE_ALLREDUCE           mppmin_a_real 
    1731 #     include "mpp_allreduce_generic.h90" 
    1732 #     undef ROUTINE_ALLREDUCE 
    1733 #  undef DIM_1d 
    1734 #  undef REAL_TYPE 
    1735 #  undef OPERATION_MIN 
    1736  
    1737    !!---------------------------------------------------------------------- 
    1738    !!    ***  mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real  *** 
    1739    !!    
    1740    !!   Global sum of 1D array or a variable (integer, real or complex) 
    1741    !!---------------------------------------------------------------------- 
    1742    !! 
    1743 #  define OPERATION_SUM 
    1744 #  define INTEGER_TYPE 
    1745 #  define DIM_0d 
    1746 #     define ROUTINE_ALLREDUCE           mppsum_int 
    1747 #     include "mpp_allreduce_generic.h90" 
    1748 #     undef ROUTINE_ALLREDUCE 
    1749 #  undef DIM_0d 
    1750 #  define DIM_1d 
    1751 #     define ROUTINE_ALLREDUCE           mppsum_a_int 
    1752 #     include "mpp_allreduce_generic.h90" 
    1753 #     undef ROUTINE_ALLREDUCE 
    1754 #  undef DIM_1d 
    1755 #  undef INTEGER_TYPE 
    1756 ! 
    1757 #  define REAL_TYPE 
    1758 #  define DIM_0d 
    1759 #     define ROUTINE_ALLREDUCE           mppsum_real 
    1760 #     include "mpp_allreduce_generic.h90" 
    1761 #     undef ROUTINE_ALLREDUCE 
    1762 #  undef DIM_0d 
    1763 #  define DIM_1d 
    1764 #     define ROUTINE_ALLREDUCE           mppsum_a_real 
    1765 #     include "mpp_allreduce_generic.h90" 
    1766 #     undef ROUTINE_ALLREDUCE 
    1767 #  undef DIM_1d 
    1768 #  undef REAL_TYPE 
    1769 #  undef OPERATION_SUM 
    1770  
    1771 #  define OPERATION_SUM_DD 
    1772 #  define COMPLEX_TYPE 
    1773 #  define DIM_0d 
    1774 #     define ROUTINE_ALLREDUCE           mppsum_realdd 
    1775 #     include "mpp_allreduce_generic.h90" 
    1776 #     undef ROUTINE_ALLREDUCE 
    1777 #  undef DIM_0d 
    1778 #  define DIM_1d 
    1779 #     define ROUTINE_ALLREDUCE           mppsum_a_realdd 
    1780 #     include "mpp_allreduce_generic.h90" 
    1781 #     undef ROUTINE_ALLREDUCE 
    1782 #  undef DIM_1d 
    1783 #  undef COMPLEX_TYPE 
    1784 #  undef OPERATION_SUM_DD 
    1785  
    1786    !!---------------------------------------------------------------------- 
    1787    !!    ***  mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d 
    1788    !!    
    1789    !!---------------------------------------------------------------------- 
    1790    !! 
    1791 #  define OPERATION_MINLOC 
    1792 #  define DIM_2d 
    1793 #     define ROUTINE_LOC           mpp_minloc2d 
    1794 #     include "mpp_loc_generic.h90" 
    1795 #     undef ROUTINE_LOC 
    1796 #  undef DIM_2d 
    1797 #  define DIM_3d 
    1798 #     define ROUTINE_LOC           mpp_minloc3d 
    1799 #     include "mpp_loc_generic.h90" 
    1800 #     undef ROUTINE_LOC 
    1801 #  undef DIM_3d 
    1802 #  undef OPERATION_MINLOC 
    1803  
    1804 #  define OPERATION_MAXLOC 
    1805 #  define DIM_2d 
    1806 #     define ROUTINE_LOC           mpp_maxloc2d 
    1807 #     include "mpp_loc_generic.h90" 
    1808 #     undef ROUTINE_LOC 
    1809 #  undef DIM_2d 
    1810 #  define DIM_3d 
    1811 #     define ROUTINE_LOC           mpp_maxloc3d 
    1812 #     include "mpp_loc_generic.h90" 
    1813 #     undef ROUTINE_LOC 
    1814 #  undef DIM_3d 
    1815 #  undef OPERATION_MAXLOC 
    1816  
    1817    SUBROUTINE mpp_delay_sum( cdname, cdelay, y_in, pout, ldlast, kcom ) 
    1818       CHARACTER(len=*), INTENT(in   )               ::   cdname  ! name of the calling subroutine 
    1819       CHARACTER(len=*), INTENT(in   )               ::   cdelay  ! name (used as id) of the delayed operation 
    1820       COMPLEX(wp),      INTENT(in   ), DIMENSION(:) ::   y_in 
    1821       REAL(wp),         INTENT(  out), DIMENSION(:) ::   pout 
    1822       LOGICAL,          INTENT(in   )               ::   ldlast  ! true if this is the last time we call this routine 
    1823       INTEGER,          INTENT(in   ), OPTIONAL     ::   kcom 
    1824       ! 
    1825       pout(:) = REAL(y_in(:), wp) 
    1826    END SUBROUTINE mpp_delay_sum 
    1827  
    1828    SUBROUTINE mpp_delay_max( cdname, cdelay, p_in, pout, ldlast, kcom ) 
    1829       CHARACTER(len=*), INTENT(in   )               ::   cdname  ! name of the calling subroutine 
    1830       CHARACTER(len=*), INTENT(in   )               ::   cdelay  ! name (used as id) of the delayed operation 
    1831       REAL(wp),         INTENT(in   ), DIMENSION(:) ::   p_in 
    1832       REAL(wp),         INTENT(  out), DIMENSION(:) ::   pout 
    1833       LOGICAL,          INTENT(in   )               ::   ldlast  ! true if this is the last time we call this routine 
    1834       INTEGER,          INTENT(in   ), OPTIONAL     ::   kcom 
    1835       ! 
    1836       pout(:) = p_in(:) 
    1837    END SUBROUTINE mpp_delay_max 
    1838  
    1839    SUBROUTINE mpp_delay_rcv( kid ) 
    1840       INTEGER,INTENT(in   )      ::  kid  
    1841       WRITE(*,*) 'mpp_delay_rcv: You should not have seen this print! error?', kid 
    1842    END SUBROUTINE mpp_delay_rcv 
    1843     
    1844    SUBROUTINE mppstop( ldfinal, ld_force_abort ) 
    1845       LOGICAL, OPTIONAL, INTENT(in) :: ldfinal    ! source process number 
    1846       LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort    ! source process number 
    1847       STOP      ! non MPP case, just stop the run 
    1848    END SUBROUTINE mppstop 
    1849  
    1850    SUBROUTINE mpp_ini_znl( knum ) 
    1851       INTEGER :: knum 
    1852       WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum 
    1853    END SUBROUTINE mpp_ini_znl 
    1854  
    1855    SUBROUTINE mpp_comm_free( kcom ) 
    1856       INTEGER :: kcom 
    1857       WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom 
    1858    END SUBROUTINE mpp_comm_free 
    1859     
    1860 #endif 
    1861  
    1862    !!---------------------------------------------------------------------- 
    1863    !!   All cases:         ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam   routines 
     1061   FUNCTION MPI_Wtime() 
     1062      REAL(wp) ::  MPI_Wtime 
     1063      MPI_Wtime = -1. 
     1064   END FUNCTION MPI_Wtime 
     1065#endif 
     1066 
     1067   !!---------------------------------------------------------------------- 
     1068   !!   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam   routines 
    18641069   !!---------------------------------------------------------------------- 
    18651070 
    … …  
    18721077      !!                increment the error number (nstop) by one. 
    18731078      !!---------------------------------------------------------------------- 
    1874       CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5 
    1875       CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10 
     1079      CHARACTER(len=*), INTENT(in   )           ::   cd1 
     1080      CHARACTER(len=*), INTENT(in   ), OPTIONAL ::        cd2, cd3, cd4, cd5 
     1081      CHARACTER(len=*), INTENT(in   ), OPTIONAL ::   cd6, cd7, cd8, cd9, cd10 
    18761082      !!---------------------------------------------------------------------- 
    18771083      ! 
    18781084      nstop = nstop + 1 
    1879  
    1880       ! force to open ocean.output file 
     1085      ! 
     1086      ! force to open ocean.output file if not already opened 
    18811087      IF( numout == 6 ) CALL ctl_opn( numout, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 
    1882         
    1883       WRITE(numout,cform_err) 
    1884       IF( PRESENT(cd1 ) )   WRITE(numout,*) TRIM(cd1) 
     1088      ! 
     1089                            WRITE(numout,*) 
     1090                            WRITE(numout,*) ' ===>>> : E R R O R' 
     1091                            WRITE(numout,*) 
     1092                            WRITE(numout,*) '         ===========' 
     1093                            WRITE(numout,*) 
     1094                            WRITE(numout,*) TRIM(cd1) 
    18851095      IF( PRESENT(cd2 ) )   WRITE(numout,*) TRIM(cd2) 
    18861096      IF( PRESENT(cd3 ) )   WRITE(numout,*) TRIM(cd3) 
    … …  
    18921102      IF( PRESENT(cd9 ) )   WRITE(numout,*) TRIM(cd9) 
    18931103      IF( PRESENT(cd10) )   WRITE(numout,*) TRIM(cd10) 
    1894  
     1104                            WRITE(numout,*) 
     1105      ! 
    18951106                               CALL FLUSH(numout    ) 
    18961107      IF( numstp     /= -1 )   CALL FLUSH(numstp    ) 
    … …  
    18991110      ! 
    19001111      IF( cd1 == 'STOP' ) THEN 
     1112         WRITE(numout,*)   
    19011113         WRITE(numout,*)  'huge E-R-R-O-R : immediate stop' 
    1902          CALL mppstop(ld_force_abort = .true.) 
     1114         WRITE(numout,*)   
     1115         CALL mppstop( ld_abort = .true. ) 
    19031116      ENDIF 
    19041117      ! 
    … …  
    19191132      ! 
    19201133      nwarn = nwarn + 1 
     1134      ! 
    19211135      IF(lwp) THEN 
    1922          WRITE(numout,cform_war) 
    1923          IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 
    1924          IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 
    1925          IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) 
    1926          IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) 
    1927          IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) 
    1928          IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) 
    1929          IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) 
    1930          IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) 
    1931          IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 
    1932          IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 
     1136                               WRITE(numout,*) 
     1137                               WRITE(numout,*) ' ===>>> : W A R N I N G' 
     1138                               WRITE(numout,*) 
     1139                               WRITE(numout,*) '         ===============' 
     1140                               WRITE(numout,*) 
     1141         IF( PRESENT(cd1 ) )   WRITE(numout,*) TRIM(cd1) 
     1142         IF( PRESENT(cd2 ) )   WRITE(numout,*) TRIM(cd2) 
     1143         IF( PRESENT(cd3 ) )   WRITE(numout,*) TRIM(cd3) 
     1144         IF( PRESENT(cd4 ) )   WRITE(numout,*) TRIM(cd4) 
     1145         IF( PRESENT(cd5 ) )   WRITE(numout,*) TRIM(cd5) 
     1146         IF( PRESENT(cd6 ) )   WRITE(numout,*) TRIM(cd6) 
     1147         IF( PRESENT(cd7 ) )   WRITE(numout,*) TRIM(cd7) 
     1148         IF( PRESENT(cd8 ) )   WRITE(numout,*) TRIM(cd8) 
     1149         IF( PRESENT(cd9 ) )   WRITE(numout,*) TRIM(cd9) 
     1150         IF( PRESENT(cd10) )   WRITE(numout,*) TRIM(cd10) 
     1151                               WRITE(numout,*) 
    19331152      ENDIF 
    19341153      CALL FLUSH(numout) 
    … …  
    19731192      IF( TRIM(cdfile) == '/dev/null' )   clfile = TRIM(cdfile)   ! force the use of /dev/null 
    19741193      ! 
    1975       iost=0 
    1976       IF( cdacce(1:6) == 'DIRECT' )  THEN         ! cdacce has always more than 6 characters 
     1194      IF(       cdacce(1:6) == 'DIRECT' )  THEN   ! cdacce has always more than 6 characters 
    19771195         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh         , ERR=100, IOSTAT=iost ) 
    19781196      ELSE IF( TRIM(cdstat) == 'APPEND' )  THEN   ! cdstat can have less than 6 characters 
    … …  
    19951213100   CONTINUE 
    19961214      IF( iost /= 0 ) THEN 
    1997          IF(ldwp) THEN 
    1998             WRITE(kout,*) 
    1999             WRITE(kout,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 
    2000             WRITE(kout,*) ' =======   ===  ' 
    2001             WRITE(kout,*) '           unit   = ', knum 
    2002             WRITE(kout,*) '           status = ', cdstat 
    2003             WRITE(kout,*) '           form   = ', cdform 
    2004             WRITE(kout,*) '           access = ', cdacce 
    2005             WRITE(kout,*) '           iostat = ', iost 
    2006             WRITE(kout,*) '           we stop. verify the file ' 
    2007             WRITE(kout,*) 
    2008          ELSE  !!! Force writing to make sure we get the information - at least once - in this violent STOP!! 
    2009             WRITE(*,*) 
    2010             WRITE(*,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 
    2011             WRITE(*,*) ' =======   ===  ' 
    2012             WRITE(*,*) '           unit   = ', knum 
    2013             WRITE(*,*) '           status = ', cdstat 
    2014             WRITE(*,*) '           form   = ', cdform 
    2015             WRITE(*,*) '           access = ', cdacce 
    2016             WRITE(*,*) '           iostat = ', iost 
    2017             WRITE(*,*) '           we stop. verify the file ' 
    2018             WRITE(*,*) 
    2019          ENDIF 
    2020          CALL FLUSH( kout )  
    2021          STOP 'ctl_opn bad opening' 
     1215         WRITE(ctmp1,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 
     1216         WRITE(ctmp2,*) ' =======   ===  ' 
     1217         WRITE(ctmp3,*) '           unit   = ', knum 
     1218         WRITE(ctmp4,*) '           status = ', cdstat 
     1219         WRITE(ctmp5,*) '           form   = ', cdform 
     1220         WRITE(ctmp6,*) '           access = ', cdacce 
     1221         WRITE(ctmp7,*) '           iostat = ', iost 
     1222         WRITE(ctmp8,*) '           we stop. verify the file ' 
     1223         CALL ctl_stop( 'STOP', ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 ) 
    20221224      ENDIF 
    20231225      ! 
    … …  
    20251227 
    20261228 
    2027    SUBROUTINE ctl_nam ( kios, cdnam, ldwp ) 
     1229   SUBROUTINE ctl_nam ( kios, cdnam ) 
    20281230      !!---------------------------------------------------------------------- 
    20291231      !!                  ***  ROUTINE ctl_nam  *** 
    … …  
    20331235      !! ** Method  :   Fortan open 
    20341236      !!---------------------------------------------------------------------- 
    2035       INTEGER         , INTENT(inout) ::   kios    ! IO status after reading the namelist 
    2036       CHARACTER(len=*), INTENT(in   ) ::   cdnam   ! group name of namelist for which error occurs 
    2037       CHARACTER(len=5)                ::   clios   ! string to convert iostat in character for print 
    2038       LOGICAL         , INTENT(in   ) ::   ldwp    ! boolean term for print 
     1237      INTEGER                                , INTENT(inout) ::   kios    ! IO status after reading the namelist 
     1238      CHARACTER(len=*)                       , INTENT(in   ) ::   cdnam   ! group name of namelist for which error occurs 
     1239      ! 
     1240      CHARACTER(len=5) ::   clios   ! string to convert iostat in character for print 
    20391241      !!---------------------------------------------------------------------- 
    20401242      ! 
    … …  
    20501252      ENDIF 
    20511253      kios = 0 
    2052       RETURN 
    20531254      ! 
    20541255   END SUBROUTINE ctl_nam 
    … …  
    20711272      END DO 
    20721273      IF( (get_unit == 999) .AND. llopn ) THEN 
    2073          CALL ctl_stop( 'get_unit: All logical units until 999 are used...' ) 
    2074          get_unit = -1 
     1274         CALL ctl_stop( 'STOP', 'get_unit: All logical units until 999 are used...' ) 
    20751275      ENDIF 
    20761276      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LBC/mpp_lnk_generic.h90

    r10542 r11822  
    4646 
    4747#if defined MULTI 
    48    SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, cd_mpp, pval ) 
    49       INTEGER                     , INTENT(in   ) ::   kfld        ! number of pt3d arrays 
     48   SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ihlcom ) 
     49      INTEGER             , INTENT(in   ) ::   kfld        ! number of pt3d arrays 
    5050#else 
    51    SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn      , cd_mpp, pval ) 
     51   SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn      , kfillmode, pfillval, lsend, lrecv, ihlcom ) 
    5252#endif 
    5353      ARRAY_TYPE(:,:,:,:,:)                                        ! array or pointer of arrays on which the boundary condition is applied 
    54       CHARACTER(len=*)            , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    55       CHARACTER(len=1)            , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points 
    56       REAL(wp)                    , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary 
    57       CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp      ! fill the overlap area only 
    58       REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval        ! background value (used at closed boundaries) 
    59       ! 
    60       INTEGER  ::    ji,  jj,  jk,  jl, jh, jf   ! dummy loop indices 
     54      CHARACTER(len=*)              , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
     55      CHARACTER(len=1)              , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points 
     56      REAL(wp)                      , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary 
     57      INTEGER ,             OPTIONAL, INTENT(in   ) ::   kfillmode   ! filling method for halo over land (default = constant) 
     58      REAL(wp),             OPTIONAL, INTENT(in   ) ::   pfillval    ! background value (used at closed boundaries) 
     59      LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in   ) ::   lsend, lrecv  ! communication with other 4 proc 
     60      INTEGER              ,OPTIONAL, INTENT(in   ) ::   ihlcom        ! number of ranks and rows to be communicated 
     61      ! 
     62      INTEGER  ::    ji,  jj,  jk,  jl,  jf      ! dummy loop indices 
    6163      INTEGER  ::   ipi, ipj, ipk, ipl, ipf      ! dimension of the input array 
    62       INTEGER  ::   imigr, iihom, ijhom          ! local integers 
    63       INTEGER  ::   ml_req1, ml_req2, ml_err     ! for key_mpi_isend 
     64      INTEGER  ::   isize, ishift, ishift2       ! local integers 
     65      INTEGER  ::   ireq_we, ireq_ea, ireq_so, ireq_no     ! mpi_request id 
    6466      INTEGER  ::   ierr 
     67      INTEGER  ::   ifill_we, ifill_ea, ifill_so, ifill_no 
     68      INTEGER  ::   ihl                          ! number of ranks and rows to be communicated  
    6569      REAL(wp) ::   zland 
    66       INTEGER , DIMENSION(MPI_STATUS_SIZE)      ::   ml_stat        ! for key_mpi_isend 
    67       REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! north-south & south-north  halos 
    68       REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! east -west  & west - east  halos 
     70      INTEGER , DIMENSION(MPI_STATUS_SIZE)        ::   istat          ! for mpi_isend 
     71      REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zsnd_we, zrcv_we, zsnd_ea, zrcv_ea   ! east -west  & west - east  halos 
     72      REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zsnd_so, zrcv_so, zsnd_no, zrcv_no   ! north-south & south-north  halos 
     73      LOGICAL  ::   llsend_we, llsend_ea, llsend_no, llsend_so       ! communication send 
     74      LOGICAL  ::   llrecv_we, llrecv_ea, llrecv_no, llrecv_so       ! communication receive  
     75      LOGICAL  ::   lldo_nfd                                     ! do north pole folding 
    6976      !!---------------------------------------------------------------------- 
     77      ! 
     78      ! ----------------------------------------- ! 
     79      !     0. local variables initialization     ! 
     80      ! ----------------------------------------- ! 
    7081      ! 
    7182      ipk = K_SIZE(ptab)   ! 3rd dimension 
    … …  
    7384      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers) 
    7485      ! 
     86      IF( PRESENT(ihlcom) ) THEN   ;   ihl = ihlcom 
     87      ELSE                         ;   ihl = 1 
     88      END IF 
     89      ! 
    7590      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) 
    7691      ! 
    77       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    78       ELSE                         ;   zland = 0._wp     ! zero by default 
    79       ENDIF 
    80  
    81       ! ------------------------------- ! 
    82       !   standard boundary treatment   !    ! CAUTION: semi-column notation is often impossible 
    83       ! ------------------------------- ! 
    84       ! 
    85       IF( .NOT. PRESENT( cd_mpp ) ) THEN     !==  standard close or cyclic treatment  ==! 
    86          ! 
    87          DO jf = 1, ipf                      ! number of arrays to be treated 
    88             ! 
    89             !                                ! East-West boundaries 
    90             IF( l_Iperio ) THEN                    !* cyclic 
    91                ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf) 
    92                ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN(  2  ,:,:,:,jf) 
    93             ELSE                                   !* closed 
    94                IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(     1       :nn_hls,:,:,:,jf) = zland    ! east except F-point 
    95                                                ARRAY_IN(nlci-nn_hls+1:jpi   ,:,:,:,jf) = zland    ! west 
    96             ENDIF 
    97             !                                ! North-South boundaries 
    98             IF( l_Jperio ) THEN                    !* cyclic (only with no mpp j-split) 
    99                ARRAY_IN(:, 1 ,:,:,jf) = ARRAY_IN(:, jpjm1,:,:,jf) 
    100                ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:,   2  ,:,:,jf) 
    101             ELSE                                   !* closed 
    102                IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:,     1       :nn_hls,:,:,jf) = zland    ! south except F-point 
    103                                                ARRAY_IN(:,nlcj-nn_hls+1:jpj   ,:,:,jf) = zland    ! north 
     92      IF     ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN 
     93         llsend_we = lsend(1)   ;   llsend_ea = lsend(2)   ;   llsend_so = lsend(3)   ;   llsend_no = lsend(4) 
     94         llrecv_we = lrecv(1)   ;   llrecv_ea = lrecv(2)   ;   llrecv_so = lrecv(3)   ;   llrecv_no = lrecv(4) 
     95      ELSE IF( PRESENT(lsend) .OR.  PRESENT(lrecv) ) THEN 
     96         WRITE(ctmp1,*) ' E R R O R : Routine ', cdname, '  is calling lbc_lnk with only one of the two arguments lsend or lrecv' 
     97         WRITE(ctmp2,*) ' ========== ' 
     98         CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
     99      ELSE   ! send and receive with every neighbour 
     100         llsend_we = nbondi ==  1 .OR. nbondi == 0   ! keep for compatibility, should be defined in mppini 
     101         llsend_ea = nbondi == -1 .OR. nbondi == 0   ! keep for compatibility, should be defined in mppini 
     102         llsend_so = nbondj ==  1 .OR. nbondj == 0   ! keep for compatibility, should be defined in mppini 
     103         llsend_no = nbondj == -1 .OR. nbondj == 0   ! keep for compatibility, should be defined in mppini 
     104         llrecv_we = llsend_we   ;   llrecv_ea = llsend_ea   ;   llrecv_so = llsend_so   ;   llrecv_no = llsend_no 
     105      END IF 
     106          
     107          
     108      lldo_nfd = npolj /= 0                      ! keep for compatibility, should be defined in mppini 
     109 
     110      zland = 0._wp                                     ! land filling value: zero by default 
     111      IF( PRESENT( pfillval ) )   zland = pfillval      ! set land value 
     112 
     113      ! define the method we will use to fill the halos in each direction 
     114      IF(              llrecv_we ) THEN   ;   ifill_we = jpfillmpi 
     115      ELSEIF(           l_Iperio ) THEN   ;   ifill_we = jpfillperio 
     116      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_we = kfillmode 
     117      ELSE                                ;   ifill_we = jpfillcst 
     118      END IF 
     119      ! 
     120      IF(              llrecv_ea ) THEN   ;   ifill_ea = jpfillmpi 
     121      ELSEIF(           l_Iperio ) THEN   ;   ifill_ea = jpfillperio 
     122      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_ea = kfillmode 
     123      ELSE                                ;   ifill_ea = jpfillcst 
     124      END IF 
     125      ! 
     126      IF(              llrecv_so ) THEN   ;   ifill_so = jpfillmpi 
     127      ELSEIF(           l_Jperio ) THEN   ;   ifill_so = jpfillperio 
     128      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_so = kfillmode 
     129      ELSE                                ;   ifill_so = jpfillcst 
     130      END IF 
     131      ! 
     132      IF(              llrecv_no ) THEN   ;   ifill_no = jpfillmpi 
     133      ELSEIF(           l_Jperio ) THEN   ;   ifill_no = jpfillperio 
     134      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_no = kfillmode 
     135      ELSE                                ;   ifill_no = jpfillcst 
     136      END IF 
     137      ! 
     138#if defined PRINT_CAUTION 
     139      ! 
     140      ! ================================================================================== ! 
     141      ! CAUTION: semi-column notation is often impossible because of the cpp preprocessing ! 
     142      ! ================================================================================== ! 
     143      ! 
     144#endif 
     145      ! 
     146      ! -------------------------------------------------- ! 
     147      !     1. Do east and west MPI exchange if needed     ! 
     148      ! -------------------------------------------------- ! 
     149      ! 
     150      ! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg 
     151      isize = ihl * jpj * ipk * ipl * ipf       
     152      ! 
     153      ! Allocate local temporary arrays to be sent/received. Fill arrays to be sent 
     154      IF( llsend_we )   ALLOCATE( zsnd_we(ihl,jpj,ipk,ipl,ipf) ) 
     155      IF( llsend_ea )   ALLOCATE( zsnd_ea(ihl,jpj,ipk,ipl,ipf) ) 
     156      IF( llrecv_we )   ALLOCATE( zrcv_we(ihl,jpj,ipk,ipl,ipf) ) 
     157      IF( llrecv_ea )   ALLOCATE( zrcv_ea(ihl,jpj,ipk,ipl,ipf) ) 
     158      ! 
     159      IF( llsend_we ) THEN   ! copy western side of the inner mpi domain in local temporary array to be sent by MPI 
     160         ishift = ihl 
     161         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     162            zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf)   ! ihl + 1 -> 2*ihl 
     163         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
     164      ENDIF 
     165      ! 
     166      IF(llsend_ea  ) THEN   ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 
     167         ishift = jpi - 2 * ihl 
     168         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     169            zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf)   ! jpi - 2*ihl + 1 -> jpi - ihl 
     170         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
     171      ENDIF 
     172      ! 
     173      IF( ln_timing ) CALL tic_tac(.TRUE.) 
     174      ! 
     175      ! non-blocking send of the western/eastern side using local temporary arrays 
     176      IF( llsend_we )   CALL mppsend( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we ) 
     177      IF( llsend_ea )   CALL mppsend( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea ) 
     178      ! blocking receive of the western/eastern halo in local temporary arrays 
     179      IF( llrecv_we )   CALL mpprecv( 2, zrcv_we(1,1,1,1,1), isize, nowe ) 
     180      IF( llrecv_ea )   CALL mpprecv( 1, zrcv_ea(1,1,1,1,1), isize, noea ) 
     181      ! 
     182      IF( ln_timing ) CALL tic_tac(.FALSE.) 
     183      ! 
     184      ! 
     185      ! ----------------------------------- ! 
     186      !     2. Fill east and west halos     ! 
     187      ! ----------------------------------- ! 
     188      ! 
     189      ! 2.1 fill weastern halo 
     190      ! ---------------------- 
     191      ! ishift = 0                         ! fill halo from ji = 1 to ihl 
     192      SELECT CASE ( ifill_we ) 
     193      CASE ( jpfillnothing )               ! no filling  
     194      CASE ( jpfillmpi   )                 ! use data received by MPI  
     195         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     196            ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf)   ! 1 -> ihl 
     197         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
     198      CASE ( jpfillperio )                 ! use east-weast periodicity 
     199         ishift2 = jpi - 2 * ihl 
     200         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     201            ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 
     202         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
     203      CASE ( jpfillcopy  )                 ! filling with inner domain values 
     204         DO jf = 1, ipf                               ! number of arrays to be treated 
     205            IF( .NOT. NAT_IN(jf) == 'F' ) THEN        ! do nothing for F point 
     206               DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     207                  ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ihl+1,jj,jk,jl,jf) 
     208               END DO   ;   END DO   ;   END DO   ;   END DO 
    104209            ENDIF 
    105210         END DO 
    106          ! 
    107       ENDIF 
    108  
    109       ! ------------------------------- ! 
    110       !      East and west exchange     ! 
    111       ! ------------------------------- ! 
    112       ! we play with the neigbours AND the row number because of the periodicity 
    113       ! 
    114       IF( ABS(nbondi) == 1 ) ALLOCATE( zt3ew(jpj,nn_hls,ipk,ipl,ipf,1), zt3we(jpj,nn_hls,ipk,ipl,ipf,1) ) 
    115       IF(     nbondi  == 0 ) ALLOCATE( zt3ew(jpj,nn_hls,ipk,ipl,ipf,2), zt3we(jpj,nn_hls,ipk,ipl,ipf,2) ) 
    116       ! 
    117       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    118       CASE ( -1 ) 
    119          iihom = nlci-nreci 
    120          DO jf = 1, ipf 
    121             DO jl = 1, ipl 
    122                DO jk = 1, ipk 
    123                   DO jh = 1, nn_hls 
    124                      zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf) 
    125                   END DO 
    126                END DO 
    127             END DO 
    128          END DO 
    129       CASE ( 0 ) 
    130          iihom = nlci-nreci 
    131          DO jf = 1, ipf 
    132             DO jl = 1, ipl 
    133                DO jk = 1, ipk 
    134                   DO jh = 1, nn_hls 
    135                      zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf) 
    136                      zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf) 
    137                   END DO 
    138                END DO 
    139             END DO 
    140          END DO 
    141       CASE ( 1 ) 
    142          iihom = nlci-nreci 
    143          DO jf = 1, ipf 
    144             DO jl = 1, ipl 
    145                DO jk = 1, ipk 
    146                   DO jh = 1, nn_hls 
    147                      zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf) 
    148                   END DO 
    149                END DO 
    150             END DO 
     211      CASE ( jpfillcst   )                 ! filling with constant value 
     212         DO jf = 1, ipf                               ! number of arrays to be treated 
     213            IF( .NOT. NAT_IN(jf) == 'F' ) THEN        ! do nothing for F point 
     214               DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     215                  ARRAY_IN(ji,jj,jk,jl,jf) = zland 
     216               END DO;   END DO   ;   END DO   ;   END DO 
     217            ENDIF 
    151218         END DO 
    152219      END SELECT 
    153       !                           ! Migrations 
    154       imigr = nn_hls * jpj * ipk * ipl * ipf       
    155       ! 
    156       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    157       ! 
    158       SELECT CASE ( nbondi ) 
    159       CASE ( -1 ) 
    160          CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req1 ) 
    161          CALL mpprecv( 1, zt3ew(1,1,1,1,1,1), imigr, noea ) 
    162          IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    163       CASE ( 0 ) 
    164          CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 ) 
    165          CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req2 ) 
    166          CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea ) 
    167          CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe ) 
    168          IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    169          IF(l_isend)   CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    170       CASE ( 1 ) 
    171          CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 ) 
    172          CALL mpprecv( 2, zt3we(1,1,1,1,1,1), imigr, nowe ) 
    173          IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
     220      ! 
     221      ! 2.2 fill eastern halo 
     222      ! --------------------- 
     223      ishift = jpi - ihl                ! fill halo from ji = jpi-ihl+1 to jpi  
     224      SELECT CASE ( ifill_ea ) 
     225      CASE ( jpfillnothing )               ! no filling  
     226      CASE ( jpfillmpi   )                 ! use data received by MPI  
     227         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     228            ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf)   ! jpi - ihl + 1 -> jpi 
     229         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
     230      CASE ( jpfillperio )                 ! use east-weast periodicity 
     231         ishift2 = ihl 
     232         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     233            ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 
     234         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
     235      CASE ( jpfillcopy  )                 ! filling with inner domain values 
     236         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     237            ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) 
     238         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
     239      CASE ( jpfillcst   )                 ! filling with constant value 
     240         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     241            ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland 
     242         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
    174243      END SELECT 
    175       ! 
    176       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    177       ! 
    178       !                           ! Write Dirichlet lateral conditions 
    179       iihom = nlci-nn_hls 
    180       ! 
    181       SELECT CASE ( nbondi ) 
    182       CASE ( -1 ) 
    183          DO jf = 1, ipf 
    184             DO jl = 1, ipl 
    185                DO jk = 1, ipk 
    186                   DO jh = 1, nn_hls 
    187                      ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,1) 
    188                   END DO 
    189                END DO 
    190             END DO 
    191          END DO 
    192       CASE ( 0 ) 
    193          DO jf = 1, ipf 
    194             DO jl = 1, ipl 
    195                DO jk = 1, ipk 
    196                   DO jh = 1, nn_hls 
    197                      ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2) 
    198                      ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2) 
    199                   END DO 
    200                END DO 
    201             END DO 
    202          END DO 
    203       CASE ( 1 ) 
    204          DO jf = 1, ipf 
    205             DO jl = 1, ipl 
    206                DO jk = 1, ipk 
    207                   DO jh = 1, nn_hls 
    208                      ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,1) 
    209                   END DO 
    210                END DO 
    211             END DO 
    212          END DO 
    213       END SELECT 
    214       ! 
    215       IF( nbondi /= 2 ) DEALLOCATE( zt3ew, zt3we ) 
    216244      ! 
    217245      ! ------------------------------- ! 
    218246      !     3. north fold treatment     ! 
    219247      ! ------------------------------- ! 
     248      ! 
    220249      ! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor 
    221       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     250      ! 
     251      IF( lldo_nfd .AND. ifill_no /= jpfillnothing ) THEN 
    222252         ! 
    223253         SELECT CASE ( jpni ) 
    … …  
    226256         END SELECT 
    227257         ! 
    228       ENDIF 
    229       ! 
    230       ! ------------------------------- ! 
    231       !  4. North and south directions  ! 
    232       ! ------------------------------- ! 
    233       ! always closed : we play only with the neigbours 
    234       ! 
    235       IF( ABS(nbondj) == 1 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,1), zt3sn(jpi,nn_hls,ipk,ipl,ipf,1) ) 
    236       IF(     nbondj  == 0 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2) ) 
    237       ! 
    238       SELECT CASE ( nbondj ) 
    239       CASE ( -1 ) 
    240          ijhom = nlcj-nrecj 
    241          DO jf = 1, ipf 
    242             DO jl = 1, ipl 
    243                DO jk = 1, ipk 
    244                   DO jh = 1, nn_hls 
    245                      zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf) 
    246                   END DO 
    247                END DO 
    248             END DO 
     258         ifill_no = jpfillnothing  ! force to do nothing for the northern halo as we just done the north pole folding 
     259         ! 
     260      ENDIF 
     261      ! 
     262      ! ---------------------------------------------------- ! 
     263      !     4. Do north and south MPI exchange if needed     ! 
     264      ! ---------------------------------------------------- ! 
     265      ! 
     266      IF( llsend_so )   ALLOCATE( zsnd_so(jpi,ihl,ipk,ipl,ipf) ) 
     267      IF( llsend_no )   ALLOCATE( zsnd_no(jpi,ihl,ipk,ipl,ipf) ) 
     268      IF( llrecv_so )   ALLOCATE( zrcv_so(jpi,ihl,ipk,ipl,ipf) ) 
     269      IF( llrecv_no )   ALLOCATE( zrcv_no(jpi,ihl,ipk,ipl,ipf) ) 
     270      ! 
     271      isize = jpi * ihl * ipk * ipl * ipf       
     272 
     273      ! allocate local temporary arrays to be sent/received. Fill arrays to be sent 
     274      IF( llsend_so ) THEN   ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI 
     275         ishift = ihl 
     276         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
     277            zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf)   ! ihl+1 -> 2*ihl 
     278         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
     279      ENDIF 
     280      ! 
     281      IF( llsend_no ) THEN   ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 
     282         ishift = jpj - 2 * ihl 
     283         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
     284            zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf)   ! jpj-2*ihl+1 -> jpj-ihl 
     285         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
     286      ENDIF 
     287      ! 
     288      IF( ln_timing ) CALL tic_tac(.TRUE.) 
     289      ! 
     290      ! non-blocking send of the southern/northern side 
     291      IF( llsend_so )   CALL mppsend( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so ) 
     292      IF( llsend_no )   CALL mppsend( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no ) 
     293      ! blocking receive of the southern/northern halo 
     294      IF( llrecv_so )   CALL mpprecv( 4, zrcv_so(1,1,1,1,1), isize, noso ) 
     295      IF( llrecv_no )   CALL mpprecv( 3, zrcv_no(1,1,1,1,1), isize, nono ) 
     296      ! 
     297      IF( ln_timing ) CALL tic_tac(.FALSE.) 
     298      ! 
     299      ! ------------------------------------- ! 
     300      !     5. Fill south and north halos     ! 
     301      ! ------------------------------------- ! 
     302      ! 
     303      ! 5.1 fill southern halo 
     304      ! ---------------------- 
     305      ! ishift = 0                         ! fill halo from jj = 1 to ihl 
     306      SELECT CASE ( ifill_so ) 
     307      CASE ( jpfillnothing )               ! no filling  
     308      CASE ( jpfillmpi   )                 ! use data received by MPI  
     309         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
     310            ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf)   ! 1 -> ihl 
     311         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
     312      CASE ( jpfillperio )                 ! use north-south periodicity 
     313         ishift2 = jpj - 2 * ihl 
     314         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
     315            ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 
     316         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
     317      CASE ( jpfillcopy  )                 ! filling with inner domain values 
     318         DO jf = 1, ipf                               ! number of arrays to be treated 
     319            IF( .NOT. NAT_IN(jf) == 'F' ) THEN        ! do nothing for F point 
     320               DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
     321                  ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ihl+1,jk,jl,jf) 
     322               END DO   ;   END DO   ;   END DO   ;   END DO 
     323            ENDIF 
    249324         END DO 
    250       CASE ( 0 ) 
    251          ijhom = nlcj-nrecj 
    252          DO jf = 1, ipf 
    253             DO jl = 1, ipl 
    254                DO jk = 1, ipk 
    255                   DO jh = 1, nn_hls 
    256                      zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf) 
    257                      zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf) 
    258                   END DO 
    259                END DO 
    260             END DO 
    261          END DO 
    262       CASE ( 1 ) 
    263          ijhom = nlcj-nrecj 
    264          DO jf = 1, ipf 
    265             DO jl = 1, ipl 
    266                DO jk = 1, ipk 
    267                   DO jh = 1, nn_hls 
    268                      zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf) 
    269                   END DO 
    270                END DO 
    271             END DO 
     325      CASE ( jpfillcst   )                 ! filling with constant value 
     326         DO jf = 1, ipf                               ! number of arrays to be treated 
     327            IF( .NOT. NAT_IN(jf) == 'F' ) THEN        ! do nothing for F point 
     328               DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi  
     329                  ARRAY_IN(ji,jj,jk,jl,jf) = zland 
     330               END DO;   END DO   ;   END DO   ;   END DO 
     331            ENDIF 
    272332         END DO 
    273333      END SELECT 
    274334      ! 
    275       !                           ! Migrations 
    276       imigr = nn_hls * jpi * ipk * ipl * ipf 
    277       ! 
    278       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    279       !  
    280       SELECT CASE ( nbondj ) 
    281       CASE ( -1 ) 
    282          CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req1 ) 
    283          CALL mpprecv( 3, zt3ns(1,1,1,1,1,1), imigr, nono ) 
    284          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
    285       CASE ( 0 ) 
    286          CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 ) 
    287          CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req2 ) 
    288          CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono ) 
    289          CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso ) 
    290          IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
    291          IF(l_isend)   CALL mpi_wait(ml_req2, ml_stat, ml_err ) 
    292       CASE ( 1 ) 
    293          CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 ) 
    294          CALL mpprecv( 4, zt3sn(1,1,1,1,1,1), imigr, noso ) 
    295          IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
     335      ! 5.2 fill northern halo 
     336      ! ---------------------- 
     337      ishift = jpj - ihl                ! fill halo from jj = jpj-ihl+1 to jpj  
     338      SELECT CASE ( ifill_no ) 
     339      CASE ( jpfillnothing )               ! no filling  
     340      CASE ( jpfillmpi   )                 ! use data received by MPI  
     341         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
     342            ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf)   ! jpj-ihl+1 -> jpj 
     343         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
     344      CASE ( jpfillperio )                 ! use north-south periodicity 
     345         ishift2 = ihl 
     346         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
     347            ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 
     348         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
     349      CASE ( jpfillcopy  )                 ! filling with inner domain values 
     350         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
     351            ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf) 
     352         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
     353      CASE ( jpfillcst   )                 ! filling with constant value 
     354         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
     355            ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland 
     356         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
    296357      END SELECT 
    297358      ! 
    298       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    299       !                           ! Write Dirichlet lateral conditions 
    300       ijhom = nlcj-nn_hls 
    301       ! 
    302       SELECT CASE ( nbondj ) 
    303       CASE ( -1 ) 
    304          DO jf = 1, ipf 
    305             DO jl = 1, ipl 
    306                DO jk = 1, ipk 
    307                   DO jh = 1, nn_hls 
    308                      ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,1) 
    309                   END DO 
    310                END DO 
    311             END DO 
    312          END DO 
    313       CASE ( 0 ) 
    314          DO jf = 1, ipf 
    315             DO jl = 1, ipl 
    316                DO jk = 1, ipk 
    317                   DO jh = 1, nn_hls 
    318                      ARRAY_IN(:,      jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2) 
    319                      ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2) 
    320                   END DO 
    321                END DO 
    322             END DO 
    323          END DO 
    324       CASE ( 1 ) 
    325          DO jf = 1, ipf 
    326             DO jl = 1, ipl 
    327                DO jk = 1, ipk 
    328                   DO jh = 1, nn_hls 
    329                      ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,1) 
    330                   END DO 
    331                END DO 
    332             END DO 
    333          END DO 
    334       END SELECT 
    335       ! 
    336       IF( nbondj /= 2 ) DEALLOCATE( zt3ns, zt3sn ) 
     359      ! -------------------------------------------- ! 
     360      !     6. deallocate local temporary arrays     ! 
     361      ! -------------------------------------------- ! 
     362      ! 
     363      IF( llsend_we ) THEN 
     364         CALL mpi_wait(ireq_we, istat, ierr ) 
     365         DEALLOCATE( zsnd_we ) 
     366      ENDIF 
     367      IF( llsend_ea )  THEN 
     368         CALL mpi_wait(ireq_ea, istat, ierr ) 
     369         DEALLOCATE( zsnd_ea ) 
     370      ENDIF 
     371      IF( llsend_so ) THEN 
     372         CALL mpi_wait(ireq_so, istat, ierr ) 
     373         DEALLOCATE( zsnd_so ) 
     374      ENDIF 
     375      IF( llsend_no ) THEN 
     376         CALL mpi_wait(ireq_no, istat, ierr ) 
     377         DEALLOCATE( zsnd_no ) 
     378      ENDIF 
     379      ! 
     380      IF( llrecv_we )   DEALLOCATE( zrcv_we ) 
     381      IF( llrecv_ea )   DEALLOCATE( zrcv_ea ) 
     382      IF( llrecv_so )   DEALLOCATE( zrcv_so ) 
     383      IF( llrecv_no )   DEALLOCATE( zrcv_no ) 
    337384      ! 
    338385   END SUBROUTINE ROUTINE_LNK 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LBC/mpp_nfd_generic.h90

    r10440 r11822  
    7676      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers) 
    7777      ! 
    78       IF( l_north_nogather ) THEN      !==  ????  ==! 
     78      IF( l_north_nogather ) THEN      !==  no allgather exchanges  ==! 
    7979 
    8080         ALLOCATE(ipj_s(ipf)) 
    … …  
    200200            ENDIF 
    201201         END DO 
    202          IF( l_isend ) THEN 
    203             DO jr = 1,nsndto 
    204                IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    205                   CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 
    206                ENDIF 
    207             END DO 
    208          ENDIF 
     202         DO jr = 1,nsndto 
     203            IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
     204               CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 
     205            ENDIF 
     206         END DO 
    209207         ! 
    210208         IF( ln_timing ) CALL tic_tac(.FALSE.) 
    … …  
    213211         ! 
    214212         DO jf = 1, ipf 
    215             CALL lbc_nfd_nogather(ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 
    216          END DO 
    217          ! 
    218          DEALLOCATE( zfoldwk ) 
    219          DEALLOCATE( ztabr )  
    220          DEALLOCATE( jj_s )  
    221          DEALLOCATE( ipj_s )  
    222       ELSE                             !==  ????  ==! 
     213            CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 
     214         END DO 
     215         ! 
     216         DEALLOCATE( zfoldwk, ztabr, jj_s, ipj_s ) 
     217         ! 
     218      ELSE                             !==  allgather exchanges  ==! 
    223219         ! 
    224220         ipj   = 4            ! 2nd dimension of message transfers (last j-lines) 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LBC/mppini.F90

    r10615 r11822  
    8484      nbondj = 2 
    8585      nidom  = FLIO_DOM_NONE 
    86       npolj = jperio 
     86      npolj = 0 
     87      IF( jperio == 3 .OR. jperio == 4 )   npolj = 3 
     88      IF( jperio == 5 .OR. jperio == 6 )   npolj = 5 
    8789      l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) 
    8890      l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) 
    … …  
    152154      LOGICAL ::   llbest, llauto 
    153155      LOGICAL ::   llwrtlay 
     156      LOGICAL ::   ln_listonly 
    154157      INTEGER, ALLOCATABLE, DIMENSION(:)     ::   iin, ii_nono, ii_noea          ! 1D workspace 
    155158      INTEGER, ALLOCATABLE, DIMENSION(:)     ::   ijn, ii_noso, ii_nowe          !  -     - 
    … …  
    164167           &             ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & 
    165168           &             cn_ice, nn_ice_dta,                                     & 
    166            &             rn_ice_tem, rn_ice_sal, rn_ice_age,                     & 
    167            &             ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy 
    168       !!---------------------------------------------------------------------- 
    169  
     169           &             ln_vol, nn_volctl, nn_rimwidth 
     170      NAMELIST/nammpp/ jpni, jpnj, ln_nnogather, ln_listonly 
     171      !!---------------------------------------------------------------------- 
     172      ! 
    170173      llwrtlay = lwp .OR. ln_ctl .OR. sn_cfctl%l_layout 
     174      ! 
     175      !  0. read namelists parameters 
     176      ! ----------------------------------- 
     177      ! 
     178      REWIND( numnam_ref )              ! Namelist nammpp in reference namelist 
     179      READ  ( numnam_ref, nammpp, IOSTAT = ios, ERR = 901 ) 
     180901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nammpp in reference namelist' ) 
     181      REWIND( numnam_cfg )              ! Namelist nammpp in confguration namelist 
     182      READ  ( numnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 
     183902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nammpp in configuration namelist' )    
     184      ! 
     185      IF(lwp) THEN 
     186            WRITE(numout,*) '   Namelist nammpp' 
     187         IF( jpni < 1 .OR. jpnj < 1  ) THEN 
     188            WRITE(numout,*) '      jpni and jpnj will be calculated automatically' 
     189         ELSE 
     190            WRITE(numout,*) '      processor grid extent in i                            jpni = ', jpni 
     191            WRITE(numout,*) '      processor grid extent in j                            jpnj = ', jpnj 
     192         ENDIF 
     193            WRITE(numout,*) '      avoid use of mpi_allgather at the north fold  ln_nnogather = ', ln_nnogather 
     194      ENDIF 
     195      ! 
     196      IF(lwm)   WRITE( numond, nammpp ) 
     197 
    171198      ! do we need to take into account bdy_msk? 
    172199      REWIND( numnam_ref )              ! Namelist nambdy in reference namelist : BDY 
    173200      READ  ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) 
    174 903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)', lwp ) 
     201903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)' ) 
    175202      REWIND( numnam_cfg )              ! Namelist nambdy in configuration namelist : BDY 
    176203      READ  ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 ) 
    177 904   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambdy in configuration namelist (mppini)', lwp ) 
     204904   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambdy in configuration namelist (mppini)' ) 
    178205      ! 
    179206      IF(               ln_read_cfg ) CALL iom_open( cn_domcfg,    numbot ) 
    180207      IF( ln_bdy .AND. ln_mask_file ) CALL iom_open( cn_mask_file, numbdy ) 
     208      ! 
     209      IF( ln_listonly )   CALL mpp_init_bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. )   ! must be done by all core 
    181210      ! 
    182211      !  1. Dimension arrays for subdomains 
    … …  
    241270         CALL ctl_stop( ctmp1, ctmp2, ctmp3, ' ', ctmp4, ' ' ) 
    242271         CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. )   ! must be done by all core 
    243          CALL ctl_stop( 'STOP' ) 
    244272      ENDIF 
    245273 
    … …  
    266294         ENDIF 
    267295         CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. )   ! must be done by all core 
    268          CALL ctl_stop( 'STOP' ) 
    269296      ENDIF 
    270297 
    … …  
    511538 9401    FORMAT('              '   ,20('   ',i3,'          ') ) 
    512539 9402    FORMAT('       ',i3,' *  ',20(i3,'  x',i3,'   *   ') ) 
    513  9404    FORMAT('           *  '   ,20('      ',i3,'   *   ') ) 
     540 9404    FORMAT('           *  '   ,20('     ' ,i4,'   *   ') ) 
    514541      ENDIF 
    515542          
    … …  
    669696      ! 
    670697      CALL mpp_init_ioipsl       ! Prepare NetCDF output file (if necessary) 
    671       ! 
    672       IF( ln_nnogather ) THEN 
     698      !       
     699      IF (( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ).AND.( ln_nnogather )) THEN 
    673700         CALL mpp_init_nfdcom     ! northfold neighbour lists 
    674701         IF (llwrtlay) THEN 
    … …  
    816843      INTEGER :: isziref, iszjref 
    817844      INTEGER :: inbij, iszij 
    818       INTEGER :: inbimax, inbjmax, inbijmax 
     845      INTEGER :: inbimax, inbjmax, inbijmax, inbijold 
    819846      INTEGER :: isz0, isz1 
    820847      INTEGER, DIMENSION(  :), ALLOCATABLE :: indexok 
    … …  
    941968      DEALLOCATE( indexok, inbi1, inbj1, iszi1, iszj1 ) 
    942969 
    943       IF( llist ) THEN  ! we print about 21 best partitions 
     970      IF( llist ) THEN 
    944971         IF(lwp) THEN 
    945972            WRITE(numout,*) 
    946             WRITE(numout,         *) '                  For your information:' 
    947             WRITE(numout,'(a,i5,a)') '  list of the best partitions around ',   knbij, ' mpi processes' 
    948             WRITE(numout,         *) '  --------------------------------------', '-----', '--------------' 
     973            WRITE(numout,*) '                  For your information:' 
     974            WRITE(numout,*) '  list of the best partitions including land supression' 
     975            WRITE(numout,*) '  -----------------------------------------------------' 
    949976            WRITE(numout,*) 
    950977         END IF 
    951          iitarget = MINLOC( inbi0(:)*inbj0(:), mask = inbi0(:)*inbj0(:) >= knbij, dim = 1 ) 
    952          DO ji = MAX(1,iitarget-10), MIN(isz0,iitarget+10) 
     978         ji = isz0   ! initialization with the largest value 
     979         ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 
     980         CALL mpp_init_isoce( inbi0(ji), inbj0(ji), llisoce ) ! Warning: must be call by all cores (call mpp_sum) 
     981         inbijold = COUNT(llisoce) 
     982         DEALLOCATE( llisoce ) 
     983         DO ji =isz0-1,1,-1 
    953984            ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 
    954985            CALL mpp_init_isoce( inbi0(ji), inbj0(ji), llisoce ) ! Warning: must be call by all cores (call mpp_sum) 
    955986            inbij = COUNT(llisoce) 
    956987            DEALLOCATE( llisoce ) 
    957             IF(lwp) WRITE(numout,'(a, i5, a, i5, a, i4, a, i4, a, i9, a, i5, a, i5, a)')    & 
    958                &     'nb_cores ' , inbij,' oce + ', inbi0(ji)*inbj0(ji) - inbij             & 
    959                &                                , ' land ( ', inbi0(ji),' x ', inbj0(ji),   & 
    960                & ' ), nb_points ', iszi0(ji)*iszj0(ji),' ( ', iszi0(ji),' x ', iszj0(ji),' )' 
     988            IF(lwp .AND. inbij < inbijold) THEN 
     989               WRITE(numout,'(a, i6, a, i6, a, f4.1, a, i9, a, i6, a, i6, a)')                                 & 
     990                  &   'nb_cores oce: ', inbij, ', land domains excluded: ', inbi0(ji)*inbj0(ji) - inbij,       & 
     991                  &   ' (', REAL(inbi0(ji)*inbj0(ji) - inbij,wp) / REAL(inbi0(ji)*inbj0(ji),wp) *100.,         & 
     992                  &   '%), largest oce domain: ', iszi0(ji)*iszj0(ji), ' ( ', iszi0(ji),' x ', iszj0(ji), ' )' 
     993               inbijold = inbij 
     994            END IF 
    961995         END DO 
    962996         DEALLOCATE( inbi0, inbj0, iszi0, iszj0 ) 
    963          RETURN 
     997         IF(lwp) THEN 
     998            WRITE(numout,*) 
     999            WRITE(numout,*)  '  -----------------------------------------------------------' 
     1000         ENDIF 
     1001         CALL mppsync 
     1002         CALL mppstop( ld_abort = .TRUE. ) 
    9641003      ENDIF 
    9651004       
Note: See TracChangeset for help on using the changeset viewer.