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

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

Ignore:
Timestamp:
2019-10-25T16:27:34+02:00 (4 years ago)
Author:
mocavero
Message:

Update the branch to v4.0.1 of the trunk

File:
1 edited

Legend:

Unmodified
Added
Removed
  • NEMO/branches/2019/dev_r11470_HPC_12_mpi3/src/OCE/LBC/lib_mpp.F90

    r10982 r11799  
    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      ! 
Note: See TracChangeset for help on using the changeset viewer.