DistributedMeter.F90 Source File

#include "unused_dummy.H"
#include "MAPL_ErrLog.h"

module MAPL_DistributedMeter
   use, intrinsic :: iso_fortran_env, only: REAL64
   use MAPL_ErrorHandlingMod
   use MAPL_AbstractMeter
   use MAPL_AdvancedMeter
   use MAPL_AbstractGauge
   use MPI
   implicit none
   private

   public :: DistributedMeter
   public :: DistributedReal64
   public :: DistributedInteger
   public :: DistributedStatistics
   public :: operator(.reduce.)

   interface operator(.reduce.)
      module procedure reduce_distributed_real64
      module procedure reduce_distributed_integer
      module procedure reduce_distributed_data
   end interface

   type :: DistributedReal64
      sequence
      real(kind=REAL64) :: total = 0
      real(kind=REAL64) :: min = huge(1._REAL64)
      real(kind=REAL64) :: max = -huge(1._REAL64)
      integer :: min_pe = huge(1)
      integer :: max_pe = -1
      integer :: num_pes = 1
      integer :: pad
   end type DistributedReal64

   type :: DistributedInteger
      sequence
      integer :: total = 0
      integer :: min
      integer :: max
      integer :: min_pe = huge(1)
      integer :: max_pe = -1
      integer :: num_pes = 1
   end type DistributedInteger

   type :: DistributedStatistics
      sequence
      type(DistributedReal64) :: total
      type(DistributedReal64) :: exclusive
      type(DistributedReal64) :: min_cycle
      type(DistributedReal64) :: max_cycle
      type(DistributedReal64) :: mean_cycle
      type(DistributedReal64) :: sum_square_deviation
      type(DistributedInteger) :: num_cycles
   end type DistributedStatistics

   type, extends(AdvancedMeter) :: DistributedMeter
      private
      type(DistributedStatistics) :: statistics
   contains
      !procedure :: reduce_global
      procedure :: reduce_mpi
      generic :: reduce => reduce_mpi !,reduce_global

      procedure :: get_statistics
      procedure :: get_stats_total
      procedure :: get_stats_min_cycle
      procedure :: get_stats_max_cycle
      procedure :: get_stats_num_cycles
!!$      procedure :: get_stats_sum_square_deviation

      procedure :: make_mpi_type_distributed_data
      procedure :: make_mpi_type_distributed_real64
      procedure :: make_mpi_type_distributed_integer
      generic :: make_mpi_type => make_mpi_type_distributed_data
      generic :: make_mpi_type => make_mpi_type_distributed_real64
      generic :: make_mpi_type => make_mpi_type_distributed_integer
   end type DistributedMeter


   interface DistributedReal64
      module procedure :: new_DistributedReal64
   end interface DistributedReal64

   interface DistributedInteger
      module procedure :: new_DistributedInteger
   end interface DistributedInteger

   interface DistributedMeter
      module procedure :: new_DistributedMeter
   end interface DistributedMeter


