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 13228 for NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/lib_mpp.F90 – NEMO

Ignore:
Timestamp:
2020-07-02T16:41:07+02:00 (4 years ago)
Author:
smasson
Message:

better e3: update with trunk@13227 see #2385

File:
1 edited

Legend:

Unmodified
Added
Removed
  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/lib_mpp.F90

    r13219 r13228  
    6767   PUBLIC   mpp_ini_znl 
    6868   PUBLIC   mppsend, mpprecv                          ! needed by TAM and ICB routines 
     69   PUBLIC   mppsend_sp, mpprecv_sp                          ! needed by TAM and ICB routines 
     70   PUBLIC   mppsend_dp, mpprecv_dp                          ! needed by TAM and ICB routines 
    6971   PUBLIC   mpp_report 
    7072   PUBLIC   mpp_bcast_nml 
     
    7981   !! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ 
    8082   INTERFACE mpp_min 
    81       MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 
     83      MODULE PROCEDURE mppmin_a_int, mppmin_int 
     84      MODULE PROCEDURE mppmin_a_real_sp, mppmin_real_sp 
     85      MODULE PROCEDURE mppmin_a_real_dp, mppmin_real_dp 
    8286   END INTERFACE 
    8387   INTERFACE mpp_max 
    84       MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real 
     88      MODULE PROCEDURE mppmax_a_int, mppmax_int 
     89      MODULE PROCEDURE mppmax_a_real_sp, mppmax_real_sp 
     90      MODULE PROCEDURE mppmax_a_real_dp, mppmax_real_dp 
    8591   END INTERFACE 
    8692   INTERFACE mpp_sum 
    87       MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real,   & 
    88          &             mppsum_realdd, mppsum_a_realdd 
     93      MODULE PROCEDURE mppsum_a_int, mppsum_int 
     94      MODULE PROCEDURE mppsum_realdd, mppsum_a_realdd 
     95      MODULE PROCEDURE mppsum_a_real_sp, mppsum_real_sp 
     96      MODULE PROCEDURE mppsum_a_real_dp, mppsum_real_dp 
    8997   END INTERFACE 
    9098   INTERFACE mpp_minloc 
    91       MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 
     99      MODULE PROCEDURE mpp_minloc2d_sp ,mpp_minloc3d_sp 
     100      MODULE PROCEDURE mpp_minloc2d_dp ,mpp_minloc3d_dp 
    92101   END INTERFACE 
    93102   INTERFACE mpp_maxloc 
    94       MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
     103      MODULE PROCEDURE mpp_maxloc2d_sp ,mpp_maxloc3d_sp 
     104      MODULE PROCEDURE mpp_maxloc2d_dp ,mpp_maxloc3d_dp 
    95105   END INTERFACE 
    96106 
     
    158168   TYPE, PUBLIC ::   DELAYARR 
    159169      REAL(   wp), POINTER, DIMENSION(:) ::  z1d => NULL() 
    160       COMPLEX(wp), POINTER, DIMENSION(:) ::  y1d => NULL() 
     170      COMPLEX(dp), POINTER, DIMENSION(:) ::  y1d => NULL() 
    161171   END TYPE DELAYARR 
    162172   TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC, SAVE  ::   todelay         !: must have SAVE for default initialization of DELAYARR 
     
    164174 
    165175   ! timing summary report 
    166    REAL(wp), DIMENSION(2), PUBLIC ::  waiting_time = 0._wp 
    167    REAL(wp)              , PUBLIC ::  compute_time = 0._wp, elapsed_time = 0._wp 
     176   REAL(dp), DIMENSION(2), PUBLIC ::  waiting_time = 0._dp 
     177   REAL(dp)              , PUBLIC ::  compute_time = 0._dp, elapsed_time = 0._dp 
    168178    
    169179   REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::   tampon   ! buffer in case of bsend 
     
    251261      !! 
    252262      INTEGER ::   iflag 
     263      INTEGER :: mpi_working_type 
     264      !!---------------------------------------------------------------------- 
     265      ! 
     266#if defined key_mpp_mpi 
     267      IF (wp == dp) THEN 
     268         mpi_working_type = mpi_double_precision 
     269      ELSE 
     270         mpi_working_type = mpi_real 
     271      END IF 
     272      CALL mpi_isend( pmess, kbytes, mpi_working_type, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
     273#endif 
     274      ! 
     275   END SUBROUTINE mppsend 
     276 
     277 
     278   SUBROUTINE mppsend_dp( ktyp, pmess, kbytes, kdest, md_req ) 
     279      !!---------------------------------------------------------------------- 
     280      !!                  ***  routine mppsend  *** 
     281      !! 
     282      !! ** Purpose :   Send messag passing array 
     283      !! 
     284      !!---------------------------------------------------------------------- 
     285      REAL(dp), INTENT(inout) ::   pmess(*)   ! array of real 
     286      INTEGER , INTENT(in   ) ::   kbytes     ! size of the array pmess 
     287      INTEGER , INTENT(in   ) ::   kdest      ! receive process number 
     288      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message 
     289      INTEGER , INTENT(in   ) ::   md_req     ! argument for isend 
     290      !! 
     291      INTEGER ::   iflag 
    253292      !!---------------------------------------------------------------------- 
    254293      ! 
     
    257296#endif 
    258297      ! 
    259    END SUBROUTINE mppsend 
     298   END SUBROUTINE mppsend_dp 
     299 
     300 
     301   SUBROUTINE mppsend_sp( ktyp, pmess, kbytes, kdest, md_req ) 
     302      !!---------------------------------------------------------------------- 
     303      !!                  ***  routine mppsend  *** 
     304      !! 
     305      !! ** Purpose :   Send messag passing array 
     306      !! 
     307      !!---------------------------------------------------------------------- 
     308      REAL(sp), INTENT(inout) ::   pmess(*)   ! array of real 
     309      INTEGER , INTENT(in   ) ::   kbytes     ! size of the array pmess 
     310      INTEGER , INTENT(in   ) ::   kdest      ! receive process number 
     311      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message 
     312      INTEGER , INTENT(in   ) ::   md_req     ! argument for isend 
     313      !! 
     314      INTEGER ::   iflag 
     315      !!---------------------------------------------------------------------- 
     316      ! 
     317#if defined key_mpp_mpi 
     318      CALL mpi_isend( pmess, kbytes, mpi_real, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
     319#endif 
     320      ! 
     321   END SUBROUTINE mppsend_sp 
    260322 
    261323 
     
    275337      INTEGER :: iflag 
    276338      INTEGER :: use_source 
     339      INTEGER :: mpi_working_type 
    277340      !!---------------------------------------------------------------------- 
    278341      ! 
     
    283346      IF( PRESENT(ksource) )   use_source = ksource 
    284347      ! 
     348      IF (wp == dp) THEN 
     349         mpi_working_type = mpi_double_precision 
     350      ELSE 
     351         mpi_working_type = mpi_real 
     352      END IF 
     353      CALL mpi_recv( pmess, kbytes, mpi_working_type, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 
     354#endif 
     355      ! 
     356   END SUBROUTINE mpprecv 
     357 
     358   SUBROUTINE mpprecv_dp( ktyp, pmess, kbytes, ksource ) 
     359      !!---------------------------------------------------------------------- 
     360      !!                  ***  routine mpprecv  *** 
     361      !! 
     362      !! ** Purpose :   Receive messag passing array 
     363      !! 
     364      !!---------------------------------------------------------------------- 
     365      REAL(dp), INTENT(inout) ::   pmess(*)   ! array of real 
     366      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess 
     367      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message 
     368      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number 
     369      !! 
     370      INTEGER :: istatus(mpi_status_size) 
     371      INTEGER :: iflag 
     372      INTEGER :: use_source 
     373      !!---------------------------------------------------------------------- 
     374      ! 
     375#if defined key_mpp_mpi 
     376      ! If a specific process number has been passed to the receive call, 
     377      ! use that one. Default is to use mpi_any_source 
     378      use_source = mpi_any_source 
     379      IF( PRESENT(ksource) )   use_source = ksource 
     380      ! 
    285381      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 
    286382#endif 
    287383      ! 
    288    END SUBROUTINE mpprecv 
     384   END SUBROUTINE mpprecv_dp 
     385 
     386 
     387   SUBROUTINE mpprecv_sp( ktyp, pmess, kbytes, ksource ) 
     388      !!---------------------------------------------------------------------- 
     389      !!                  ***  routine mpprecv  *** 
     390      !! 
     391      !! ** Purpose :   Receive messag passing array 
     392      !! 
     393      !!---------------------------------------------------------------------- 
     394      REAL(sp), INTENT(inout) ::   pmess(*)   ! array of real 
     395      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess 
     396      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message 
     397      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number 
     398      !! 
     399      INTEGER :: istatus(mpi_status_size) 
     400      INTEGER :: iflag 
     401      INTEGER :: use_source 
     402      !!---------------------------------------------------------------------- 
     403      ! 
     404#if defined key_mpp_mpi 
     405      ! If a specific process number has been passed to the receive call, 
     406      ! use that one. Default is to use mpi_any_source 
     407      use_source = mpi_any_source 
     408      IF( PRESENT(ksource) )   use_source = ksource 
     409      ! 
     410      CALL mpi_recv( pmess, kbytes, mpi_real, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 
     411#endif 
     412      ! 
     413   END SUBROUTINE mpprecv_sp 
    289414 
    290415 
     
    351476      CHARACTER(len=*), INTENT(in   )               ::   cdname  ! name of the calling subroutine 
    352477      CHARACTER(len=*), INTENT(in   )               ::   cdelay  ! name (used as id) of the delayed operation 
    353       COMPLEX(wp),      INTENT(in   ), DIMENSION(:) ::   y_in 
     478      COMPLEX(dp),      INTENT(in   ), DIMENSION(:) ::   y_in 
    354479      REAL(wp),         INTENT(  out), DIMENSION(:) ::   pout 
    355480      LOGICAL,          INTENT(in   )               ::   ldlast  ! true if this is the last time we call this routine 
     
    359484      INTEGER ::   idvar 
    360485      INTEGER ::   ierr, ilocalcomm 
    361       COMPLEX(wp), ALLOCATABLE, DIMENSION(:) ::   ytmp 
     486      COMPLEX(dp), ALLOCATABLE, DIMENSION(:) ::   ytmp 
    362487      !!---------------------------------------------------------------------- 
    363488#if defined key_mpp_mpi 
     
    432557      INTEGER ::   idvar 
    433558      INTEGER ::   ierr, ilocalcomm 
    434       !!---------------------------------------------------------------------- 
    435 #if defined key_mpp_mpi 
     559      INTEGER ::   MPI_TYPE 
     560      !!---------------------------------------------------------------------- 
     561       
     562#if defined key_mpp_mpi 
     563      if( wp == dp ) then 
     564         MPI_TYPE = MPI_DOUBLE_PRECISION 
     565      else if ( wp == sp ) then 
     566         MPI_TYPE = MPI_REAL 
     567      else 
     568        CALL ctl_stop( "Error defining type, wp is neither dp nor sp" ) 
     569    
     570      end if 
     571 
    436572      ilocalcomm = mpi_comm_oce 
    437573      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     
    470606# if defined key_mpi2 
    471607      IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 
    472       CALL  mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ierr ) 
    473       ndelayid(idvar) = 1 
     608      CALL  mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
    474609      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
    475610# else 
    476       CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
     611      CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
    477612# endif 
    478613#else 
     
    551686#  undef INTEGER_TYPE 
    552687! 
     688   !! 
     689   !!   ----   SINGLE PRECISION VERSIONS 
     690   !! 
     691#  define SINGLE_PRECISION 
    553692#  define REAL_TYPE 
    554693#  define DIM_0d 
    555 #     define ROUTINE_ALLREDUCE           mppmax_real 
     694#     define ROUTINE_ALLREDUCE           mppmax_real_sp 
    556695#     include "mpp_allreduce_generic.h90" 
    557696#     undef ROUTINE_ALLREDUCE 
    558697#  undef DIM_0d 
    559698#  define DIM_1d 
    560 #     define ROUTINE_ALLREDUCE           mppmax_a_real 
     699#     define ROUTINE_ALLREDUCE           mppmax_a_real_sp 
     700#     include "mpp_allreduce_generic.h90" 
     701#     undef ROUTINE_ALLREDUCE 
     702#  undef DIM_1d 
     703#  undef SINGLE_PRECISION 
     704   !! 
     705   !! 
     706   !!   ----   DOUBLE PRECISION VERSIONS 
     707   !! 
     708! 
     709#  define DIM_0d 
     710#     define ROUTINE_ALLREDUCE           mppmax_real_dp 
     711#     include "mpp_allreduce_generic.h90" 
     712#     undef ROUTINE_ALLREDUCE 
     713#  undef DIM_0d 
     714#  define DIM_1d 
     715#     define ROUTINE_ALLREDUCE           mppmax_a_real_dp 
    561716#     include "mpp_allreduce_generic.h90" 
    562717#     undef ROUTINE_ALLREDUCE 
     
    583738#  undef INTEGER_TYPE 
    584739! 
     740   !! 
     741   !!   ----   SINGLE PRECISION VERSIONS 
     742   !! 
     743#  define SINGLE_PRECISION 
    585744#  define REAL_TYPE 
    586745#  define DIM_0d 
    587 #     define ROUTINE_ALLREDUCE           mppmin_real 
     746#     define ROUTINE_ALLREDUCE           mppmin_real_sp 
    588747#     include "mpp_allreduce_generic.h90" 
    589748#     undef ROUTINE_ALLREDUCE 
    590749#  undef DIM_0d 
    591750#  define DIM_1d 
    592 #     define ROUTINE_ALLREDUCE           mppmin_a_real 
     751#     define ROUTINE_ALLREDUCE           mppmin_a_real_sp 
     752#     include "mpp_allreduce_generic.h90" 
     753#     undef ROUTINE_ALLREDUCE 
     754#  undef DIM_1d 
     755#  undef SINGLE_PRECISION 
     756   !! 
     757   !!   ----   DOUBLE PRECISION VERSIONS 
     758   !! 
     759 
     760#  define DIM_0d 
     761#     define ROUTINE_ALLREDUCE           mppmin_real_dp 
     762#     include "mpp_allreduce_generic.h90" 
     763#     undef ROUTINE_ALLREDUCE 
     764#  undef DIM_0d 
     765#  define DIM_1d 
     766#     define ROUTINE_ALLREDUCE           mppmin_a_real_dp 
    593767#     include "mpp_allreduce_generic.h90" 
    594768#     undef ROUTINE_ALLREDUCE 
     
    616790#  undef DIM_1d 
    617791#  undef INTEGER_TYPE 
    618 ! 
     792 
     793   !! 
     794   !!   ----   SINGLE PRECISION VERSIONS 
     795   !! 
     796#  define OPERATION_SUM 
     797#  define SINGLE_PRECISION 
    619798#  define REAL_TYPE 
    620799#  define DIM_0d 
    621 #     define ROUTINE_ALLREDUCE           mppsum_real 
     800#     define ROUTINE_ALLREDUCE           mppsum_real_sp 
    622801#     include "mpp_allreduce_generic.h90" 
    623802#     undef ROUTINE_ALLREDUCE 
    624803#  undef DIM_0d 
    625804#  define DIM_1d 
    626 #     define ROUTINE_ALLREDUCE           mppsum_a_real 
     805#     define ROUTINE_ALLREDUCE           mppsum_a_real_sp 
     806#     include "mpp_allreduce_generic.h90" 
     807#     undef ROUTINE_ALLREDUCE 
     808#  undef DIM_1d 
     809#  undef REAL_TYPE 
     810#  undef OPERATION_SUM 
     811 
     812#  undef SINGLE_PRECISION 
     813 
     814   !! 
     815   !!   ----   DOUBLE PRECISION VERSIONS 
     816   !! 
     817#  define OPERATION_SUM 
     818#  define REAL_TYPE 
     819#  define DIM_0d 
     820#     define ROUTINE_ALLREDUCE           mppsum_real_dp 
     821#     include "mpp_allreduce_generic.h90" 
     822#     undef ROUTINE_ALLREDUCE 
     823#  undef DIM_0d 
     824#  define DIM_1d 
     825#     define ROUTINE_ALLREDUCE           mppsum_a_real_dp 
    627826#     include "mpp_allreduce_generic.h90" 
    628827#     undef ROUTINE_ALLREDUCE 
     
    651850   !!---------------------------------------------------------------------- 
    652851   !! 
     852   !! 
     853   !!   ----   SINGLE PRECISION VERSIONS 
     854   !! 
     855#  define SINGLE_PRECISION 
    653856#  define OPERATION_MINLOC 
    654857#  define DIM_2d 
    655 #     define ROUTINE_LOC           mpp_minloc2d 
     858#     define ROUTINE_LOC           mpp_minloc2d_sp 
    656859#     include "mpp_loc_generic.h90" 
    657860#     undef ROUTINE_LOC 
    658861#  undef DIM_2d 
    659862#  define DIM_3d 
    660 #     define ROUTINE_LOC           mpp_minloc3d 
     863#     define ROUTINE_LOC           mpp_minloc3d_sp 
    661864#     include "mpp_loc_generic.h90" 
    662865#     undef ROUTINE_LOC 
     
    666869#  define OPERATION_MAXLOC 
    667870#  define DIM_2d 
    668 #     define ROUTINE_LOC           mpp_maxloc2d 
     871#     define ROUTINE_LOC           mpp_maxloc2d_sp 
    669872#     include "mpp_loc_generic.h90" 
    670873#     undef ROUTINE_LOC 
    671874#  undef DIM_2d 
    672875#  define DIM_3d 
    673 #     define ROUTINE_LOC           mpp_maxloc3d 
     876#     define ROUTINE_LOC           mpp_maxloc3d_sp 
    674877#     include "mpp_loc_generic.h90" 
    675878#     undef ROUTINE_LOC 
    676879#  undef DIM_3d 
    677880#  undef OPERATION_MAXLOC 
     881#  undef SINGLE_PRECISION 
     882   !! 
     883   !!   ----   DOUBLE PRECISION VERSIONS 
     884   !! 
     885#  define OPERATION_MINLOC 
     886#  define DIM_2d 
     887#     define ROUTINE_LOC           mpp_minloc2d_dp 
     888#     include "mpp_loc_generic.h90" 
     889#     undef ROUTINE_LOC 
     890#  undef DIM_2d 
     891#  define DIM_3d 
     892#     define ROUTINE_LOC           mpp_minloc3d_dp 
     893#     include "mpp_loc_generic.h90" 
     894#     undef ROUTINE_LOC 
     895#  undef DIM_3d 
     896#  undef OPERATION_MINLOC 
     897 
     898#  define OPERATION_MAXLOC 
     899#  define DIM_2d 
     900#     define ROUTINE_LOC           mpp_maxloc2d_dp 
     901#     include "mpp_loc_generic.h90" 
     902#     undef ROUTINE_LOC 
     903#  undef DIM_2d 
     904#  define DIM_3d 
     905#     define ROUTINE_LOC           mpp_maxloc3d_dp 
     906#     include "mpp_loc_generic.h90" 
     907#     undef ROUTINE_LOC 
     908#  undef DIM_3d 
     909#  undef OPERATION_MAXLOC 
     910 
    678911 
    679912   SUBROUTINE mppsync() 
     
    9041137      !!--------------------------------------------------------------------- 
    9051138      INTEGER                     , INTENT(in)    ::   ilen, itype 
    906       COMPLEX(wp), DIMENSION(ilen), INTENT(in)    ::   ydda 
    907       COMPLEX(wp), DIMENSION(ilen), INTENT(inout) ::   yddb 
    908       ! 
    909       REAL(wp) :: zerr, zt1, zt2    ! local work variables 
     1139      COMPLEX(dp), DIMENSION(ilen), INTENT(in)    ::   ydda 
     1140      COMPLEX(dp), DIMENSION(ilen), INTENT(inout) ::   yddb 
     1141      ! 
     1142      REAL(dp) :: zerr, zt1, zt2    ! local work variables 
    9101143      INTEGER  :: ji, ztmp           ! local scalar 
    9111144      !!--------------------------------------------------------------------- 
     
    10601293    LOGICAL,           INTENT(IN) :: ld_tic 
    10611294    LOGICAL, OPTIONAL, INTENT(IN) :: ld_global 
    1062     REAL(wp), DIMENSION(2), SAVE :: tic_wt 
    1063     REAL(wp),               SAVE :: tic_ct = 0._wp 
     1295    REAL(dp), DIMENSION(2), SAVE :: tic_wt 
     1296    REAL(dp),               SAVE :: tic_ct = 0._dp 
    10641297    INTEGER :: ii 
    10651298#if defined key_mpp_mpi 
     
    10741307    IF ( ld_tic ) THEN 
    10751308       tic_wt(ii) = MPI_Wtime()                                                    ! start count tic->tac (waiting time) 
    1076        IF ( tic_ct > 0.0_wp ) compute_time = compute_time + MPI_Wtime() - tic_ct   ! cumulate count tac->tic 
     1309       IF ( tic_ct > 0.0_dp ) compute_time = compute_time + MPI_Wtime() - tic_ct   ! cumulate count tac->tic 
    10771310    ELSE 
    10781311       waiting_time(ii) = waiting_time(ii) + MPI_Wtime() - tic_wt(ii)              ! cumulate count tic->tac 
Note: See TracChangeset for help on using the changeset viewer.