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 11192 for NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/LBC/lib_mpp.F90 – NEMO

Ignore:
Timestamp:
2019-06-27T12:40:32+02:00 (5 years ago)
Author:
smasson
Message:

dev_r10984_HPC-13 : reorganization of lbclnk, part 1: simpler mpp_lnk_generic.h90 supress lbc_lnk_generic.h90, see #2285

File:
1 edited

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/LBC/lib_mpp.F90

    r11067 r11192  
    3434   !!   get_unit      : give the index of an unused logical unit 
    3535   !!---------------------------------------------------------------------- 
    36 #if   defined key_mpp_mpi 
    37    !!---------------------------------------------------------------------- 
    38    !!   'key_mpp_mpi'             MPI massively parallel processing library 
    39    !!---------------------------------------------------------------------- 
    40    !!   lib_mpp_alloc : allocate mpp arrays 
     36   !!---------------------------------------------------------------------- 
    4137   !!   mynode        : indentify the processor unit 
    4238   !!   mpp_lnk       : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 
    … …  
    5753   !!---------------------------------------------------------------------- 
    5854   USE dom_oce        ! ocean space and time domain 
    59    USE lbcnfd         ! north fold treatment 
    6055   USE in_out_manager ! I/O manager 
    6156 
    6257   IMPLICIT NONE 
    6358   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 
    73    PUBLIC   mpp_lnk_bdy_2d    , mpp_lnk_bdy_3d    , mpp_lnk_bdy_4d 
    74    PUBLIC   mpp_lnk_bdy_2d_ptr, mpp_lnk_bdy_3d_ptr, mpp_lnk_bdy_4d_ptr 
    75    ! 
    76 !!gm  this should be useless 
    77    PUBLIC   mpp_nfd_2d    , mpp_nfd_3d    , mpp_nfd_4d 
    78    PUBLIC   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 
    79 !!gm end 
    8059   ! 
    8160   PUBLIC   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 
    8261   PUBLIC   mynode, mppstop, mppsync, mpp_comm_free 
    8362   PUBLIC   mpp_ini_north 
    84    PUBLIC   mpp_lnk_2d_icb 
    85    PUBLIC   mpp_lbc_north_icb 
    8663   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
    8764   PUBLIC   mpp_delay_max, mpp_delay_sum, mpp_delay_rcv 
    … …  
    8966   PUBLIC   mpp_ini_znl 
    9067   PUBLIC   mppsend, mpprecv                          ! needed by TAM and ICB routines 
     68   PUBLIC   mpp_report 
     69   PUBLIC   tic_tac 
    9170    
    9271   !! * Interfaces 
    … …  
    11493   !!  MPI  variable definition !! 
    11594   !! ========================= !! 
     95#if   defined key_mpp_mpi 
    11696!$AGRIF_DO_NOT_TREAT 
    11797   INCLUDE 'mpif.h' 
    11898!$AGRIF_END_DO_NOT_TREAT 
    119  
    12099   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .TRUE.    !: mpp flag 
     100#else    
     101   INTEGER, PUBLIC, PARAMETER ::   MPI_STATUS_SIZE = 1 
     102   INTEGER, PUBLIC, PARAMETER ::   MPI_DOUBLE_PRECISION = 8 
     103   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.    !: mpp flag 
     104#endif 
    121105 
    122106   INTEGER, PARAMETER         ::   nprocmax = 2**10   ! maximun dimension (required to be a power of 2) 
    … …  
    189173   LOGICAL, PUBLIC ::   l_north_nogather = .FALSE.  !: internal control of northfold comms 
    190174 
     175   INTEGER, PUBLIC, PARAMETER ::   jpfillnothing = 1 
     176   INTEGER, PUBLIC, PARAMETER ::   jpfillcst     = 2 
     177   INTEGER, PUBLIC, PARAMETER ::   jpfillcopy    = 3 
     178   INTEGER, PUBLIC, PARAMETER ::   jpfillperio   = 4 
     179   INTEGER, PUBLIC, PARAMETER ::   jpfillmpi     = 5 
     180    
    191181   !!---------------------------------------------------------------------- 
    192182   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    215205      NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, ln_nnogather 
    216206      !!---------------------------------------------------------------------- 
     207#if defined key_mpp_mpi 
    217208      ! 
    218209      ii = 1 
    … …  
    311302      ENDIF 
    312303 
    313 #if defined key_agrif 
     304# if defined key_agrif 
    314305      IF( Agrif_Root() ) THEN 
    315306         CALL Agrif_MPI_Init(mpi_comm_oce) 
    … …  
    317308         CALL Agrif_MPI_set_grid_comm(mpi_comm_oce) 
    318309      ENDIF 
    319 #endif 
     310# endif 
    320311 
    321312      CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr ) 
    … …  
    330321      CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) 
    331322      ! 
     323#else 
     324      IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 
     325      mynode = 0 
     326      CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
     327#endif 
    332328   END FUNCTION mynode 
    333  
    334    !!---------------------------------------------------------------------- 
    335    !!                   ***  routine mpp_lnk_(2,3,4)d  *** 
    336    !! 
    337    !!   * Argument : dummy argument use in mpp_lnk_... routines 
    338    !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
    339    !!                cd_nat :   nature of array grid-points 
    340    !!                psgn   :   sign used across the north fold boundary 
    341    !!                kfld   :   optional, number of pt3d arrays 
    342    !!                cd_mpp :   optional, fill the overlap area only 
    343    !!                pval   :   optional, background value (used at closed boundaries) 
    344    !!---------------------------------------------------------------------- 
    345    ! 
    346    !                       !==  2D array and array of 2D pointer  ==! 
    347    ! 
    348 #  define DIM_2d 
    349 #     define ROUTINE_LNK           mpp_lnk_2d 
    350 #     include "mpp_lnk_generic.h90" 
    351 #     undef ROUTINE_LNK 
    352 #     define MULTI 
    353 #     define ROUTINE_LNK           mpp_lnk_2d_ptr 
    354 #     include "mpp_lnk_generic.h90" 
    355 #     undef ROUTINE_LNK 
    356 #     undef MULTI 
    357 #  undef DIM_2d 
    358    ! 
    359    !                       !==  3D array and array of 3D pointer  ==! 
    360    ! 
    361 #  define DIM_3d 
    362 #     define ROUTINE_LNK           mpp_lnk_3d 
    363 #     include "mpp_lnk_generic.h90" 
    364 #     undef ROUTINE_LNK 
    365 #     define MULTI 
    366 #     define ROUTINE_LNK           mpp_lnk_3d_ptr 
    367 #     include "mpp_lnk_generic.h90" 
    368 #     undef ROUTINE_LNK 
    369 #     undef MULTI 
    370 #  undef DIM_3d 
    371    ! 
    372    !                       !==  4D array and array of 4D pointer  ==! 
    373    ! 
    374 #  define DIM_4d 
    375 #     define ROUTINE_LNK           mpp_lnk_4d 
    376 #     include "mpp_lnk_generic.h90" 
    377 #     undef ROUTINE_LNK 
    378 #     define MULTI 
    379 #     define ROUTINE_LNK           mpp_lnk_4d_ptr 
    380 #     include "mpp_lnk_generic.h90" 
    381 #     undef ROUTINE_LNK 
    382 #     undef MULTI 
    383 #  undef DIM_4d 
    384  
    385    !!---------------------------------------------------------------------- 
    386    !!                   ***  routine mpp_nfd_(2,3,4)d  *** 
    387    !! 
    388    !!   * Argument : dummy argument use in mpp_nfd_... routines 
    389    !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
    390    !!                cd_nat :   nature of array grid-points 
    391    !!                psgn   :   sign used across the north fold boundary 
    392    !!                kfld   :   optional, number of pt3d arrays 
    393    !!                cd_mpp :   optional, fill the overlap area only 
    394    !!                pval   :   optional, background value (used at closed boundaries) 
    395    !!---------------------------------------------------------------------- 
    396    ! 
    397    !                       !==  2D array and array of 2D pointer  ==! 
    398    ! 
    399 #  define DIM_2d 
    400 #     define ROUTINE_NFD           mpp_nfd_2d 
    401 #     include "mpp_nfd_generic.h90" 
    402 #     undef ROUTINE_NFD 
    403 #     define MULTI 
    404 #     define ROUTINE_NFD           mpp_nfd_2d_ptr 
    405 #     include "mpp_nfd_generic.h90" 
    406 #     undef ROUTINE_NFD 
    407 #     undef MULTI 
    408 #  undef DIM_2d 
    409    ! 
    410    !                       !==  3D array and array of 3D pointer  ==! 
    411    ! 
    412 #  define DIM_3d 
    413 #     define ROUTINE_NFD           mpp_nfd_3d 
    414 #     include "mpp_nfd_generic.h90" 
    415 #     undef ROUTINE_NFD 
    416 #     define MULTI 
    417 #     define ROUTINE_NFD           mpp_nfd_3d_ptr 
    418 #     include "mpp_nfd_generic.h90" 
    419 #     undef ROUTINE_NFD 
    420 #     undef MULTI 
    421 #  undef DIM_3d 
    422    ! 
    423    !                       !==  4D array and array of 4D pointer  ==! 
    424    ! 
    425 #  define DIM_4d 
    426 #     define ROUTINE_NFD           mpp_nfd_4d 
    427 #     include "mpp_nfd_generic.h90" 
    428 #     undef ROUTINE_NFD 
    429 #     define MULTI 
    430 #     define ROUTINE_NFD           mpp_nfd_4d_ptr 
    431 #     include "mpp_nfd_generic.h90" 
    432 #     undef ROUTINE_NFD 
    433 #     undef MULTI 
    434 #  undef DIM_4d 
    435  
    436  
    437    !!---------------------------------------------------------------------- 
    438    !!                   ***  routine mpp_lnk_bdy_(2,3,4)d  *** 
    439    !! 
    440    !!   * Argument : dummy argument use in mpp_lnk_... routines 
    441    !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
    442    !!                cd_nat :   nature of array grid-points 
    443    !!                psgn   :   sign used across the north fold boundary 
    444    !!                kb_bdy :   BDY boundary set 
    445    !!                kfld   :   optional, number of pt3d arrays 
    446    !!---------------------------------------------------------------------- 
    447    ! 
    448    !                       !==  2D array and array of 2D pointer  ==! 
    449    ! 
    450 #  define DIM_2d 
    451 #     define ROUTINE_BDY           mpp_lnk_bdy_2d 
    452 #     include "mpp_bdy_generic.h90" 
    453 #     undef ROUTINE_BDY 
    454 #     define MULTI 
    455 #     define ROUTINE_BDY           mpp_lnk_bdy_2d_ptr 
    456 #     include "mpp_bdy_generic.h90" 
    457 #     undef ROUTINE_BDY 
    458 #     undef MULTI 
    459 #  undef DIM_2d 
    460    ! 
    461    !                       !==  3D array and array of 3D pointer  ==! 
    462    ! 
    463 #  define DIM_3d 
    464 #     define ROUTINE_BDY           mpp_lnk_bdy_3d 
    465 #     include "mpp_bdy_generic.h90" 
    466 #     undef ROUTINE_BDY 
    467 #     define MULTI 
    468 #     define ROUTINE_BDY           mpp_lnk_bdy_3d_ptr 
    469 #     include "mpp_bdy_generic.h90" 
    470 #     undef ROUTINE_BDY 
    471 #     undef MULTI 
    472 #  undef DIM_3d 
    473    ! 
    474    !                       !==  4D array and array of 4D pointer  ==! 
    475    ! 
    476 #  define DIM_4d 
    477 #     define ROUTINE_BDY           mpp_lnk_bdy_4d 
    478 #     include "mpp_bdy_generic.h90" 
    479 #     undef ROUTINE_BDY 
    480 #     define MULTI 
    481 #     define ROUTINE_BDY           mpp_lnk_bdy_4d_ptr 
    482 #     include "mpp_bdy_generic.h90" 
    483 #     undef ROUTINE_BDY 
    484 #     undef MULTI 
    485 #  undef DIM_4d 
    486  
    487    !!---------------------------------------------------------------------- 
    488    !! 
    489    !!   load_array  &   mpp_lnk_2d_9    à generaliser a 3D et 4D 
    490     
    491     
    492    !!    mpp_lnk_sum_2d et 3D   ====>>>>>>   à virer du code !!!! 
    493     
    494     
    495    !!---------------------------------------------------------------------- 
    496  
    497329 
    498330 
    … …  
    513345      !!---------------------------------------------------------------------- 
    514346      ! 
     347#if defined key_mpp_mpi 
    515348      SELECT CASE ( cn_mpi_send ) 
    516349      CASE ( 'S' )                ! Standard mpi send (blocking) 
    … …  
    522355         CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
    523356      END SELECT 
     357#endif 
    524358      ! 
    525359   END SUBROUTINE mppsend 
    … …  
    543377      !!---------------------------------------------------------------------- 
    544378      ! 
     379#if defined key_mpp_mpi 
    545380      ! If a specific process number has been passed to the receive call, 
    546381      ! use that one. Default is to use mpi_any_source 
    … …  
    549384      ! 
    550385      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 
     386#endif 
    551387      ! 
    552388   END SUBROUTINE mpprecv 
    … …  
    569405      ! 
    570406      itaille = jpi * jpj 
     407#if defined key_mpp_mpi 
    571408      CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille     ,   & 
    572409         &                            mpi_double_precision, kp , mpi_comm_oce, ierror ) 
     410#else 
     411      pio(:,:,1) = ptab(:,:) 
     412#endif 
    573413      ! 
    574414   END SUBROUTINE mppgather 
    … …  
    592432      itaille = jpi * jpj 
    593433      ! 
     434#if defined key_mpp_mpi 
    594435      CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille     ,   & 
    595436         &                            mpi_double_precision, kp  , mpi_comm_oce, ierror ) 
     437#else 
     438      ptab(:,:) = pio(:,:,1) 
     439#endif 
    596440      ! 
    597441   END SUBROUTINE mppscatter 
    … …  
    617461      COMPLEX(wp), ALLOCATABLE, DIMENSION(:) ::   ytmp 
    618462      !!---------------------------------------------------------------------- 
     463#if defined key_mpp_mpi 
    619464      ilocalcomm = mpi_comm_oce 
    620465      IF( PRESENT(kcom) )   ilocalcomm = kcom 
    … …  
    655500 
    656501      ! send y_in into todelay(idvar)%y1d with a non-blocking communication 
    657 #if defined key_mpi2 
     502# if defined key_mpi2 
    658503      IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 
    659504      CALL  mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 
    660505      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
     506# else 
     507      CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 
     508# endif 
    661509#else 
    662       CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 
     510      pout(:) = REAL(y_in(:), wp) 
    663511#endif 
    664512 
    … …  
    684532      INTEGER ::   ierr, ilocalcomm 
    685533      !!---------------------------------------------------------------------- 
     534#if defined key_mpp_mpi 
    686535      ilocalcomm = mpi_comm_oce 
    687536      IF( PRESENT(kcom) )   ilocalcomm = kcom 
    … …  
    718567 
    719568      ! send p_in into todelay(idvar)%z1d with a non-blocking communication 
    720 #if defined key_mpi2 
     569# if defined key_mpi2 
    721570      IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 
    722571      CALL  mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
    723572      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
     573# else 
     574      CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
     575# endif 
    724576#else 
    725       CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
     577      pout(:) = p_in(:) 
    726578#endif 
    727579 
    … …  
    739591      INTEGER ::   ierr 
    740592      !!---------------------------------------------------------------------- 
     593#if defined key_mpp_mpi 
    741594      IF( ndelayid(kid) /= -2 ) THEN   
    742595#if ! defined key_mpi2 
    … …  
    748601         ndelayid(kid) = -2   ! add flag to know that mpi_wait was already called on kid 
    749602      ENDIF 
     603#endif 
    750604   END SUBROUTINE mpp_delay_rcv 
    751605 
    … …  
    906760      !!----------------------------------------------------------------------- 
    907761      ! 
     762#if defined key_mpp_mpi 
    908763      CALL mpi_barrier( mpi_comm_oce, ierror ) 
     764#endif 
    909765      ! 
    910766   END SUBROUTINE mppsync 
    … …  
    928784      IF( PRESENT(ld_force_abort) ) ll_force_abort = ld_force_abort 
    929785      ! 
     786#if defined key_mpp_mpi 
    930787      IF(ll_force_abort) THEN 
    931788         CALL mpi_abort( MPI_COMM_WORLD ) 
    … …  
    934791         CALL mpi_finalize( info ) 
    935792      ENDIF 
     793#endif 
    936794      IF( .NOT. llfinal ) STOP 123 
    937795      ! 
    … …  
    946804      !!---------------------------------------------------------------------- 
    947805      ! 
     806#if defined key_mpp_mpi 
    948807      CALL MPI_COMM_FREE(kcom, ierr) 
     808#endif 
    949809      ! 
    950810   END SUBROUTINE mpp_comm_free 
    … …  
    976836      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kwork 
    977837      !!---------------------------------------------------------------------- 
     838#if defined key_mpp_mpi 
    978839      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world     : ', ngrp_world 
    979840      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world 
    … …  
    1047908 
    1048909      DEALLOCATE(kwork) 
     910#endif 
    1049911 
    1050912   END SUBROUTINE mpp_ini_znl 
    … …  
    1078940      !!---------------------------------------------------------------------- 
    1079941      ! 
     942#if defined key_mpp_mpi 
    1080943      njmppmax = MAXVAL( njmppt ) 
    1081944      ! 
    … …  
    1109972      CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr ) 
    1110973      ! 
     974#endif 
    1111975   END SUBROUTINE mpp_ini_north 
    1112976 
    … …  
    1130994      LOGICAL                                      ::   mpi_was_called 
    1131995      !!--------------------------------------------------------------------- 
     996#if defined key_mpp_mpi 
    1132997      ! 
    1133998      CALL mpi_initialized( mpi_was_called, code )      ! MPI initialization 
    … …  
    11691034      ENDIF 
    11701035      ! 
     1036#endif 
    11711037   END SUBROUTINE mpi_init_oce 
    11721038 
    … …  
    12031069 
    12041070 
    1205    SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 
    1206       !!--------------------------------------------------------------------- 
    1207       !!                   ***  routine mpp_lbc_north_icb  *** 
    1208       !! 
    1209       !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    1210       !!              in mpp configuration in case of jpn1 > 1 and for 2d 
    1211       !!              array with outer extra halo 
    1212       !! 
    1213       !! ** Method  :   North fold condition and mpp with more than one proc 
    1214       !!              in i-direction require a specific treatment. We gather 
    1215       !!              the 4+kextj northern lines of the global domain on 1 
    1216       !!              processor and apply lbc north-fold on this sub array. 
    1217       !!              Then we scatter the north fold array back to the processors. 
    1218       !!              This routine accounts for an extra halo with icebergs 
    1219       !!              and assumes ghost rows and columns have been suppressed. 
    1220       !! 
    1221       !!---------------------------------------------------------------------- 
    1222       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    1223       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points 
    1224       !                                                     !   = T ,  U , V , F or W -points 
    1225       REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
    1226       !!                                                    ! north fold, =  1. otherwise 
    1227       INTEGER                 , INTENT(in   ) ::   kextj    ! Extra halo width at north fold 
    1228       ! 
    1229       INTEGER ::   ji, jj, jr 
    1230       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    1231       INTEGER ::   ipj, ij, iproc 
    1232       ! 
    1233       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
    1234       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e 
    1235       !!---------------------------------------------------------------------- 
    1236       ! 
    1237       ipj=4 
    1238       ALLOCATE(        ztab_e(jpiglo, 1-kextj:ipj+kextj)       ,       & 
    1239      &            znorthloc_e(jpimax, 1-kextj:ipj+kextj)       ,       & 
    1240      &          znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni)    ) 
    1241       ! 
    1242       ztab_e(:,:)      = 0._wp 
    1243       znorthloc_e(:,:) = 0._wp 
    1244       ! 
    1245       ij = 1 - kextj 
    1246       ! put the last ipj+2*kextj lines of pt2d into znorthloc_e  
    1247       DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
    1248          znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 
    1249          ij = ij + 1 
    1250       END DO 
    1251       ! 
    1252       itaille = jpimax * ( ipj + 2*kextj ) 
    1253       ! 
    1254       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    1255       CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj)    , itaille, MPI_DOUBLE_PRECISION,    & 
    1256          &                znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION,    & 
    1257          &                ncomm_north, ierr ) 
    1258       ! 
    1259       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    1260       ! 
    1261       DO jr = 1, ndim_rank_north            ! recover the global north array 
    1262          iproc = nrank_north(jr) + 1 
    1263          ildi = nldit (iproc) 
    1264          ilei = nleit (iproc) 
    1265          iilb = nimppt(iproc) 
    1266          DO jj = 1-kextj, ipj+kextj 
    1267             DO ji = ildi, ilei 
    1268                ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 
    1269             END DO 
    1270          END DO 
    1271       END DO 
    1272  
    1273       ! 2. North-Fold boundary conditions 
    1274       ! ---------------------------------- 
    1275       CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) 
    1276  
    1277       ij = 1 - kextj 
    1278       !! Scatter back to pt2d 
    1279       DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
    1280          DO ji= 1, jpi 
    1281             pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 
    1282          END DO 
    1283          ij  = ij +1 
    1284       END DO 
    1285       ! 
    1286       DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 
    1287       ! 
    1288    END SUBROUTINE mpp_lbc_north_icb 
    1289  
    1290  
    1291    SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj ) 
    1292       !!---------------------------------------------------------------------- 
    1293       !!                  ***  routine mpp_lnk_2d_icb  *** 
    1294       !! 
    1295       !! ** Purpose :   Message passing management for 2d array (with extra halo for icebergs) 
    1296       !!                This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) 
    1297       !!                array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. 
    1298       !! 
    1299       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1300       !!      between processors following neighboring subdomains. 
    1301       !!            domain parameters 
    1302       !!                    jpi    : first dimension of the local subdomain 
    1303       !!                    jpj    : second dimension of the local subdomain 
    1304       !!                    kexti  : number of columns for extra outer halo 
    1305       !!                    kextj  : number of rows for extra outer halo 
    1306       !!                    nbondi : mark for "east-west local boundary" 
    1307       !!                    nbondj : mark for "north-south local boundary" 
    1308       !!                    noea   : number for local neighboring processors 
    1309       !!                    nowe   : number for local neighboring processors 
    1310       !!                    noso   : number for local neighboring processors 
    1311       !!                    nono   : number for local neighboring processors 
    1312       !!---------------------------------------------------------------------- 
    1313       CHARACTER(len=*)                                        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    1314       REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    1315       CHARACTER(len=1)                                        , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
    1316       REAL(wp)                                                , INTENT(in   ) ::   psgn     ! sign used across the north fold 
    1317       INTEGER                                                 , INTENT(in   ) ::   kexti    ! extra i-halo width 
    1318       INTEGER                                                 , INTENT(in   ) ::   kextj    ! extra j-halo width 
    1319       ! 
    1320       INTEGER  ::   jl   ! dummy loop indices 
    1321       INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    1322       INTEGER  ::   ipreci, iprecj             !   -       - 
    1323       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1324       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    1325       !! 
    1326       REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) ::   r2dns, r2dsn 
    1327       REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) ::   r2dwe, r2dew 
    1328       !!---------------------------------------------------------------------- 
    1329  
    1330       ipreci = nn_hls + kexti      ! take into account outer extra 2D overlap area 
    1331       iprecj = nn_hls + kextj 
    1332  
    1333       IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) 
    1334  
    1335       ! 1. standard boundary treatment 
    1336       ! ------------------------------ 
    1337       ! Order matters Here !!!! 
    1338       ! 
    1339       !                                      ! East-West boundaries 
    1340       !                                           !* Cyclic east-west 
    1341       IF( l_Iperio ) THEN 
    1342          pt2d(1-kexti:     1   ,:) = pt2d(jpim1-kexti: jpim1 ,:)       ! east 
    1343          pt2d(  jpi  :jpi+kexti,:) = pt2d(     2     :2+kexti,:)       ! west 
    1344          ! 
    1345       ELSE                                        !* closed 
    1346          IF( .NOT. cd_type == 'F' )   pt2d(  1-kexti   :nn_hls   ,:) = 0._wp    ! east except at F-point 
    1347                                       pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp    ! west 
    1348       ENDIF 
    1349       !                                      ! North-South boundaries 
    1350       IF( l_Jperio ) THEN                         !* cyclic (only with no mpp j-split) 
    1351          pt2d(:,1-kextj:     1   ) = pt2d(:,jpjm1-kextj:  jpjm1)       ! north 
    1352          pt2d(:,  jpj  :jpj+kextj) = pt2d(:,     2     :2+kextj)       ! south 
    1353       ELSE                                        !* closed 
    1354          IF( .NOT. cd_type == 'F' )   pt2d(:,  1-kextj   :nn_hls   ) = 0._wp    ! north except at F-point 
    1355                                       pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp    ! south 
    1356       ENDIF 
    1357       ! 
    1358  
    1359       ! north fold treatment 
    1360       ! ----------------------- 
    1361       IF( npolj /= 0 ) THEN 
    1362          ! 
    1363          SELECT CASE ( jpni ) 
    1364                    CASE ( 1 )     ;   CALL lbc_nfd          ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
    1365                    CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
    1366          END SELECT 
    1367          ! 
    1368       ENDIF 
    1369  
    1370       ! 2. East and west directions exchange 
    1371       ! ------------------------------------ 
    1372       ! we play with the neigbours AND the row number because of the periodicity 
    1373       ! 
    1374       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    1375       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1376          iihom = jpi-nreci-kexti 
    1377          DO jl = 1, ipreci 
    1378             r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 
    1379             r2dwe(:,jl,1) = pt2d(iihom +jl,:) 
    1380          END DO 
    1381       END SELECT 
    1382       ! 
    1383       !                           ! Migrations 
    1384       imigr = ipreci * ( jpj + 2*kextj ) 
    1385       ! 
    1386       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    1387       ! 
    1388       SELECT CASE ( nbondi ) 
    1389       CASE ( -1 ) 
    1390          CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 
    1391          CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
    1392          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1393       CASE ( 0 ) 
    1394          CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
    1395          CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 
    1396          CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
    1397          CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    1398          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1399          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1400       CASE ( 1 ) 
    1401          CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
    1402          CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    1403          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1404       END SELECT 
    1405       ! 
    1406       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    1407       ! 
    1408       !                           ! Write Dirichlet lateral conditions 
    1409       iihom = jpi - nn_hls 
    1410       ! 
    1411       SELECT CASE ( nbondi ) 
    1412       CASE ( -1 ) 
    1413          DO jl = 1, ipreci 
    1414             pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    1415          END DO 
    1416       CASE ( 0 ) 
    1417          DO jl = 1, ipreci 
    1418             pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
    1419             pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    1420          END DO 
    1421       CASE ( 1 ) 
    1422          DO jl = 1, ipreci 
    1423             pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
    1424          END DO 
    1425       END SELECT 
    1426  
    1427  
    1428       ! 3. North and south directions 
    1429       ! ----------------------------- 
    1430       ! always closed : we play only with the neigbours 
    1431       ! 
    1432       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    1433          ijhom = jpj-nrecj-kextj 
    1434          DO jl = 1, iprecj 
    1435             r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 
    1436             r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 
    1437          END DO 
    1438       ENDIF 
    1439       ! 
    1440       !                           ! Migrations 
    1441       imigr = iprecj * ( jpi + 2*kexti ) 
    1442       ! 
    1443       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    1444       ! 
    1445       SELECT CASE ( nbondj ) 
    1446       CASE ( -1 ) 
    1447          CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 
    1448          CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
    1449          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1450       CASE ( 0 ) 
    1451          CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
    1452          CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 
    1453          CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
    1454          CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    1455          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1456          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1457       CASE ( 1 ) 
    1458          CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
    1459          CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    1460          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1461       END SELECT 
    1462       ! 
    1463       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    1464       ! 
    1465       !                           ! Write Dirichlet lateral conditions 
    1466       ijhom = jpj - nn_hls 
    1467       ! 
    1468       SELECT CASE ( nbondj ) 
    1469       CASE ( -1 ) 
    1470          DO jl = 1, iprecj 
    1471             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    1472          END DO 
    1473       CASE ( 0 ) 
    1474          DO jl = 1, iprecj 
    1475             pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
    1476             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    1477          END DO 
    1478       CASE ( 1 ) 
    1479          DO jl = 1, iprecj 
    1480             pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
    1481          END DO 
    1482       END SELECT 
    1483       ! 
    1484    END SUBROUTINE mpp_lnk_2d_icb 
    1485  
    1486  
    14871071   SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb, ld_dlg ) 
    14881072      !!---------------------------------------------------------------------- 
    … …  
    15001084      INTEGER ::    ji,  jj,  jk,  jh, jf, jcount   ! dummy loop indices 
    15011085      !!---------------------------------------------------------------------- 
     1086#if defined key_mpp_mpi 
    15021087      ! 
    15031088      ll_lbc = .FALSE. 
    … …  
    16101195         DEALLOCATE(crname_lbc) 
    16111196      ENDIF 
     1197#endif 
    16121198   END SUBROUTINE mpp_report 
    16131199 
    … …  
    16201206    REAL(wp),               SAVE :: tic_ct = 0._wp 
    16211207    INTEGER :: ii 
     1208#if defined key_mpp_mpi 
    16221209 
    16231210    IF( ncom_stp <= nit000 ) RETURN 
    … …  
    16351222       tic_ct = MPI_Wtime()                                                        ! start count tac->tic (waiting time) 
    16361223    ENDIF 
     1224#endif 
    16371225     
    16381226   END SUBROUTINE tic_tac 
    16391227 
    1640     
    1641 #else 
    1642    !!---------------------------------------------------------------------- 
    1643    !!   Default case:            Dummy module        share memory computing 
    1644    !!---------------------------------------------------------------------- 
    1645    USE in_out_manager 
    1646  
    1647    INTERFACE mpp_sum 
    1648       MODULE PROCEDURE mppsum_int, mppsum_a_int, mppsum_real, mppsum_a_real, mppsum_realdd, mppsum_a_realdd 
    1649    END INTERFACE 
    1650    INTERFACE mpp_max 
    1651       MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real 
    1652    END INTERFACE 
    1653    INTERFACE mpp_min 
    1654       MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 
    1655    END INTERFACE 
    1656    INTERFACE mpp_minloc 
    1657       MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 
    1658    END INTERFACE 
    1659    INTERFACE mpp_maxloc 
    1660       MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
    1661    END INTERFACE 
    1662  
    1663    LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag 
    1664    LOGICAL, PUBLIC            ::   ln_nnogather          !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 
    1665    INTEGER, PUBLIC            ::   mpi_comm_oce          ! opa local communicator 
    1666  
    1667    INTEGER, PARAMETER, PUBLIC               ::   nbdelay = 0   ! make sure we don't enter loops: DO ji = 1, nbdelay 
    1668    CHARACTER(len=32), DIMENSION(1), PUBLIC  ::   c_delaylist = 'empty' 
    1669    CHARACTER(len=32), DIMENSION(1), PUBLIC  ::   c_delaycpnt = 'empty' 
    1670    LOGICAL, PUBLIC                          ::   l_full_nf_update = .TRUE. 
    1671    TYPE ::   DELAYARR 
    1672       REAL(   wp), POINTER, DIMENSION(:) ::  z1d => NULL() 
    1673       COMPLEX(wp), POINTER, DIMENSION(:) ::  y1d => NULL() 
    1674    END TYPE DELAYARR 
    1675    TYPE( DELAYARR ), DIMENSION(1), PUBLIC  ::   todelay               
    1676    INTEGER,  PUBLIC, DIMENSION(1)           ::   ndelayid = -1 
    1677    !!---------------------------------------------------------------------- 
    1678 CONTAINS 
    1679  
    1680    INTEGER FUNCTION lib_mpp_alloc(kumout)          ! Dummy function 
    1681       INTEGER, INTENT(in) ::   kumout 
    1682       lib_mpp_alloc = 0 
    1683    END FUNCTION lib_mpp_alloc 
    1684  
    1685    FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg,  kumond , kstop, localComm ) RESULT (function_value) 
    1686       INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm 
    1687       CHARACTER(len=*),DIMENSION(:) ::   ldtxt 
    1688       CHARACTER(len=*) ::   ldname 
    1689       INTEGER ::   kumnam_ref, knumnam_cfg , kumond , kstop 
    1690       IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 
    1691       function_value = 0 
    1692       IF( .FALSE. )   ldtxt(:) = 'never done' 
    1693       CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
    1694    END FUNCTION mynode 
    1695  
    1696    SUBROUTINE mppsync                       ! Dummy routine 
    1697    END SUBROUTINE mppsync 
    1698  
    1699    !!---------------------------------------------------------------------- 
    1700    !!    ***  mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real  *** 
    1701    !!    
    1702    !!---------------------------------------------------------------------- 
    1703    !! 
    1704 #  define OPERATION_MAX 
    1705 #  define INTEGER_TYPE 
    1706 #  define DIM_0d 
    1707 #     define ROUTINE_ALLREDUCE           mppmax_int 
    1708 #     include "mpp_allreduce_generic.h90" 
    1709 #     undef ROUTINE_ALLREDUCE 
    1710 #  undef DIM_0d 
    1711 #  define DIM_1d 
    1712 #     define ROUTINE_ALLREDUCE           mppmax_a_int 
    1713 #     include "mpp_allreduce_generic.h90" 
    1714 #     undef ROUTINE_ALLREDUCE 
    1715 #  undef DIM_1d 
    1716 #  undef INTEGER_TYPE 
    1717 ! 
    1718 #  define REAL_TYPE 
    1719 #  define DIM_0d 
    1720 #     define ROUTINE_ALLREDUCE           mppmax_real 
    1721 #     include "mpp_allreduce_generic.h90" 
    1722 #     undef ROUTINE_ALLREDUCE 
    1723 #  undef DIM_0d 
    1724 #  define DIM_1d 
    1725 #     define ROUTINE_ALLREDUCE           mppmax_a_real 
    1726 #     include "mpp_allreduce_generic.h90" 
    1727 #     undef ROUTINE_ALLREDUCE 
    1728 #  undef DIM_1d 
    1729 #  undef REAL_TYPE 
    1730 #  undef OPERATION_MAX 
    1731    !!---------------------------------------------------------------------- 
    1732    !!    ***  mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real  *** 
    1733    !!    
    1734    !!---------------------------------------------------------------------- 
    1735    !! 
    1736 #  define OPERATION_MIN 
    1737 #  define INTEGER_TYPE 
    1738 #  define DIM_0d 
    1739 #     define ROUTINE_ALLREDUCE           mppmin_int 
    1740 #     include "mpp_allreduce_generic.h90" 
    1741 #     undef ROUTINE_ALLREDUCE 
    1742 #  undef DIM_0d 
    1743 #  define DIM_1d 
    1744 #     define ROUTINE_ALLREDUCE           mppmin_a_int 
    1745 #     include "mpp_allreduce_generic.h90" 
    1746 #     undef ROUTINE_ALLREDUCE 
    1747 #  undef DIM_1d 
    1748 #  undef INTEGER_TYPE 
    1749 ! 
    1750 #  define REAL_TYPE 
    1751 #  define DIM_0d 
    1752 #     define ROUTINE_ALLREDUCE           mppmin_real 
    1753 #     include "mpp_allreduce_generic.h90" 
    1754 #     undef ROUTINE_ALLREDUCE 
    1755 #  undef DIM_0d 
    1756 #  define DIM_1d 
    1757 #     define ROUTINE_ALLREDUCE           mppmin_a_real 
    1758 #     include "mpp_allreduce_generic.h90" 
    1759 #     undef ROUTINE_ALLREDUCE 
    1760 #  undef DIM_1d 
    1761 #  undef REAL_TYPE 
    1762 #  undef OPERATION_MIN 
    1763  
    1764    !!---------------------------------------------------------------------- 
    1765    !!    ***  mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real  *** 
    1766    !!    
    1767    !!   Global sum of 1D array or a variable (integer, real or complex) 
    1768    !!---------------------------------------------------------------------- 
    1769    !! 
    1770 #  define OPERATION_SUM 
    1771 #  define INTEGER_TYPE 
    1772 #  define DIM_0d 
    1773 #     define ROUTINE_ALLREDUCE           mppsum_int 
    1774 #     include "mpp_allreduce_generic.h90" 
    1775 #     undef ROUTINE_ALLREDUCE 
    1776 #  undef DIM_0d 
    1777 #  define DIM_1d 
    1778 #     define ROUTINE_ALLREDUCE           mppsum_a_int 
    1779 #     include "mpp_allreduce_generic.h90" 
    1780 #     undef ROUTINE_ALLREDUCE 
    1781 #  undef DIM_1d 
    1782 #  undef INTEGER_TYPE 
    1783 ! 
    1784 #  define REAL_TYPE 
    1785 #  define DIM_0d 
    1786 #     define ROUTINE_ALLREDUCE           mppsum_real 
    1787 #     include "mpp_allreduce_generic.h90" 
    1788 #     undef ROUTINE_ALLREDUCE 
    1789 #  undef DIM_0d 
    1790 #  define DIM_1d 
    1791 #     define ROUTINE_ALLREDUCE           mppsum_a_real 
    1792 #     include "mpp_allreduce_generic.h90" 
    1793 #     undef ROUTINE_ALLREDUCE 
    1794 #  undef DIM_1d 
    1795 #  undef REAL_TYPE 
    1796 #  undef OPERATION_SUM 
    1797  
    1798 #  define OPERATION_SUM_DD 
    1799 #  define COMPLEX_TYPE 
    1800 #  define DIM_0d 
    1801 #     define ROUTINE_ALLREDUCE           mppsum_realdd 
    1802 #     include "mpp_allreduce_generic.h90" 
    1803 #     undef ROUTINE_ALLREDUCE 
    1804 #  undef DIM_0d 
    1805 #  define DIM_1d 
    1806 #     define ROUTINE_ALLREDUCE           mppsum_a_realdd 
    1807 #     include "mpp_allreduce_generic.h90" 
    1808 #     undef ROUTINE_ALLREDUCE 
    1809 #  undef DIM_1d 
    1810 #  undef COMPLEX_TYPE 
    1811 #  undef OPERATION_SUM_DD 
    1812  
    1813    !!---------------------------------------------------------------------- 
    1814    !!    ***  mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d 
    1815    !!    
    1816    !!---------------------------------------------------------------------- 
    1817    !! 
    1818 #  define OPERATION_MINLOC 
    1819 #  define DIM_2d 
    1820 #     define ROUTINE_LOC           mpp_minloc2d 
    1821 #     include "mpp_loc_generic.h90" 
    1822 #     undef ROUTINE_LOC 
    1823 #  undef DIM_2d 
    1824 #  define DIM_3d 
    1825 #     define ROUTINE_LOC           mpp_minloc3d 
    1826 #     include "mpp_loc_generic.h90" 
    1827 #     undef ROUTINE_LOC 
    1828 #  undef DIM_3d 
    1829 #  undef OPERATION_MINLOC 
    1830  
    1831 #  define OPERATION_MAXLOC 
    1832 #  define DIM_2d 
    1833 #     define ROUTINE_LOC           mpp_maxloc2d 
    1834 #     include "mpp_loc_generic.h90" 
    1835 #     undef ROUTINE_LOC 
    1836 #  undef DIM_2d 
    1837 #  define DIM_3d 
    1838 #     define ROUTINE_LOC           mpp_maxloc3d 
    1839 #     include "mpp_loc_generic.h90" 
    1840 #     undef ROUTINE_LOC 
    1841 #  undef DIM_3d 
    1842 #  undef OPERATION_MAXLOC 
    1843  
    1844    SUBROUTINE mpp_delay_sum( cdname, cdelay, y_in, pout, ldlast, kcom ) 
    1845       CHARACTER(len=*), INTENT(in   )               ::   cdname  ! name of the calling subroutine 
    1846       CHARACTER(len=*), INTENT(in   )               ::   cdelay  ! name (used as id) of the delayed operation 
    1847       COMPLEX(wp),      INTENT(in   ), DIMENSION(:) ::   y_in 
    1848       REAL(wp),         INTENT(  out), DIMENSION(:) ::   pout 
    1849       LOGICAL,          INTENT(in   )               ::   ldlast  ! true if this is the last time we call this routine 
    1850       INTEGER,          INTENT(in   ), OPTIONAL     ::   kcom 
    1851       ! 
    1852       pout(:) = REAL(y_in(:), wp) 
    1853    END SUBROUTINE mpp_delay_sum 
    1854  
    1855    SUBROUTINE mpp_delay_max( cdname, cdelay, p_in, pout, ldlast, kcom ) 
    1856       CHARACTER(len=*), INTENT(in   )               ::   cdname  ! name of the calling subroutine 
    1857       CHARACTER(len=*), INTENT(in   )               ::   cdelay  ! name (used as id) of the delayed operation 
    1858       REAL(wp),         INTENT(in   ), DIMENSION(:) ::   p_in 
    1859       REAL(wp),         INTENT(  out), DIMENSION(:) ::   pout 
    1860       LOGICAL,          INTENT(in   )               ::   ldlast  ! true if this is the last time we call this routine 
    1861       INTEGER,          INTENT(in   ), OPTIONAL     ::   kcom 
    1862       ! 
    1863       pout(:) = p_in(:) 
    1864    END SUBROUTINE mpp_delay_max 
    1865  
    1866    SUBROUTINE mpp_delay_rcv( kid ) 
    1867       INTEGER,INTENT(in   )      ::  kid  
    1868       WRITE(*,*) 'mpp_delay_rcv: You should not have seen this print! error?', kid 
    1869    END SUBROUTINE mpp_delay_rcv 
    1870     
    1871    SUBROUTINE mppstop( ldfinal, ld_force_abort ) 
    1872       LOGICAL, OPTIONAL, INTENT(in) :: ldfinal    ! source process number 
    1873       LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort    ! source process number 
    1874       STOP      ! non MPP case, just stop the run 
    1875    END SUBROUTINE mppstop 
    1876  
    1877    SUBROUTINE mpp_ini_znl( knum ) 
    1878       INTEGER :: knum 
    1879       WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum 
    1880    END SUBROUTINE mpp_ini_znl 
    1881  
    1882    SUBROUTINE mpp_comm_free( kcom ) 
    1883       INTEGER :: kcom 
    1884       WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom 
    1885    END SUBROUTINE mpp_comm_free 
    1886     
    1887 #endif 
    1888  
    1889    !!---------------------------------------------------------------------- 
    1890    !!   All cases:         ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam   routines 
     1228#if ! defined key_mpp_mpi 
     1229   SUBROUTINE mpi_wait(request, status, ierror) 
     1230      INTEGER                            , INTENT(in   ) ::   request 
     1231      INTEGER, DIMENSION(MPI_STATUS_SIZE), INTENT(  out) ::   status 
     1232      INTEGER                            , INTENT(  out) ::   ierror 
     1233   END SUBROUTINE mpi_wait 
     1234#endif 
     1235 
     1236   !!---------------------------------------------------------------------- 
     1237   !!   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam   routines 
    18911238   !!---------------------------------------------------------------------- 
    18921239 
Note: See TracChangeset for help on using the changeset viewer.