Ignore:
Timestamp:
2019-10-12T16:08:18+02:00 (16 months ago)
Author:
francesca
Message:

Update branch to integrate the development starting from the current v4.01 ready trunk

Location:
NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC
Files:
2 deleted
8 edited

Legend:

Unmodified
Added
Removed
  • NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC/lbc_lnk_multi_generic.h90

    r10425 r11692  
    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_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC/lbc_nfd_nogather_generic.h90

    r10425 r11692  
    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_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC/lbclnk.F90

    r10425 r11692  
    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_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC/lbcnfd.F90

    r10425 r11692  
    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_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC/lib_mpp.F90

    r10982 r11692  
    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) 
     
    145132   INTEGER, PUBLIC ::   north_root        !: number (in the comm_opa) of proc 0 in the northern comm 
    146133   INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_north   !: dimension ndim_rank_north 
    147  
    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 
    152134 
    153135   ! Communications summary report 
     
    187169   LOGICAL, PUBLIC ::   ln_nnogather                !: namelist control of northfold comms 
    188170   LOGICAL, PUBLIC ::   l_north_nogather = .FALSE.  !: internal control of northfold comms 
    189  
     171    
    190172   !!---------------------------------------------------------------------- 
    191173   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
     
    195177CONTAINS 
    196178 
    197    FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm ) 
    198       !!---------------------------------------------------------------------- 
    199       !!                  ***  routine mynode  *** 
    200       !! 
    201       !! ** Purpose :   Find processor unit 
    202       !!---------------------------------------------------------------------- 
    203       CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt        ! 
    204       CHARACTER(len=*)             , INTENT(in   ) ::   ldname       ! 
    205       INTEGER                      , INTENT(in   ) ::   kumnam_ref   ! logical unit for reference namelist 
    206       INTEGER                      , INTENT(in   ) ::   kumnam_cfg   ! logical unit for configuration namelist 
    207       INTEGER                      , INTENT(inout) ::   kumond       ! logical unit for namelist output 
    208       INTEGER                      , INTENT(inout) ::   kstop        ! stop indicator 
     179   SUBROUTINE mpp_start( localComm ) 
     180      !!---------------------------------------------------------------------- 
     181      !!                  ***  routine mpp_start  *** 
     182      !! 
     183      !! ** Purpose :   get mpi_comm_oce, mpprank and mppsize 
     184      !!---------------------------------------------------------------------- 
    209185      INTEGER         , OPTIONAL   , INTENT(in   ) ::   localComm    ! 
    210186      ! 
    211       INTEGER ::   mynode, ierr, code, ji, ii, ios 
    212       LOGICAL ::   mpi_was_called 
    213       ! 
    214       NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, ln_nnogather 
    215       !!---------------------------------------------------------------------- 
    216       ! 
    217       ii = 1 
    218       WRITE(ldtxt(ii),*)                                                                  ;   ii = ii + 1 
    219       WRITE(ldtxt(ii),*) 'mynode : mpi initialisation'                                    ;   ii = ii + 1 
    220       WRITE(ldtxt(ii),*) '~~~~~~ '                                                        ;   ii = ii + 1 
    221       ! 
    222       REWIND( kumnam_ref )              ! Namelist nammpp in reference namelist: mpi variables 
    223       READ  ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901) 
    224 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp ) 
    225       ! 
    226       REWIND( kumnam_cfg )              ! Namelist nammpp in configuration namelist: mpi variables 
    227       READ  ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 
    228 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp ) 
    229       ! 
    230       !                              ! control print 
    231       WRITE(ldtxt(ii),*) '   Namelist nammpp'                                             ;   ii = ii + 1 
    232       WRITE(ldtxt(ii),*) '      mpi send type          cn_mpi_send = ', cn_mpi_send       ;   ii = ii + 1 
    233       WRITE(ldtxt(ii),*) '      size exported buffer   nn_buffer   = ', nn_buffer,' bytes';   ii = ii + 1 
    234       ! 
    235       IF( jpni < 1 .OR. jpnj < 1  ) THEN 
    236          WRITE(ldtxt(ii),*) '      jpni and jpnj will be calculated automatically' ;   ii = ii + 1 
    237       ELSE 
    238          WRITE(ldtxt(ii),*) '      processor grid extent in i         jpni = ',jpni       ;   ii = ii + 1 
    239          WRITE(ldtxt(ii),*) '      processor grid extent in j         jpnj = ',jpnj       ;   ii = ii + 1 
    240       ENDIF 
    241  
    242       WRITE(ldtxt(ii),*) '      avoid use of mpi_allgather at the north fold  ln_nnogather = ', ln_nnogather  ; ii = ii + 1 
    243  
    244       CALL mpi_initialized ( mpi_was_called, code ) 
    245       IF( code /= MPI_SUCCESS ) THEN 
    246          DO ji = 1, SIZE(ldtxt) 
    247             IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    248          END DO 
    249          WRITE(*, cform_err) 
    250          WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' 
    251          CALL mpi_abort( mpi_comm_world, code, ierr ) 
    252       ENDIF 
    253  
    254       IF( mpi_was_called ) THEN 
    255          ! 
    256          SELECT CASE ( cn_mpi_send ) 
    257          CASE ( 'S' )                ! Standard mpi send (blocking) 
    258             WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'             ;   ii = ii + 1 
    259          CASE ( 'B' )                ! Buffer mpi send (blocking) 
    260             WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'              ;   ii = ii + 1 
    261             IF( Agrif_Root() )   CALL mpi_init_oce( ldtxt, ii, ierr ) 
    262          CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    263             WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'           ;   ii = ii + 1 
    264             l_isend = .TRUE. 
    265          CASE DEFAULT 
    266             WRITE(ldtxt(ii),cform_err)                                                    ;   ii = ii + 1 
    267             WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send     ;   ii = ii + 1 
    268             kstop = kstop + 1 
    269          END SELECT 
    270          ! 
    271       ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN 
    272          WRITE(ldtxt(ii),cform_err)                                                    ;   ii = ii + 1 
    273          WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator '          ;   ii = ii + 1 
    274          WRITE(ldtxt(ii),*) '          without calling MPI_Init before ! '                ;   ii = ii + 1 
    275          kstop = kstop + 1 
    276       ELSE 
    277          SELECT CASE ( cn_mpi_send ) 
    278          CASE ( 'S' )                ! Standard mpi send (blocking) 
    279             WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'             ;   ii = ii + 1 
    280             CALL mpi_init( ierr ) 
    281          CASE ( 'B' )                ! Buffer mpi send (blocking) 
    282             WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'              ;   ii = ii + 1 
    283             IF( Agrif_Root() )   CALL mpi_init_oce( ldtxt, ii, ierr ) 
    284          CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    285             WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'           ;   ii = ii + 1 
    286             l_isend = .TRUE. 
    287             CALL mpi_init( ierr ) 
    288          CASE DEFAULT 
    289             WRITE(ldtxt(ii),cform_err)                                                    ;   ii = ii + 1 
    290             WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send     ;   ii = ii + 1 
    291             kstop = kstop + 1 
    292          END SELECT 
    293          ! 
    294       ENDIF 
    295  
     187      INTEGER ::   ierr 
     188      LOGICAL ::   llmpi_init 
     189      !!---------------------------------------------------------------------- 
     190#if defined key_mpp_mpi 
     191      ! 
     192      CALL mpi_initialized ( llmpi_init, ierr ) 
     193      IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_initialized' ) 
     194 
     195      IF( .NOT. llmpi_init ) THEN 
     196         IF( PRESENT(localComm) ) THEN 
     197            WRITE(ctmp1,*) ' lib_mpp: You cannot provide a local communicator ' 
     198            WRITE(ctmp2,*) '          without calling MPI_Init before ! ' 
     199            CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) 
     200         ENDIF 
     201         CALL mpi_init( ierr ) 
     202         IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_init' ) 
     203      ENDIF 
     204        
    296205      IF( PRESENT(localComm) ) THEN 
    297206         IF( Agrif_Root() ) THEN 
     
    299208         ENDIF 
    300209      ELSE 
    301          CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code) 
    302          IF( code /= MPI_SUCCESS ) THEN 
    303             DO ji = 1, SIZE(ldtxt) 
    304                IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    305             END DO 
    306             WRITE(*, cform_err) 
    307             WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 
    308             CALL mpi_abort( mpi_comm_world, code, ierr ) 
    309          ENDIF 
    310       ENDIF 
    311  
    312 #if defined key_agrif 
     210         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, ierr) 
     211         IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_comm_dup' ) 
     212      ENDIF 
     213 
     214# if defined key_agrif 
    313215      IF( Agrif_Root() ) THEN 
    314216         CALL Agrif_MPI_Init(mpi_comm_oce) 
     
    316218         CALL Agrif_MPI_set_grid_comm(mpi_comm_oce) 
    317219      ENDIF 
    318 #endif 
     220# endif 
    319221 
    320222      CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr ) 
    321223      CALL mpi_comm_size( mpi_comm_oce, mppsize, ierr ) 
    322       mynode = mpprank 
    323  
    324       IF( mynode == 0 ) THEN 
    325          CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
    326          WRITE(kumond, nammpp)       
    327       ENDIF 
    328224      ! 
    329225      CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) 
    330226      ! 
    331    END FUNCTION mynode 
    332  
    333    !!---------------------------------------------------------------------- 
    334    !!                   ***  routine mpp_lnk_(2,3,4)d  *** 
    335    !! 
    336    !!   * Argument : dummy argument use in mpp_lnk_... routines 
    337    !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
    338    !!                cd_nat :   nature of array grid-points 
    339    !!                psgn   :   sign used across the north fold boundary 
    340    !!                kfld   :   optional, number of pt3d arrays 
    341    !!                cd_mpp :   optional, fill the overlap area only 
    342    !!                pval   :   optional, background value (used at closed boundaries) 
    343    !!---------------------------------------------------------------------- 
    344    ! 
    345    !                       !==  2D array and array of 2D pointer  ==! 
    346    ! 
    347 #  define DIM_2d 
    348 #     define ROUTINE_LNK           mpp_lnk_2d 
    349 #     include "mpp_lnk_generic.h90" 
    350 #     undef ROUTINE_LNK 
    351 #     define MULTI 
    352 #     define ROUTINE_LNK           mpp_lnk_2d_ptr 
    353 #     include "mpp_lnk_generic.h90" 
    354 #     undef ROUTINE_LNK 
    355 #     undef MULTI 
    356 #  undef DIM_2d 
    357    ! 
    358    !                       !==  3D array and array of 3D pointer  ==! 
    359    ! 
    360 #  define DIM_3d 
    361 #     define ROUTINE_LNK           mpp_lnk_3d 
    362 #     include "mpp_lnk_generic.h90" 
    363 #     undef ROUTINE_LNK 
    364 #     define MULTI 
    365 #     define ROUTINE_LNK           mpp_lnk_3d_ptr 
    366 #     include "mpp_lnk_generic.h90" 
    367 #     undef ROUTINE_LNK 
    368 #     undef MULTI 
    369 #  undef DIM_3d 
    370    ! 
    371    !                       !==  4D array and array of 4D pointer  ==! 
    372    ! 
    373 #  define DIM_4d 
    374 #     define ROUTINE_LNK           mpp_lnk_4d 
    375 #     include "mpp_lnk_generic.h90" 
    376 #     undef ROUTINE_LNK 
    377 #     define MULTI 
    378 #     define ROUTINE_LNK           mpp_lnk_4d_ptr 
    379 #     include "mpp_lnk_generic.h90" 
    380 #     undef ROUTINE_LNK 
    381 #     undef MULTI 
    382 #  undef DIM_4d 
    383  
    384    !!---------------------------------------------------------------------- 
    385    !!                   ***  routine mpp_nfd_(2,3,4)d  *** 
    386    !! 
    387    !!   * Argument : dummy argument use in mpp_nfd_... routines 
    388    !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
    389    !!                cd_nat :   nature of array grid-points 
    390    !!                psgn   :   sign used across the north fold boundary 
    391    !!                kfld   :   optional, number of pt3d arrays 
    392    !!                cd_mpp :   optional, fill the overlap area only 
    393    !!                pval   :   optional, background value (used at closed boundaries) 
    394    !!---------------------------------------------------------------------- 
    395    ! 
    396    !                       !==  2D array and array of 2D pointer  ==! 
    397    ! 
    398 #  define DIM_2d 
    399 #     define ROUTINE_NFD           mpp_nfd_2d 
    400 #     include "mpp_nfd_generic.h90" 
    401 #     undef ROUTINE_NFD 
    402 #     define MULTI 
    403 #     define ROUTINE_NFD           mpp_nfd_2d_ptr 
    404 #     include "mpp_nfd_generic.h90" 
    405 #     undef ROUTINE_NFD 
    406 #     undef MULTI 
    407 #  undef DIM_2d 
    408    ! 
    409    !                       !==  3D array and array of 3D pointer  ==! 
    410    ! 
    411 #  define DIM_3d 
    412 #     define ROUTINE_NFD           mpp_nfd_3d 
    413 #     include "mpp_nfd_generic.h90" 
    414 #     undef ROUTINE_NFD 
    415 #     define MULTI 
    416 #     define ROUTINE_NFD           mpp_nfd_3d_ptr 
    417 #     include "mpp_nfd_generic.h90" 
    418 #     undef ROUTINE_NFD 
    419 #     undef MULTI 
    420 #  undef DIM_3d 
    421    ! 
    422    !                       !==  4D array and array of 4D pointer  ==! 
    423    ! 
    424 #  define DIM_4d 
    425 #     define ROUTINE_NFD           mpp_nfd_4d 
    426 #     include "mpp_nfd_generic.h90" 
    427 #     undef ROUTINE_NFD 
    428 #     define MULTI 
    429 #     define ROUTINE_NFD           mpp_nfd_4d_ptr 
    430 #     include "mpp_nfd_generic.h90" 
    431 #     undef ROUTINE_NFD 
    432 #     undef MULTI 
    433 #  undef DIM_4d 
    434  
    435  
    436    !!---------------------------------------------------------------------- 
    437    !!                   ***  routine mpp_lnk_bdy_(2,3,4)d  *** 
    438    !! 
    439    !!   * Argument : dummy argument use in mpp_lnk_... routines 
    440    !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
    441    !!                cd_nat :   nature of array grid-points 
    442    !!                psgn   :   sign used across the north fold boundary 
    443    !!                kb_bdy :   BDY boundary set 
    444    !!                kfld   :   optional, number of pt3d arrays 
    445    !!---------------------------------------------------------------------- 
    446    ! 
    447    !                       !==  2D array and array of 2D pointer  ==! 
    448    ! 
    449 #  define DIM_2d 
    450 #     define ROUTINE_BDY           mpp_lnk_bdy_2d 
    451 #     include "mpp_bdy_generic.h90" 
    452 #     undef ROUTINE_BDY 
    453 #  undef DIM_2d 
    454    ! 
    455    !                       !==  3D array and array of 3D pointer  ==! 
    456    ! 
    457 #  define DIM_3d 
    458 #     define ROUTINE_BDY           mpp_lnk_bdy_3d 
    459 #     include "mpp_bdy_generic.h90" 
    460 #     undef ROUTINE_BDY 
    461 #  undef DIM_3d 
    462    ! 
    463    !                       !==  4D array and array of 4D pointer  ==! 
    464    ! 
    465 #  define DIM_4d 
    466 #     define ROUTINE_BDY           mpp_lnk_bdy_4d 
    467 #     include "mpp_bdy_generic.h90" 
    468 #     undef ROUTINE_BDY 
    469 #  undef DIM_4d 
    470  
    471    !!---------------------------------------------------------------------- 
    472    !! 
    473    !!   load_array  &   mpp_lnk_2d_9    à generaliser a 3D et 4D 
    474     
    475     
    476    !!    mpp_lnk_sum_2d et 3D   ====>>>>>>   à virer du code !!!! 
    477     
    478     
    479    !!---------------------------------------------------------------------- 
    480  
     227#else 
     228      IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 
     229      mppsize = 1 
     230      mpprank = 0 
     231#endif 
     232   END SUBROUTINE mpp_start 
    481233 
    482234 
     
    497249      !!---------------------------------------------------------------------- 
    498250      ! 
    499       SELECT CASE ( cn_mpi_send ) 
    500       CASE ( 'S' )                ! Standard mpi send (blocking) 
    501          CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce        , iflag ) 
    502       CASE ( 'B' )                ! Buffer mpi send (blocking) 
    503          CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce        , iflag ) 
    504       CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    505          ! be carefull, one more argument here : the mpi request identifier.. 
    506          CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
    507       END SELECT 
     251#if defined key_mpp_mpi 
     252      CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
     253#endif 
    508254      ! 
    509255   END SUBROUTINE mppsend 
     
    527273      !!---------------------------------------------------------------------- 
    528274      ! 
     275#if defined key_mpp_mpi 
    529276      ! If a specific process number has been passed to the receive call, 
    530277      ! use that one. Default is to use mpi_any_source 
     
    533280      ! 
    534281      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 
     282#endif 
    535283      ! 
    536284   END SUBROUTINE mpprecv 
     
    553301      ! 
    554302      itaille = jpi * jpj 
     303#if defined key_mpp_mpi 
    555304      CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille     ,   & 
    556305         &                            mpi_double_precision, kp , mpi_comm_oce, ierror ) 
     306#else 
     307      pio(:,:,1) = ptab(:,:) 
     308#endif 
    557309      ! 
    558310   END SUBROUTINE mppgather 
     
    576328      itaille = jpi * jpj 
    577329      ! 
     330#if defined key_mpp_mpi 
    578331      CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille     ,   & 
    579332         &                            mpi_double_precision, kp  , mpi_comm_oce, ierror ) 
     333#else 
     334      ptab(:,:) = pio(:,:,1) 
     335#endif 
    580336      ! 
    581337   END SUBROUTINE mppscatter 
     
    601357      COMPLEX(wp), ALLOCATABLE, DIMENSION(:) ::   ytmp 
    602358      !!---------------------------------------------------------------------- 
     359#if defined key_mpp_mpi 
    603360      ilocalcomm = mpi_comm_oce 
    604361      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     
    639396 
    640397      ! send y_in into todelay(idvar)%y1d with a non-blocking communication 
    641 #if defined key_mpi2 
     398# if defined key_mpi2 
    642399      IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 
    643400      CALL  mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 
    644401      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
     402# else 
     403      CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 
     404# endif 
    645405#else 
    646       CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 
     406      pout(:) = REAL(y_in(:), wp) 
    647407#endif 
    648408 
     
    668428      INTEGER ::   ierr, ilocalcomm 
    669429      !!---------------------------------------------------------------------- 
     430#if defined key_mpp_mpi 
    670431      ilocalcomm = mpi_comm_oce 
    671432      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     
    702463 
    703464      ! send p_in into todelay(idvar)%z1d with a non-blocking communication 
    704 #if defined key_mpi2 
     465# if defined key_mpi2 
    705466      IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 
    706467      CALL  mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
    707468      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
     469# else 
     470      CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
     471# endif 
    708472#else 
    709       CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
     473      pout(:) = p_in(:) 
    710474#endif 
    711475 
     
    723487      INTEGER ::   ierr 
    724488      !!---------------------------------------------------------------------- 
     489#if defined key_mpp_mpi 
    725490      IF( ndelayid(kid) /= -2 ) THEN   
    726491#if ! defined key_mpi2 
     
    732497         ndelayid(kid) = -2   ! add flag to know that mpi_wait was already called on kid 
    733498      ENDIF 
     499#endif 
    734500   END SUBROUTINE mpp_delay_rcv 
    735501 
     
    890656      !!----------------------------------------------------------------------- 
    891657      ! 
     658#if defined key_mpp_mpi 
    892659      CALL mpi_barrier( mpi_comm_oce, ierror ) 
     660#endif 
    893661      ! 
    894662   END SUBROUTINE mppsync 
    895663 
    896664 
    897    SUBROUTINE mppstop( ldfinal, ld_force_abort )  
     665   SUBROUTINE mppstop( ld_abort )  
    898666      !!---------------------------------------------------------------------- 
    899667      !!                  ***  routine mppstop  *** 
     
    902670      !! 
    903671      !!---------------------------------------------------------------------- 
    904       LOGICAL, OPTIONAL, INTENT(in) :: ldfinal    ! source process number 
    905       LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort    ! source process number 
    906       LOGICAL ::   llfinal, ll_force_abort 
     672      LOGICAL, OPTIONAL, INTENT(in) :: ld_abort    ! source process number 
     673      LOGICAL ::   ll_abort 
    907674      INTEGER ::   info 
    908675      !!---------------------------------------------------------------------- 
    909       llfinal = .FALSE. 
    910       IF( PRESENT(ldfinal) ) llfinal = ldfinal 
    911       ll_force_abort = .FALSE. 
    912       IF( PRESENT(ld_force_abort) ) ll_force_abort = ld_force_abort 
    913       ! 
    914       IF(ll_force_abort) THEN 
     676      ll_abort = .FALSE. 
     677      IF( PRESENT(ld_abort) ) ll_abort = ld_abort 
     678      ! 
     679#if defined key_mpp_mpi 
     680      IF(ll_abort) THEN 
    915681         CALL mpi_abort( MPI_COMM_WORLD ) 
    916682      ELSE 
     
    918684         CALL mpi_finalize( info ) 
    919685      ENDIF 
    920       IF( .NOT. llfinal ) STOP 123 
     686#endif 
     687      IF( ll_abort ) STOP 123 
    921688      ! 
    922689   END SUBROUTINE mppstop 
     
    930697      !!---------------------------------------------------------------------- 
    931698      ! 
     699#if defined key_mpp_mpi 
    932700      CALL MPI_COMM_FREE(kcom, ierr) 
     701#endif 
    933702      ! 
    934703   END SUBROUTINE mpp_comm_free 
     
    960729      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kwork 
    961730      !!---------------------------------------------------------------------- 
     731#if defined key_mpp_mpi 
    962732      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world     : ', ngrp_world 
    963733      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world 
     
    965735      ! 
    966736      ALLOCATE( kwork(jpnij), STAT=ierr ) 
    967       IF( ierr /= 0 ) THEN 
    968          WRITE(kumout, cform_err) 
    969          WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij' 
    970          CALL mppstop 
    971       ENDIF 
     737      IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_ini_znl : failed to allocate 1D array of length jpnij') 
    972738 
    973739      IF( jpnj == 1 ) THEN 
     
    1031797 
    1032798      DEALLOCATE(kwork) 
     799#endif 
    1033800 
    1034801   END SUBROUTINE mpp_ini_znl 
     
    1062829      !!---------------------------------------------------------------------- 
    1063830      ! 
     831#if defined key_mpp_mpi 
    1064832      njmppmax = MAXVAL( njmppt ) 
    1065833      ! 
     
    1093861      CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr ) 
    1094862      ! 
     863#endif 
    1095864   END SUBROUTINE mpp_ini_north 
    1096  
    1097  
    1098    SUBROUTINE mpi_init_oce( ldtxt, ksft, code ) 
    1099       !!--------------------------------------------------------------------- 
    1100       !!                   ***  routine mpp_init.opa  *** 
    1101       !! 
    1102       !! ** Purpose :: export and attach a MPI buffer for bsend 
    1103       !! 
    1104       !! ** Method  :: define buffer size in namelist, if 0 no buffer attachment 
    1105       !!            but classical mpi_init 
    1106       !! 
    1107       !! History :: 01/11 :: IDRIS initial version for IBM only 
    1108       !!            08/04 :: R. Benshila, generalisation 
    1109       !!--------------------------------------------------------------------- 
    1110       CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt 
    1111       INTEGER                      , INTENT(inout) ::   ksft 
    1112       INTEGER                      , INTENT(  out) ::   code 
    1113       INTEGER                                      ::   ierr, ji 
    1114       LOGICAL                                      ::   mpi_was_called 
    1115       !!--------------------------------------------------------------------- 
    1116       ! 
    1117       CALL mpi_initialized( mpi_was_called, code )      ! MPI initialization 
    1118       IF ( code /= MPI_SUCCESS ) THEN 
    1119          DO ji = 1, SIZE(ldtxt) 
    1120             IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    1121          END DO 
    1122          WRITE(*, cform_err) 
    1123          WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized' 
    1124          CALL mpi_abort( mpi_comm_world, code, ierr ) 
    1125       ENDIF 
    1126       ! 
    1127       IF( .NOT. mpi_was_called ) THEN 
    1128          CALL mpi_init( code ) 
    1129          CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code ) 
    1130          IF ( code /= MPI_SUCCESS ) THEN 
    1131             DO ji = 1, SIZE(ldtxt) 
    1132                IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    1133             END DO 
    1134             WRITE(*, cform_err) 
    1135             WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 
    1136             CALL mpi_abort( mpi_comm_world, code, ierr ) 
    1137          ENDIF 
    1138       ENDIF 
    1139       ! 
    1140       IF( nn_buffer > 0 ) THEN 
    1141          WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of  : ', nn_buffer   ;   ksft = ksft + 1 
    1142          ! Buffer allocation and attachment 
    1143          ALLOCATE( tampon(nn_buffer), stat = ierr ) 
    1144          IF( ierr /= 0 ) THEN 
    1145             DO ji = 1, SIZE(ldtxt) 
    1146                IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    1147             END DO 
    1148             WRITE(*, cform_err) 
    1149             WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr 
    1150             CALL mpi_abort( mpi_comm_world, code, ierr ) 
    1151          END IF 
    1152          CALL mpi_buffer_attach( tampon, nn_buffer, code ) 
    1153       ENDIF 
    1154       ! 
    1155    END SUBROUTINE mpi_init_oce 
    1156865 
    1157866 
     
    1187896 
    1188897 
    1189    SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 
    1190       !!--------------------------------------------------------------------- 
    1191       !!                   ***  routine mpp_lbc_north_icb  *** 
    1192       !! 
    1193       !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    1194       !!              in mpp configuration in case of jpn1 > 1 and for 2d 
    1195       !!              array with outer extra halo 
    1196       !! 
    1197       !! ** Method  :   North fold condition and mpp with more than one proc 
    1198       !!              in i-direction require a specific treatment. We gather 
    1199       !!              the 4+kextj northern lines of the global domain on 1 
    1200       !!              processor and apply lbc north-fold on this sub array. 
    1201       !!              Then we scatter the north fold array back to the processors. 
    1202       !!              This routine accounts for an extra halo with icebergs 
    1203       !!              and assumes ghost rows and columns have been suppressed. 
    1204       !! 
    1205       !!---------------------------------------------------------------------- 
    1206       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    1207       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points 
    1208       !                                                     !   = T ,  U , V , F or W -points 
    1209       REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
    1210       !!                                                    ! north fold, =  1. otherwise 
    1211       INTEGER                 , INTENT(in   ) ::   kextj    ! Extra halo width at north fold 
    1212       ! 
    1213       INTEGER ::   ji, jj, jr 
    1214       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    1215       INTEGER ::   ipj, ij, iproc 
    1216       ! 
    1217       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
    1218       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e 
    1219       !!---------------------------------------------------------------------- 
    1220       ! 
    1221       ipj=4 
    1222       ALLOCATE(        ztab_e(jpiglo, 1-kextj:ipj+kextj)       ,       & 
    1223      &            znorthloc_e(jpimax, 1-kextj:ipj+kextj)       ,       & 
    1224      &          znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni)    ) 
    1225       ! 
    1226       ztab_e(:,:)      = 0._wp 
    1227       znorthloc_e(:,:) = 0._wp 
    1228       ! 
    1229       ij = 1 - kextj 
    1230       ! put the last ipj+2*kextj lines of pt2d into znorthloc_e  
    1231       DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
    1232          znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 
    1233          ij = ij + 1 
    1234       END DO 
    1235       ! 
    1236       itaille = jpimax * ( ipj + 2*kextj ) 
    1237       ! 
    1238       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    1239       CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj)    , itaille, MPI_DOUBLE_PRECISION,    & 
    1240          &                znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION,    & 
    1241          &                ncomm_north, ierr ) 
    1242       ! 
    1243       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    1244       ! 
    1245       DO jr = 1, ndim_rank_north            ! recover the global north array 
    1246          iproc = nrank_north(jr) + 1 
    1247          ildi = nldit (iproc) 
    1248          ilei = nleit (iproc) 
    1249          iilb = nimppt(iproc) 
    1250          DO jj = 1-kextj, ipj+kextj 
    1251             DO ji = ildi, ilei 
    1252                ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 
    1253             END DO 
    1254          END DO 
    1255       END DO 
    1256  
    1257       ! 2. North-Fold boundary conditions 
    1258       ! ---------------------------------- 
    1259       CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) 
    1260  
    1261       ij = 1 - kextj 
    1262       !! Scatter back to pt2d 
    1263       DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
    1264          DO ji= 1, jpi 
    1265             pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 
    1266          END DO 
    1267          ij  = ij +1 
    1268       END DO 
    1269       ! 
    1270       DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 
    1271       ! 
    1272    END SUBROUTINE mpp_lbc_north_icb 
    1273  
    1274  
    1275    SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj ) 
    1276       !!---------------------------------------------------------------------- 
    1277       !!                  ***  routine mpp_lnk_2d_icb  *** 
    1278       !! 
    1279       !! ** Purpose :   Message passing management for 2d array (with extra halo for icebergs) 
    1280       !!                This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) 
    1281       !!                array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. 
    1282       !! 
    1283       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1284       !!      between processors following neighboring subdomains. 
    1285       !!            domain parameters 
    1286       !!                    jpi    : first dimension of the local subdomain 
    1287       !!                    jpj    : second dimension of the local subdomain 
    1288       !!                    kexti  : number of columns for extra outer halo 
    1289       !!                    kextj  : number of rows for extra outer halo 
    1290       !!                    nbondi : mark for "east-west local boundary" 
    1291       !!                    nbondj : mark for "north-south local boundary" 
    1292       !!                    noea   : number for local neighboring processors 
    1293       !!                    nowe   : number for local neighboring processors 
    1294       !!                    noso   : number for local neighboring processors 
    1295       !!                    nono   : number for local neighboring processors 
    1296       !!---------------------------------------------------------------------- 
    1297       CHARACTER(len=*)                                        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    1298       REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    1299       CHARACTER(len=1)                                        , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
    1300       REAL(wp)                                                , INTENT(in   ) ::   psgn     ! sign used across the north fold 
    1301       INTEGER                                                 , INTENT(in   ) ::   kexti    ! extra i-halo width 
    1302       INTEGER                                                 , INTENT(in   ) ::   kextj    ! extra j-halo width 
    1303       ! 
    1304       INTEGER  ::   jl   ! dummy loop indices 
    1305       INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    1306       INTEGER  ::   ipreci, iprecj             !   -       - 
    1307       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1308       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    1309       !! 
    1310       REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) ::   r2dns, r2dsn 
    1311       REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) ::   r2dwe, r2dew 
    1312       !!---------------------------------------------------------------------- 
    1313  
    1314       ipreci = nn_hls + kexti      ! take into account outer extra 2D overlap area 
    1315       iprecj = nn_hls + kextj 
    1316  
    1317       IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) 
    1318  
    1319       ! 1. standard boundary treatment 
    1320       ! ------------------------------ 
    1321       ! Order matters Here !!!! 
    1322       ! 
    1323       !                                      ! East-West boundaries 
    1324       !                                           !* Cyclic east-west 
    1325       IF( l_Iperio ) THEN 
    1326          pt2d(1-kexti:     1   ,:) = pt2d(jpim1-kexti: jpim1 ,:)       ! east 
    1327          pt2d(  jpi  :jpi+kexti,:) = pt2d(     2     :2+kexti,:)       ! west 
    1328          ! 
    1329       ELSE                                        !* closed 
    1330          IF( .NOT. cd_type == 'F' )   pt2d(  1-kexti   :nn_hls   ,:) = 0._wp    ! east except at F-point 
    1331                                       pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp    ! west 
    1332       ENDIF 
    1333       !                                      ! North-South boundaries 
    1334       IF( l_Jperio ) THEN                         !* cyclic (only with no mpp j-split) 
    1335          pt2d(:,1-kextj:     1   ) = pt2d(:,jpjm1-kextj:  jpjm1)       ! north 
    1336          pt2d(:,  jpj  :jpj+kextj) = pt2d(:,     2     :2+kextj)       ! south 
    1337       ELSE                                        !* closed 
    1338          IF( .NOT. cd_type == 'F' )   pt2d(:,  1-kextj   :nn_hls   ) = 0._wp    ! north except at F-point 
    1339                                       pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp    ! south 
    1340       ENDIF 
    1341       ! 
    1342  
    1343       ! north fold treatment 
    1344       ! ----------------------- 
    1345       IF( npolj /= 0 ) THEN 
    1346          ! 
    1347          SELECT CASE ( jpni ) 
    1348                    CASE ( 1 )     ;   CALL lbc_nfd          ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
    1349                    CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
    1350          END SELECT 
    1351          ! 
    1352       ENDIF 
    1353  
    1354       ! 2. East and west directions exchange 
    1355       ! ------------------------------------ 
    1356       ! we play with the neigbours AND the row number because of the periodicity 
    1357       ! 
    1358       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    1359       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1360          iihom = jpi-nreci-kexti 
    1361          DO jl = 1, ipreci 
    1362             r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 
    1363             r2dwe(:,jl,1) = pt2d(iihom +jl,:) 
    1364          END DO 
    1365       END SELECT 
    1366       ! 
    1367       !                           ! Migrations 
    1368       imigr = ipreci * ( jpj + 2*kextj ) 
    1369       ! 
    1370       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    1371       ! 
    1372       SELECT CASE ( nbondi ) 
    1373       CASE ( -1 ) 
    1374          CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 
    1375          CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
    1376          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1377       CASE ( 0 ) 
    1378          CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
    1379          CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 
    1380          CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
    1381          CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    1382          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1383          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1384       CASE ( 1 ) 
    1385          CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
    1386          CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    1387          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1388       END SELECT 
    1389       ! 
    1390       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    1391       ! 
    1392       !                           ! Write Dirichlet lateral conditions 
    1393       iihom = jpi - nn_hls 
    1394       ! 
    1395       SELECT CASE ( nbondi ) 
    1396       CASE ( -1 ) 
    1397          DO jl = 1, ipreci 
    1398             pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    1399          END DO 
    1400       CASE ( 0 ) 
    1401          DO jl = 1, ipreci 
    1402             pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
    1403             pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    1404          END DO 
    1405       CASE ( 1 ) 
    1406          DO jl = 1, ipreci 
    1407             pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
    1408          END DO 
    1409       END SELECT 
    1410  
    1411  
    1412       ! 3. North and south directions 
    1413       ! ----------------------------- 
    1414       ! always closed : we play only with the neigbours 
    1415       ! 
    1416       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    1417          ijhom = jpj-nrecj-kextj 
    1418          DO jl = 1, iprecj 
    1419             r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 
    1420             r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 
    1421          END DO 
    1422       ENDIF 
    1423       ! 
    1424       !                           ! Migrations 
    1425       imigr = iprecj * ( jpi + 2*kexti ) 
    1426       ! 
    1427       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    1428       ! 
    1429       SELECT CASE ( nbondj ) 
    1430       CASE ( -1 ) 
    1431          CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 
    1432          CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
    1433          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1434       CASE ( 0 ) 
    1435          CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
    1436          CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 
    1437          CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
    1438          CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    1439          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1440          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1441       CASE ( 1 ) 
    1442          CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
    1443          CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    1444          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1445       END SELECT 
    1446       ! 
    1447       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    1448       ! 
    1449       !                           ! Write Dirichlet lateral conditions 
    1450       ijhom = jpj - nn_hls 
    1451       ! 
    1452       SELECT CASE ( nbondj ) 
    1453       CASE ( -1 ) 
    1454          DO jl = 1, iprecj 
    1455             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    1456          END DO 
    1457       CASE ( 0 ) 
    1458          DO jl = 1, iprecj 
    1459             pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
    1460             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    1461          END DO 
    1462       CASE ( 1 ) 
    1463          DO jl = 1, iprecj 
    1464             pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
    1465          END DO 
    1466       END SELECT 
    1467       ! 
    1468    END SUBROUTINE mpp_lnk_2d_icb 
    1469  
    1470  
    1471898   SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb, ld_dlg ) 
    1472899      !!---------------------------------------------------------------------- 
     
    1484911      INTEGER ::    ji,  jj,  jk,  jh, jf, jcount   ! dummy loop indices 
    1485912      !!---------------------------------------------------------------------- 
     913#if defined key_mpp_mpi 
    1486914      ! 
    1487915      ll_lbc = .FALSE. 
     
    15941022         DEALLOCATE(crname_lbc) 
    15951023      ENDIF 
     1024#endif 
    15961025   END SUBROUTINE mpp_report 
    15971026 
     
    16041033    REAL(wp),               SAVE :: tic_ct = 0._wp 
    16051034    INTEGER :: ii 
     1035#if defined key_mpp_mpi 
    16061036 
    16071037    IF( ncom_stp <= nit000 ) RETURN 
     
    16191049       tic_ct = MPI_Wtime()                                                        ! start count tac->tic (waiting time) 
    16201050    ENDIF 
     1051#endif 
    16211052     
    16221053   END SUBROUTINE tic_tac 
    16231054 
     1055#if ! defined key_mpp_mpi 
     1056   SUBROUTINE mpi_wait(request, status, ierror) 
     1057      INTEGER                            , INTENT(in   ) ::   request 
     1058      INTEGER, DIMENSION(MPI_STATUS_SIZE), INTENT(  out) ::   status 
     1059      INTEGER                            , INTENT(  out) ::   ierror 
     1060   END SUBROUTINE mpi_wait 
     1061 
    16241062    
    1625 #else 
    1626    !!---------------------------------------------------------------------- 
    1627    !!   Default case:            Dummy module        share memory computing 
    1628    !!---------------------------------------------------------------------- 
    1629    USE in_out_manager 
    1630  
    1631    INTERFACE mpp_sum 
    1632       MODULE PROCEDURE mppsum_int, mppsum_a_int, mppsum_real, mppsum_a_real, mppsum_realdd, mppsum_a_realdd 
    1633    END INTERFACE 
    1634    INTERFACE mpp_max 
    1635       MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real 
    1636    END INTERFACE 
    1637    INTERFACE mpp_min 
    1638       MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 
    1639    END INTERFACE 
    1640    INTERFACE mpp_minloc 
    1641       MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 
    1642    END INTERFACE 
    1643    INTERFACE mpp_maxloc 
    1644       MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
    1645    END INTERFACE 
    1646  
    1647    LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag 
    1648    LOGICAL, PUBLIC            ::   ln_nnogather          !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 
    1649    INTEGER, PUBLIC            ::   mpi_comm_oce          ! opa local communicator 
    1650  
    1651    INTEGER, PARAMETER, PUBLIC               ::   nbdelay = 0   ! make sure we don't enter loops: DO ji = 1, nbdelay 
    1652    CHARACTER(len=32), DIMENSION(1), PUBLIC  ::   c_delaylist = 'empty' 
    1653    CHARACTER(len=32), DIMENSION(1), PUBLIC  ::   c_delaycpnt = 'empty' 
    1654    LOGICAL, PUBLIC                          ::   l_full_nf_update = .TRUE. 
    1655    TYPE ::   DELAYARR 
    1656       REAL(   wp), POINTER, DIMENSION(:) ::  z1d => NULL() 
    1657       COMPLEX(wp), POINTER, DIMENSION(:) ::  y1d => NULL() 
    1658    END TYPE DELAYARR 
    1659    TYPE( DELAYARR ), DIMENSION(1), PUBLIC  ::   todelay               
    1660    INTEGER,  PUBLIC, DIMENSION(1)           ::   ndelayid = -1 
    1661    !!---------------------------------------------------------------------- 
    1662 CONTAINS 
    1663  
    1664    INTEGER FUNCTION lib_mpp_alloc(kumout)          ! Dummy function 
    1665       INTEGER, INTENT(in) ::   kumout 
    1666       lib_mpp_alloc = 0 
    1667    END FUNCTION lib_mpp_alloc 
    1668  
    1669    FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg,  kumond , kstop, localComm ) RESULT (function_value) 
    1670       INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm 
    1671       CHARACTER(len=*),DIMENSION(:) ::   ldtxt 
    1672       CHARACTER(len=*) ::   ldname 
    1673       INTEGER ::   kumnam_ref, knumnam_cfg , kumond , kstop 
    1674       IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 
    1675       function_value = 0 
    1676       IF( .FALSE. )   ldtxt(:) = 'never done' 
    1677       CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
    1678    END FUNCTION mynode 
    1679  
    1680    SUBROUTINE mppsync                       ! Dummy routine 
    1681    END SUBROUTINE mppsync 
    1682  
    1683    !!---------------------------------------------------------------------- 
    1684    !!    ***  mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real  *** 
    1685    !!    
    1686    !!---------------------------------------------------------------------- 
    1687    !! 
    1688 #  define OPERATION_MAX 
    1689 #  define INTEGER_TYPE 
    1690 #  define DIM_0d 
    1691 #     define ROUTINE_ALLREDUCE           mppmax_int 
    1692 #     include "mpp_allreduce_generic.h90" 
    1693 #     undef ROUTINE_ALLREDUCE 
    1694 #  undef DIM_0d 
    1695 #  define DIM_1d 
    1696 #     define ROUTINE_ALLREDUCE           mppmax_a_int 
    1697 #     include "mpp_allreduce_generic.h90" 
    1698 #     undef ROUTINE_ALLREDUCE 
    1699 #  undef DIM_1d 
    1700 #  undef INTEGER_TYPE 
    1701 ! 
    1702 #  define REAL_TYPE 
    1703 #  define DIM_0d 
    1704 #     define ROUTINE_ALLREDUCE           mppmax_real 
    1705 #     include "mpp_allreduce_generic.h90" 
    1706 #     undef ROUTINE_ALLREDUCE 
    1707 #  undef DIM_0d 
    1708 #  define DIM_1d 
    1709 #     define ROUTINE_ALLREDUCE           mppmax_a_real 
    1710 #     include "mpp_allreduce_generic.h90" 
    1711 #     undef ROUTINE_ALLREDUCE 
    1712 #  undef DIM_1d 
    1713 #  undef REAL_TYPE 
    1714 #  undef OPERATION_MAX 
    1715    !!---------------------------------------------------------------------- 
    1716    !!    ***  mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real  *** 
    1717    !!    
    1718    !!---------------------------------------------------------------------- 
    1719    !! 
    1720 #  define OPERATION_MIN 
    1721 #  define INTEGER_TYPE 
    1722 #  define DIM_0d 
    1723 #     define ROUTINE_ALLREDUCE           mppmin_int 
    1724 #     include "mpp_allreduce_generic.h90" 
    1725 #     undef ROUTINE_ALLREDUCE 
    1726 #  undef DIM_0d 
    1727 #  define DIM_1d 
    1728 #     define ROUTINE_ALLREDUCE           mppmin_a_int 
    1729 #     include "mpp_allreduce_generic.h90" 
    1730 #     undef ROUTINE_ALLREDUCE 
    1731 #  undef DIM_1d 
    1732 #  undef INTEGER_TYPE 
    1733 ! 
    1734 #  define REAL_TYPE 
    1735 #  define DIM_0d 
    1736 #     define ROUTINE_ALLREDUCE           mppmin_real 
    1737 #     include "mpp_allreduce_generic.h90" 
    1738 #     undef ROUTINE_ALLREDUCE 
    1739 #  undef DIM_0d 
    1740 #  define DIM_1d 
    1741 #     define ROUTINE_ALLREDUCE           mppmin_a_real 
    1742 #     include "mpp_allreduce_generic.h90" 
    1743 #     undef ROUTINE_ALLREDUCE 
    1744 #  undef DIM_1d 
    1745 #  undef REAL_TYPE 
    1746 #  undef OPERATION_MIN 
    1747  
    1748    !!---------------------------------------------------------------------- 
    1749    !!    ***  mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real  *** 
    1750    !!    
    1751    !!   Global sum of 1D array or a variable (integer, real or complex) 
    1752    !!---------------------------------------------------------------------- 
    1753    !! 
    1754 #  define OPERATION_SUM 
    1755 #  define INTEGER_TYPE 
    1756 #  define DIM_0d 
    1757 #     define ROUTINE_ALLREDUCE           mppsum_int 
    1758 #     include "mpp_allreduce_generic.h90" 
    1759 #     undef ROUTINE_ALLREDUCE 
    1760 #  undef DIM_0d 
    1761 #  define DIM_1d 
    1762 #     define ROUTINE_ALLREDUCE           mppsum_a_int 
    1763 #     include "mpp_allreduce_generic.h90" 
    1764 #     undef ROUTINE_ALLREDUCE 
    1765 #  undef DIM_1d 
    1766 #  undef INTEGER_TYPE 
    1767 ! 
    1768 #  define REAL_TYPE 
    1769 #  define DIM_0d 
    1770 #     define ROUTINE_ALLREDUCE           mppsum_real 
    1771 #     include "mpp_allreduce_generic.h90" 
    1772 #     undef ROUTINE_ALLREDUCE 
    1773 #  undef DIM_0d 
    1774 #  define DIM_1d 
    1775 #     define ROUTINE_ALLREDUCE           mppsum_a_real 
    1776 #     include "mpp_allreduce_generic.h90" 
    1777 #     undef ROUTINE_ALLREDUCE 
    1778 #  undef DIM_1d 
    1779 #  undef REAL_TYPE 
    1780 #  undef OPERATION_SUM 
    1781  
    1782 #  define OPERATION_SUM_DD 
    1783 #  define COMPLEX_TYPE 
    1784 #  define DIM_0d 
    1785 #     define ROUTINE_ALLREDUCE           mppsum_realdd 
    1786 #     include "mpp_allreduce_generic.h90" 
    1787 #     undef ROUTINE_ALLREDUCE 
    1788 #  undef DIM_0d 
    1789 #  define DIM_1d 
    1790 #     define ROUTINE_ALLREDUCE           mppsum_a_realdd 
    1791 #     include "mpp_allreduce_generic.h90" 
    1792 #     undef ROUTINE_ALLREDUCE 
    1793 #  undef DIM_1d 
    1794 #  undef COMPLEX_TYPE 
    1795 #  undef OPERATION_SUM_DD 
    1796  
    1797    !!---------------------------------------------------------------------- 
    1798    !!    ***  mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d 
    1799    !!    
    1800    !!---------------------------------------------------------------------- 
    1801    !! 
    1802 #  define OPERATION_MINLOC 
    1803 #  define DIM_2d 
    1804 #     define ROUTINE_LOC           mpp_minloc2d 
    1805 #     include "mpp_loc_generic.h90" 
    1806 #     undef ROUTINE_LOC 
    1807 #  undef DIM_2d 
    1808 #  define DIM_3d 
    1809 #     define ROUTINE_LOC           mpp_minloc3d 
    1810 #     include "mpp_loc_generic.h90" 
    1811 #     undef ROUTINE_LOC 
    1812 #  undef DIM_3d 
    1813 #  undef OPERATION_MINLOC 
    1814  
    1815 #  define OPERATION_MAXLOC 
    1816 #  define DIM_2d 
    1817 #     define ROUTINE_LOC           mpp_maxloc2d 
    1818 #     include "mpp_loc_generic.h90" 
    1819 #     undef ROUTINE_LOC 
    1820 #  undef DIM_2d 
    1821 #  define DIM_3d 
    1822 #     define ROUTINE_LOC           mpp_maxloc3d 
    1823 #     include "mpp_loc_generic.h90" 
    1824 #     undef ROUTINE_LOC 
    1825 #  undef DIM_3d 
    1826 #  undef OPERATION_MAXLOC 
    1827  
    1828    SUBROUTINE mpp_delay_sum( cdname, cdelay, y_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       COMPLEX(wp),      INTENT(in   ), DIMENSION(:) ::   y_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(:) = REAL(y_in(:), wp) 
    1837    END SUBROUTINE mpp_delay_sum 
    1838  
    1839    SUBROUTINE mpp_delay_max( cdname, cdelay, p_in, pout, ldlast, kcom ) 
    1840       CHARACTER(len=*), INTENT(in   )               ::   cdname  ! name of the calling subroutine 
    1841       CHARACTER(len=*), INTENT(in   )               ::   cdelay  ! name (used as id) of the delayed operation 
    1842       REAL(wp),         INTENT(in   ), DIMENSION(:) ::   p_in 
    1843       REAL(wp),         INTENT(  out), DIMENSION(:) ::   pout 
    1844       LOGICAL,          INTENT(in   )               ::   ldlast  ! true if this is the last time we call this routine 
    1845       INTEGER,          INTENT(in   ), OPTIONAL     ::   kcom 
    1846       ! 
    1847       pout(:) = p_in(:) 
    1848    END SUBROUTINE mpp_delay_max 
    1849  
    1850    SUBROUTINE mpp_delay_rcv( kid ) 
    1851       INTEGER,INTENT(in   )      ::  kid  
    1852       WRITE(*,*) 'mpp_delay_rcv: You should not have seen this print! error?', kid 
    1853    END SUBROUTINE mpp_delay_rcv 
    1854     
    1855    SUBROUTINE mppstop( ldfinal, ld_force_abort ) 
    1856       LOGICAL, OPTIONAL, INTENT(in) :: ldfinal    ! source process number 
    1857       LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort    ! source process number 
    1858       STOP      ! non MPP case, just stop the run 
    1859    END SUBROUTINE mppstop 
    1860  
    1861    SUBROUTINE mpp_ini_znl( knum ) 
    1862       INTEGER :: knum 
    1863       WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum 
    1864    END SUBROUTINE mpp_ini_znl 
    1865  
    1866    SUBROUTINE mpp_comm_free( kcom ) 
    1867       INTEGER :: kcom 
    1868       WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom 
    1869    END SUBROUTINE mpp_comm_free 
    1870     
    1871 #endif 
    1872  
    1873    !!---------------------------------------------------------------------- 
    1874    !!   All cases:         ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam   routines 
     1063   FUNCTION MPI_Wtime() 
     1064      REAL(wp) ::  MPI_Wtime 
     1065      MPI_Wtime = -1. 
     1066   END FUNCTION MPI_Wtime 
     1067#endif 
     1068 
     1069   !!---------------------------------------------------------------------- 
     1070   !!   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam   routines 
    18751071   !!---------------------------------------------------------------------- 
    18761072 
     
    18831079      !!                increment the error number (nstop) by one. 
    18841080      !!---------------------------------------------------------------------- 
    1885       CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5 
    1886       CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10 
     1081      CHARACTER(len=*), INTENT(in   )           ::   cd1 
     1082      CHARACTER(len=*), INTENT(in   ), OPTIONAL ::        cd2, cd3, cd4, cd5 
     1083      CHARACTER(len=*), INTENT(in   ), OPTIONAL ::   cd6, cd7, cd8, cd9, cd10 
    18871084      !!---------------------------------------------------------------------- 
    18881085      ! 
    18891086      nstop = nstop + 1 
    1890  
    1891       ! force to open ocean.output file 
     1087      ! 
     1088      ! force to open ocean.output file if not already opened 
    18921089      IF( numout == 6 ) CALL ctl_opn( numout, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 
    1893         
    1894       WRITE(numout,cform_err) 
    1895       IF( PRESENT(cd1 ) )   WRITE(numout,*) TRIM(cd1) 
     1090      ! 
     1091                            WRITE(numout,*) 
     1092                            WRITE(numout,*) ' ===>>> : E R R O R' 
     1093                            WRITE(numout,*) 
     1094                            WRITE(numout,*) '         ===========' 
     1095                            WRITE(numout,*) 
     1096                            WRITE(numout,*) TRIM(cd1) 
    18961097      IF( PRESENT(cd2 ) )   WRITE(numout,*) TRIM(cd2) 
    18971098      IF( PRESENT(cd3 ) )   WRITE(numout,*) TRIM(cd3) 
     
    19031104      IF( PRESENT(cd9 ) )   WRITE(numout,*) TRIM(cd9) 
    19041105      IF( PRESENT(cd10) )   WRITE(numout,*) TRIM(cd10) 
    1905  
     1106                            WRITE(numout,*) 
     1107      ! 
    19061108                               CALL FLUSH(numout    ) 
    19071109      IF( numstp     /= -1 )   CALL FLUSH(numstp    ) 
     
    19101112      ! 
    19111113      IF( cd1 == 'STOP' ) THEN 
     1114         WRITE(numout,*)   
    19121115         WRITE(numout,*)  'huge E-R-R-O-R : immediate stop' 
    1913          CALL mppstop(ld_force_abort = .true.) 
     1116         WRITE(numout,*)   
     1117         CALL mppstop( ld_abort = .true. ) 
    19141118      ENDIF 
    19151119      ! 
     
    19301134      ! 
    19311135      nwarn = nwarn + 1 
     1136      ! 
    19321137      IF(lwp) THEN 
    1933          WRITE(numout,cform_war) 
    1934          IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 
    1935          IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 
    1936          IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) 
    1937          IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) 
    1938          IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) 
    1939          IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) 
    1940          IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) 
    1941          IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) 
    1942          IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 
    1943          IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 
     1138                               WRITE(numout,*) 
     1139                               WRITE(numout,*) ' ===>>> : W A R N I N G' 
     1140                               WRITE(numout,*) 
     1141                               WRITE(numout,*) '         ===============' 
     1142                               WRITE(numout,*) 
     1143         IF( PRESENT(cd1 ) )   WRITE(numout,*) TRIM(cd1) 
     1144         IF( PRESENT(cd2 ) )   WRITE(numout,*) TRIM(cd2) 
     1145         IF( PRESENT(cd3 ) )   WRITE(numout,*) TRIM(cd3) 
     1146         IF( PRESENT(cd4 ) )   WRITE(numout,*) TRIM(cd4) 
     1147         IF( PRESENT(cd5 ) )   WRITE(numout,*) TRIM(cd5) 
     1148         IF( PRESENT(cd6 ) )   WRITE(numout,*) TRIM(cd6) 
     1149         IF( PRESENT(cd7 ) )   WRITE(numout,*) TRIM(cd7) 
     1150         IF( PRESENT(cd8 ) )   WRITE(numout,*) TRIM(cd8) 
     1151         IF( PRESENT(cd9 ) )   WRITE(numout,*) TRIM(cd9) 
     1152         IF( PRESENT(cd10) )   WRITE(numout,*) TRIM(cd10) 
     1153                               WRITE(numout,*) 
    19441154      ENDIF 
    19451155      CALL FLUSH(numout) 
     
    19841194      IF( TRIM(cdfile) == '/dev/null' )   clfile = TRIM(cdfile)   ! force the use of /dev/null 
    19851195      ! 
    1986       iost=0 
    1987       IF( cdacce(1:6) == 'DIRECT' )  THEN         ! cdacce has always more than 6 characters 
     1196      IF(       cdacce(1:6) == 'DIRECT' )  THEN   ! cdacce has always more than 6 characters 
    19881197         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh         , ERR=100, IOSTAT=iost ) 
    19891198      ELSE IF( TRIM(cdstat) == 'APPEND' )  THEN   ! cdstat can have less than 6 characters 
     
    20061215100   CONTINUE 
    20071216      IF( iost /= 0 ) THEN 
    2008          IF(ldwp) THEN 
    2009             WRITE(kout,*) 
    2010             WRITE(kout,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 
    2011             WRITE(kout,*) ' =======   ===  ' 
    2012             WRITE(kout,*) '           unit   = ', knum 
    2013             WRITE(kout,*) '           status = ', cdstat 
    2014             WRITE(kout,*) '           form   = ', cdform 
    2015             WRITE(kout,*) '           access = ', cdacce 
    2016             WRITE(kout,*) '           iostat = ', iost 
    2017             WRITE(kout,*) '           we stop. verify the file ' 
    2018             WRITE(kout,*) 
    2019          ELSE  !!! Force writing to make sure we get the information - at least once - in this violent STOP!! 
    2020             WRITE(*,*) 
    2021             WRITE(*,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 
    2022             WRITE(*,*) ' =======   ===  ' 
    2023             WRITE(*,*) '           unit   = ', knum 
    2024             WRITE(*,*) '           status = ', cdstat 
    2025             WRITE(*,*) '           form   = ', cdform 
    2026             WRITE(*,*) '           access = ', cdacce 
    2027             WRITE(*,*) '           iostat = ', iost 
    2028             WRITE(*,*) '           we stop. verify the file ' 
    2029             WRITE(*,*) 
    2030          ENDIF 
    2031          CALL FLUSH( kout )  
    2032          STOP 'ctl_opn bad opening' 
     1217         WRITE(ctmp1,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 
     1218         WRITE(ctmp2,*) ' =======   ===  ' 
     1219         WRITE(ctmp3,*) '           unit   = ', knum 
     1220         WRITE(ctmp4,*) '           status = ', cdstat 
     1221         WRITE(ctmp5,*) '           form   = ', cdform 
     1222         WRITE(ctmp6,*) '           access = ', cdacce 
     1223         WRITE(ctmp7,*) '           iostat = ', iost 
     1224         WRITE(ctmp8,*) '           we stop. verify the file ' 
     1225         CALL ctl_stop( 'STOP', ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 ) 
    20331226      ENDIF 
    20341227      ! 
     
    20361229 
    20371230 
    2038    SUBROUTINE ctl_nam ( kios, cdnam, ldwp ) 
     1231   SUBROUTINE ctl_nam ( kios, cdnam ) 
    20391232      !!---------------------------------------------------------------------- 
    20401233      !!                  ***  ROUTINE ctl_nam  *** 
     
    20441237      !! ** Method  :   Fortan open 
    20451238      !!---------------------------------------------------------------------- 
    2046       INTEGER         , INTENT(inout) ::   kios    ! IO status after reading the namelist 
    2047       CHARACTER(len=*), INTENT(in   ) ::   cdnam   ! group name of namelist for which error occurs 
    2048       CHARACTER(len=5)                ::   clios   ! string to convert iostat in character for print 
    2049       LOGICAL         , INTENT(in   ) ::   ldwp    ! boolean term for print 
     1239      INTEGER                                , INTENT(inout) ::   kios    ! IO status after reading the namelist 
     1240      CHARACTER(len=*)                       , INTENT(in   ) ::   cdnam   ! group name of namelist for which error occurs 
     1241      ! 
     1242      CHARACTER(len=5) ::   clios   ! string to convert iostat in character for print 
    20501243      !!---------------------------------------------------------------------- 
    20511244      ! 
     
    20611254      ENDIF 
    20621255      kios = 0 
    2063       RETURN 
    20641256      ! 
    20651257   END SUBROUTINE ctl_nam 
     
    20821274      END DO 
    20831275      IF( (get_unit == 999) .AND. llopn ) THEN 
    2084          CALL ctl_stop( 'get_unit: All logical units until 999 are used...' ) 
    2085          get_unit = -1 
     1276         CALL ctl_stop( 'STOP', 'get_unit: All logical units until 999 are used...' ) 
    20861277      ENDIF 
    20871278      ! 
  • NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC/mpp_lnk_generic.h90

    r10542 r11692  
    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_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC/mpp_nfd_generic.h90

    r10440 r11692  
    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_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC/mppini.F90

    r11242 r11692  
    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          
     
    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.