contains

   function new_DistributedReal64(value, rank) result(distributed_real64)
      type(DistributedReal64) :: distributed_real64
      real(kind=REAL64), intent(in) :: value
      integer, intent(in) :: rank

      distributed_real64%total = value
      distributed_real64%min = value
      distributed_real64%max = value
      distributed_real64%min_pe = rank
      distributed_real64%max_pe = rank
      distributed_real64%num_pes = 1

   end function new_DistributedReal64

   function new_DistributedInteger(value, rank) result(distributed_integer)
      type(DistributedInteger) :: distributed_integer
      integer, intent(in) :: value
      integer, intent(in) :: rank

      distributed_integer%total = value
      distributed_integer%min = value
      distributed_integer%max = value
      distributed_integer%min_pe = rank
      distributed_integer%max_pe = rank
      distributed_integer%num_pes = 1
   end function new_DistributedInteger


   function new_DistributedMeter(gauge) result(distributed_meter)
      type(DistributedMeter) :: distributed_meter
      class(AbstractGauge), intent(in) :: gauge

      integer :: ierror
   
      if (.not. dist_initialized) then
         call initialize(ierror)
         dist_initialized = .true.
      end if

      distributed_meter%AdvancedMeter = AdvancedMeter(gauge)

   end function new_DistributedMeter

   subroutine initialize(ierror)
      integer, intent(out) :: ierror

      type (DistributedMeter) :: dummy
      logical :: commute
      integer :: rc, status
      
      call dummy%make_mpi_type(dummy%statistics, type_dist_struct, ierror)
      call MPI_Type_commit(type_dist_struct, ierror)
      _VERIFY(ierror)

      commute = .true.
      call MPI_Op_create(true_reduce, commute, dist_reduce_op, ierror)
      _VERIFY(ierror)

   end subroutine initialize

   function get_statistics(this) result(statistics)
      type (DistributedStatistics) :: statistics
      class (DistributedMeter), intent(in) :: this
      statistics = this%statistics
   end function get_statistics

   function reduce_distributed_real64(a, b) result(c)
      type(DistributedReal64) :: c
      type(DistributedReal64), intent(in) :: a
      type(DistributedReal64), intent(in) :: b

      c%total = a%total + b%total
      
      if (b%min < a%min) then
         c%min_pe = b%min_pe
      elseif (a%min < b%min) then
         c%min_pe = a%min_pe
      else ! tie
         c%min_pe = min(a%min_pe, b%min_pe)
      end if
      c%min = min(a%min, b%min)
      
      if (b%max > a%max) then
         c%max_pe = b%max_pe
      elseif (a%max > b%max) then
         c%max_pe = a%max_pe
      else ! tie
         c%max_pe = min(a%max_pe, b%max_pe)
      end if
      c%max = max(a%max, b%max)

      c%num_pes = a%num_pes + b%num_pes

   end function reduce_distributed_real64
      

   function reduce_distributed_integer(a, b) result(c)
      type(DistributedInteger) :: c
      type(DistributedInteger), intent(in) :: a
      type(DistributedInteger), intent(in) :: b

      c%total = a%total + b%total

      if (b%min < a%min) then
         c%min_pe = b%min_pe
      elseif (a%min < b%min) then
         c%min_pe = a%min_pe
      else ! tie
         c%min_pe = min(a%min_pe, b%min_pe)
      end if
      c%min = min(a%min, b%min)
      
      if (b%max > a%max) then
         c%max_pe = b%max_pe
      elseif (a%max > b%max) then
         c%max_pe = a%max_pe
      else ! tie
         c%max_pe = min(a%max_pe, b%max_pe)
      end if
      c%max = max(a%max, b%max)

      c%num_pes = a%num_pes + b%num_pes

   end function reduce_distributed_integer
      

   function reduce_distributed_data(a, b) result(c)
      type(DistributedStatistics) :: c
      type(DistributedStatistics), intent(in) :: a
      type(DistributedStatistics), intent(in) :: b

      c%total = a%total .reduce. b%total
      c%exclusive = a%exclusive .reduce. b%exclusive
      c%min_cycle = a%min_cycle .reduce. b%min_cycle
      
      c%max_cycle = a%max_cycle .reduce. b%max_cycle
      c%sum_square_deviation = a%sum_square_deviation .reduce. b%sum_square_deviation
      c%num_cycles = a%num_cycles .reduce. b%num_cycles
      
   end function reduce_distributed_data


   function get_stats_total(this) result(total)
      type(DistributedReal64) :: total
      class(DistributedMeter), intent(in) :: this

      total = this%statistics%total
   end function get_stats_total
   
   function get_stats_min_cycle(this) result(min_cycle)
      type(DistributedReal64) :: min_cycle
      class(DistributedMeter), intent(in) :: this

      min_cycle = this%statistics%min_cycle
   end function get_stats_min_cycle
   
   function get_stats_max_cycle(this) result(max_cycle)
      type(DistributedReal64) :: max_cycle
      class(DistributedMeter), intent(in) :: this

      max_cycle = this%statistics%max_cycle
   end function get_stats_max_cycle
   
   function get_stats_num_cycles(this) result(num_cycles)
      type(DistributedInteger) :: num_cycles
      class(DistributedMeter), intent(in) :: this

      num_cycles = this%statistics%num_cycles
   end function get_stats_num_cycles

   
   subroutine reduce_global(this, exclusive)
      class(DistributedMeter), intent(inout) :: this
      real(kind=REAL64), intent(in) :: exclusive
      call this%reduce(MPI_COMM_WORLD, exclusive)
   end subroutine reduce_global
   

   subroutine reduce_mpi(this, comm, exclusive)
      class(DistributedMeter), intent(inout) :: this
      integer, intent(in) :: comm
      real(kind=REAL64), intent(in) :: exclusive

      integer :: ierror

      integer :: rank
      type(DistributedStatistics) :: tmp
      integer :: rc, status

      call MPI_Comm_rank(comm, rank, ierror)
      _VERIFY(ierror)

      this%statistics%total = DistributedReal64(this%get_total(), rank)
      this%statistics%exclusive = DistributedReal64(exclusive, rank)
      this%statistics%min_cycle = DistributedReal64(this%get_min_cycle(), rank)
      this%statistics%max_cycle = DistributedReal64(this%get_max_cycle(), rank)
      this%statistics%sum_square_deviation = DistributedReal64(this%get_sum_square_deviation(), rank)
      this%statistics%num_cycles = DistributedInteger(this%get_num_cycles(), rank)

      tmp = this%statistics
      call MPI_Reduce(tmp, this%statistics, 1, type_dist_struct, dist_reduce_op, 0, comm, ierror)
      _VERIFY(ierror)

   end subroutine reduce_mpi


   subroutine make_mpi_type_distributed_real64(this, r64, new_type, ierror)
      class (DistributedMeter), intent(in) :: this
      type (DistributedReal64), intent(in) :: r64 ! used only for generic resolution
      integer, intent(out) :: new_type
      integer, intent(out) :: ierror

      integer(kind=MPI_ADDRESS_KIND) :: displacements(2)
      integer(kind=MPI_ADDRESS_KIND) :: lb, sz
      integer :: rc, status

      _UNUSED_DUMMY(this)
      _UNUSED_DUMMY(r64)
      call MPI_Type_get_extent_x(MPI_REAL8, lb, sz, ierror)
      _VERIFY(ierror)
      displacements = [0_MPI_ADDRESS_KIND, 3*sz]

      call MPI_Type_create_struct(2, [3,4], displacements, [MPI_REAL8, MPI_INTEGER], new_type, ierror)
      _VERIFY(ierror)

   end subroutine make_mpi_type_distributed_real64


   subroutine make_mpi_type_distributed_integer(this, int, new_type, ierror)
      class (DistributedMeter), intent(in) :: this
      type (DistributedInteger), intent(in) :: int ! used only for generic resolution
      integer, intent(out) :: new_type
      integer, intent(out) :: ierror

      integer(kind=MPI_ADDRESS_KIND) :: displacements(1)
      integer :: rc, status

      _UNUSED_DUMMY(this)
      _UNUSED_DUMMY(int)
      displacements = [0_MPI_ADDRESS_KIND]
      call MPI_Type_create_struct(1, [6], displacements, [MPI_INTEGER], new_type, ierror)
      _VERIFY(ierror)

   end subroutine make_mpi_type_distributed_integer


   subroutine make_mpi_type_distributed_data(this, d, new_type, ierror)
      class (DistributedMeter), intent(in) :: this
      type (DistributedStatistics), intent(in) :: d ! used only for generic resolution
      integer, intent(out) :: new_type
      integer, intent(out) :: ierror

      integer(kind=MPI_ADDRESS_KIND) :: displacements(2)
      integer(kind=MPI_ADDRESS_KIND) :: lb, sz, sz2
      integer :: rc, status

      _UNUSED_DUMMY(d)
      call this%make_mpi_type(this%statistics%total, type_dist_real64, ierror)
      call this%make_mpi_type(this%statistics%num_cycles, type_dist_integer, ierror)

      call MPI_Type_get_extent_x(type_dist_real64, lb, sz, ierror)
      _VERIFY(ierror)
      displacements = [0_MPI_ADDRESS_KIND, 6*sz]
      call MPI_Type_create_struct(2, [6,1], displacements, [type_dist_real64, type_dist_integer], new_type, ierror)
      _VERIFY(ierror)
      call MPI_Type_get_extent_x(new_type, lb, sz2, ierror)
      _VERIFY(ierror)

   end subroutine make_mpi_type_distributed_data



   subroutine true_reduce(invec, inoutvec, len, type)
      integer, intent(in) :: len
      type(DistributedStatistics), intent(in) :: invec(len)
      type(DistributedStatistics), intent(inout) :: inoutvec(len)
      integer, intent(in) :: type

      integer :: i

      _UNUSED_DUMMY(type)
      
      do i = 1, len
         inoutvec(i) = invec(i) .reduce. inoutvec(i)
      end do
   
   end subroutine true_reduce
   
end module MAPL_DistributedMeter