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 12603 for NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/LBC/lib_mpp.F90 – NEMO

Ignore:
Timestamp:
2020-03-25T16:20:25+01:00 (4 years ago)
Author:
orioltp
Message:

Adding several interfaces to work with both single and double precision

File:
1 edited

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/LBC/lib_mpp.F90

    r12512 r12603  
    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 
    … …  
    260270 
    261271 
     272   SUBROUTINE mppsend_dp( ktyp, pmess, kbytes, kdest, md_req ) 
     273      !!---------------------------------------------------------------------- 
     274      !!                  ***  routine mppsend  *** 
     275      !! 
     276      !! ** Purpose :   Send messag passing array 
     277      !! 
     278      !!---------------------------------------------------------------------- 
     279      REAL(dp), INTENT(inout) ::   pmess(*)   ! array of real 
     280      INTEGER , INTENT(in   ) ::   kbytes     ! size of the array pmess 
     281      INTEGER , INTENT(in   ) ::   kdest      ! receive process number 
     282      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message 
     283      INTEGER , INTENT(in   ) ::   md_req     ! argument for isend 
     284      !! 
     285      INTEGER ::   iflag 
     286      !!---------------------------------------------------------------------- 
     287      ! 
     288#if defined key_mpp_mpi 
     289      CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
     290#endif 
     291      ! 
     292   END SUBROUTINE mppsend_dp 
     293 
     294 
     295   SUBROUTINE mppsend_sp( ktyp, pmess, kbytes, kdest, md_req ) 
     296      !!---------------------------------------------------------------------- 
     297      !!                  ***  routine mppsend  *** 
     298      !! 
     299      !! ** Purpose :   Send messag passing array 
     300      !! 
     301      !!---------------------------------------------------------------------- 
     302      REAL(sp), INTENT(inout) ::   pmess(*)   ! array of real 
     303      INTEGER , INTENT(in   ) ::   kbytes     ! size of the array pmess 
     304      INTEGER , INTENT(in   ) ::   kdest      ! receive process number 
     305      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message 
     306      INTEGER , INTENT(in   ) ::   md_req     ! argument for isend 
     307      !! 
     308      INTEGER ::   iflag 
     309      !!---------------------------------------------------------------------- 
     310      ! 
     311#if defined key_mpp_mpi 
     312      CALL mpi_isend( pmess, kbytes, mpi_real, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
     313#endif 
     314      ! 
     315   END SUBROUTINE mppsend_sp 
     316 
     317 
    262318   SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource ) 
    263319      !!---------------------------------------------------------------------- 
    … …  
    288344   END SUBROUTINE mpprecv 
    289345 
     346   SUBROUTINE mpprecv_dp( ktyp, pmess, kbytes, ksource ) 
     347      !!---------------------------------------------------------------------- 
     348      !!                  ***  routine mpprecv  *** 
     349      !! 
     350      !! ** Purpose :   Receive messag passing array 
     351      !! 
     352      !!---------------------------------------------------------------------- 
     353      REAL(dp), INTENT(inout) ::   pmess(*)   ! array of real 
     354      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess 
     355      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message 
     356      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number 
     357      !! 
     358      INTEGER :: istatus(mpi_status_size) 
     359      INTEGER :: iflag 
     360      INTEGER :: use_source 
     361      !!---------------------------------------------------------------------- 
     362      ! 
     363#if defined key_mpp_mpi 
     364      ! If a specific process number has been passed to the receive call, 
     365      ! use that one. Default is to use mpi_any_source 
     366      use_source = mpi_any_source 
     367      IF( PRESENT(ksource) )   use_source = ksource 
     368      ! 
     369      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 
     370#endif 
     371      ! 
     372   END SUBROUTINE mpprecv_dp 
     373 
     374 
     375   SUBROUTINE mpprecv_sp( ktyp, pmess, kbytes, ksource ) 
     376      !!---------------------------------------------------------------------- 
     377      !!                  ***  routine mpprecv  *** 
     378      !! 
     379      !! ** Purpose :   Receive messag passing array 
     380      !! 
     381      !!---------------------------------------------------------------------- 
     382      REAL(sp), INTENT(inout) ::   pmess(*)   ! array of real 
     383      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess 
     384      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message 
     385      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number 
     386      !! 
     387      INTEGER :: istatus(mpi_status_size) 
     388      INTEGER :: iflag 
     389      INTEGER :: use_source 
     390      !!---------------------------------------------------------------------- 
     391      ! 
     392#if defined key_mpp_mpi 
     393      ! If a specific process number has been passed to the receive call, 
     394      ! use that one. Default is to use mpi_any_source 
     395      use_source = mpi_any_source 
     396      IF( PRESENT(ksource) )   use_source = ksource 
     397      ! 
     398      CALL mpi_recv( pmess, kbytes, mpi_real, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 
     399#endif 
     400      ! 
     401   END SUBROUTINE mpprecv_sp 
     402 
    290403 
    291404   SUBROUTINE mppgather( ptab, kp, pio ) 
    … …  
    351464      CHARACTER(len=*), INTENT(in   )               ::   cdname  ! name of the calling subroutine 
    352465      CHARACTER(len=*), INTENT(in   )               ::   cdelay  ! name (used as id) of the delayed operation 
    353       COMPLEX(wp),      INTENT(in   ), DIMENSION(:) ::   y_in 
     466      COMPLEX(dp),      INTENT(in   ), DIMENSION(:) ::   y_in 
    354467      REAL(wp),         INTENT(  out), DIMENSION(:) ::   pout 
    355468      LOGICAL,          INTENT(in   )               ::   ldlast  ! true if this is the last time we call this routine 
    … …  
    359472      INTEGER ::   idvar 
    360473      INTEGER ::   ierr, ilocalcomm 
    361       COMPLEX(wp), ALLOCATABLE, DIMENSION(:) ::   ytmp 
     474      COMPLEX(dp), ALLOCATABLE, DIMENSION(:) ::   ytmp 
    362475      !!---------------------------------------------------------------------- 
    363476#if defined key_mpp_mpi 
    … …  
    432545      INTEGER ::   idvar 
    433546      INTEGER ::   ierr, ilocalcomm 
    434       !!---------------------------------------------------------------------- 
    435 #if defined key_mpp_mpi 
     547      INTEGER ::   MPI_TYPE 
     548      !!---------------------------------------------------------------------- 
     549       
     550#if defined key_mpp_mpi 
     551      if( wp == dp ) then 
     552         MPI_TYPE = MPI_DOUBLE_PRECISION 
     553      else if ( wp == sp ) then 
     554         MPI_TYPE = MPI_REAL 
     555      else 
     556        CALL ctl_stop( "Error defining type, wp is neither dp nor sp" ) 
     557    
     558      end if 
     559 
    436560      ilocalcomm = mpi_comm_oce 
    437561      IF( PRESENT(kcom) )   ilocalcomm = kcom 
    … …  
    470594# if defined key_mpi2 
    471595      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 
     596      CALL  mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
    474597      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
    475598# else 
    476       CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
     599      CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
    477600# endif 
    478601#else 
    … …  
    551674#  undef INTEGER_TYPE 
    552675! 
     676   !! 
     677   !!   ----   SINGLE PRECISION VERSIONS 
     678   !! 
     679#  define SINGLE_PRECISION 
    553680#  define REAL_TYPE 
    554681#  define DIM_0d 
    555 #     define ROUTINE_ALLREDUCE           mppmax_real 
     682#     define ROUTINE_ALLREDUCE           mppmax_real_sp 
    556683#     include "mpp_allreduce_generic.h90" 
    557684#     undef ROUTINE_ALLREDUCE 
    558685#  undef DIM_0d 
    559686#  define DIM_1d 
    560 #     define ROUTINE_ALLREDUCE           mppmax_a_real 
     687#     define ROUTINE_ALLREDUCE           mppmax_a_real_sp 
     688#     include "mpp_allreduce_generic.h90" 
     689#     undef ROUTINE_ALLREDUCE 
     690#  undef DIM_1d 
     691#  undef SINGLE_PRECISION 
     692   !! 
     693   !! 
     694   !!   ----   DOUBLE PRECISION VERSIONS 
     695   !! 
     696! 
     697#  define DIM_0d 
     698#     define ROUTINE_ALLREDUCE           mppmax_real_dp 
     699#     include "mpp_allreduce_generic.h90" 
     700#     undef ROUTINE_ALLREDUCE 
     701#  undef DIM_0d 
     702#  define DIM_1d 
     703#     define ROUTINE_ALLREDUCE           mppmax_a_real_dp 
    561704#     include "mpp_allreduce_generic.h90" 
    562705#     undef ROUTINE_ALLREDUCE 
    … …  
    583726#  undef INTEGER_TYPE 
    584727! 
     728   !! 
     729   !!   ----   SINGLE PRECISION VERSIONS 
     730   !! 
     731#  define SINGLE_PRECISION 
    585732#  define REAL_TYPE 
    586733#  define DIM_0d 
    587 #     define ROUTINE_ALLREDUCE           mppmin_real 
     734#     define ROUTINE_ALLREDUCE           mppmin_real_sp 
    588735#     include "mpp_allreduce_generic.h90" 
    589736#     undef ROUTINE_ALLREDUCE 
    590737#  undef DIM_0d 
    591738#  define DIM_1d 
    592 #     define ROUTINE_ALLREDUCE           mppmin_a_real 
     739#     define ROUTINE_ALLREDUCE           mppmin_a_real_sp 
     740#     include "mpp_allreduce_generic.h90" 
     741#     undef ROUTINE_ALLREDUCE 
     742#  undef DIM_1d 
     743#  undef SINGLE_PRECISION 
     744   !! 
     745   !!   ----   DOUBLE PRECISION VERSIONS 
     746   !! 
     747 
     748#  define DIM_0d 
     749#     define ROUTINE_ALLREDUCE           mppmin_real_dp 
     750#     include "mpp_allreduce_generic.h90" 
     751#     undef ROUTINE_ALLREDUCE 
     752#  undef DIM_0d 
     753#  define DIM_1d 
     754#     define ROUTINE_ALLREDUCE           mppmin_a_real_dp 
    593755#     include "mpp_allreduce_generic.h90" 
    594756#     undef ROUTINE_ALLREDUCE 
    … …  
    616778#  undef DIM_1d 
    617779#  undef INTEGER_TYPE 
    618 ! 
     780 
     781   !! 
     782   !!   ----   SINGLE PRECISION VERSIONS 
     783   !! 
     784#  define OPERATION_SUM 
     785#  define SINGLE_PRECISION 
    619786#  define REAL_TYPE 
    620787#  define DIM_0d 
    621 #     define ROUTINE_ALLREDUCE           mppsum_real 
     788#     define ROUTINE_ALLREDUCE           mppsum_real_sp 
    622789#     include "mpp_allreduce_generic.h90" 
    623790#     undef ROUTINE_ALLREDUCE 
    624791#  undef DIM_0d 
    625792#  define DIM_1d 
    626 #     define ROUTINE_ALLREDUCE           mppsum_a_real 
     793#     define ROUTINE_ALLREDUCE           mppsum_a_real_sp 
     794#     include "mpp_allreduce_generic.h90" 
     795#     undef ROUTINE_ALLREDUCE 
     796#  undef DIM_1d 
     797#  undef REAL_TYPE 
     798#  undef OPERATION_SUM 
     799 
     800#  undef SINGLE_PRECISION 
     801 
     802   !! 
     803   !!   ----   DOUBLE PRECISION VERSIONS 
     804   !! 
     805#  define OPERATION_SUM 
     806#  define REAL_TYPE 
     807#  define DIM_0d 
     808#     define ROUTINE_ALLREDUCE           mppsum_real_dp 
     809#     include "mpp_allreduce_generic.h90" 
     810#     undef ROUTINE_ALLREDUCE 
     811#  undef DIM_0d 
     812#  define DIM_1d 
     813#     define ROUTINE_ALLREDUCE           mppsum_a_real_dp 
    627814#     include "mpp_allreduce_generic.h90" 
    628815#     undef ROUTINE_ALLREDUCE 
    … …  
    651838   !!---------------------------------------------------------------------- 
    652839   !! 
     840   !! 
     841   !!   ----   SINGLE PRECISION VERSIONS 
     842   !! 
     843#  define SINGLE_PRECISION 
    653844#  define OPERATION_MINLOC 
    654845#  define DIM_2d 
    655 #     define ROUTINE_LOC           mpp_minloc2d 
     846#     define ROUTINE_LOC           mpp_minloc2d_sp 
    656847#     include "mpp_loc_generic.h90" 
    657848#     undef ROUTINE_LOC 
    658849#  undef DIM_2d 
    659850#  define DIM_3d 
    660 #     define ROUTINE_LOC           mpp_minloc3d 
     851#     define ROUTINE_LOC           mpp_minloc3d_sp 
    661852#     include "mpp_loc_generic.h90" 
    662853#     undef ROUTINE_LOC 
    … …  
    666857#  define OPERATION_MAXLOC 
    667858#  define DIM_2d 
    668 #     define ROUTINE_LOC           mpp_maxloc2d 
     859#     define ROUTINE_LOC           mpp_maxloc2d_sp 
    669860#     include "mpp_loc_generic.h90" 
    670861#     undef ROUTINE_LOC 
    671862#  undef DIM_2d 
    672863#  define DIM_3d 
    673 #     define ROUTINE_LOC           mpp_maxloc3d 
     864#     define ROUTINE_LOC           mpp_maxloc3d_sp 
    674865#     include "mpp_loc_generic.h90" 
    675866#     undef ROUTINE_LOC 
    676867#  undef DIM_3d 
    677868#  undef OPERATION_MAXLOC 
     869#  undef SINGLE_PRECISION 
     870   !! 
     871   !!   ----   DOUBLE PRECISION VERSIONS 
     872   !! 
     873#  define OPERATION_MINLOC 
     874#  define DIM_2d 
     875#     define ROUTINE_LOC           mpp_minloc2d_dp 
     876#     include "mpp_loc_generic.h90" 
     877#     undef ROUTINE_LOC 
     878#  undef DIM_2d 
     879#  define DIM_3d 
     880#     define ROUTINE_LOC           mpp_minloc3d_dp 
     881#     include "mpp_loc_generic.h90" 
     882#     undef ROUTINE_LOC 
     883#  undef DIM_3d 
     884#  undef OPERATION_MINLOC 
     885 
     886#  define OPERATION_MAXLOC 
     887#  define DIM_2d 
     888#     define ROUTINE_LOC           mpp_maxloc2d_dp 
     889#     include "mpp_loc_generic.h90" 
     890#     undef ROUTINE_LOC 
     891#  undef DIM_2d 
     892#  define DIM_3d 
     893#     define ROUTINE_LOC           mpp_maxloc3d_dp 
     894#     include "mpp_loc_generic.h90" 
     895#     undef ROUTINE_LOC 
     896#  undef DIM_3d 
     897#  undef OPERATION_MAXLOC 
     898 
    678899 
    679900   SUBROUTINE mppsync() 
    … …  
    9041125      !!--------------------------------------------------------------------- 
    9051126      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 
     1127      COMPLEX(dp), DIMENSION(ilen), INTENT(in)    ::   ydda 
     1128      COMPLEX(dp), DIMENSION(ilen), INTENT(inout) ::   yddb 
     1129      ! 
     1130      REAL(dp) :: zerr, zt1, zt2    ! local work variables 
    9101131      INTEGER  :: ji, ztmp           ! local scalar 
    9111132      !!--------------------------------------------------------------------- 
    … …  
    10601281    LOGICAL,           INTENT(IN) :: ld_tic 
    10611282    LOGICAL, OPTIONAL, INTENT(IN) :: ld_global 
    1062     REAL(wp), DIMENSION(2), SAVE :: tic_wt 
    1063     REAL(wp),               SAVE :: tic_ct = 0._wp 
     1283    REAL(dp), DIMENSION(2), SAVE :: tic_wt 
     1284    REAL(dp),               SAVE :: tic_ct = 0._dp 
    10641285    INTEGER :: ii 
    10651286#if defined key_mpp_mpi 
    … …  
    10741295    IF ( ld_tic ) THEN 
    10751296       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 
     1297       IF ( tic_ct > 0.0_dp ) compute_time = compute_time + MPI_Wtime() - tic_ct   ! cumulate count tac->tic 
    10771298    ELSE 
    10781299       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.