MeterNode.F90 Source File

module MAPL_MeterNode
   use, intrinsic :: iso_fortran_env, only: REAL64
   use MAPL_AbstractMeter
   use MAPL_AbstractMeterNode
   use MAPL_MeterNodeVector
   implicit none
   private

   public :: MeterNode
   public :: MeterNodeIterator

   type, extends(AbstractMeterNode) :: MeterNode
      private

      ! Node data
      class(AbstractMeter), allocatable :: meter
      character(:), allocatable :: name

      ! Tree structure
      integer :: depth
      type (MeterNodeVector) :: children
      integer :: last_child_accessed = 0

   contains
      procedure :: get_meter
      procedure :: get_name
      procedure :: get_depth
      procedure :: get_inclusive
      procedure :: get_exclusive
      procedure :: add_child
      procedure :: find_child
      procedure :: get_child
      procedure :: has_child
      procedure :: get_num_nodes
      procedure :: get_num_children

      procedure :: accumulate
      procedure :: reset

      procedure :: begin
      procedure :: end
   end type MeterNode


   type, extends(AbstractMeterNodeIterator) :: MeterNodeIterator
      private
      class (MeterNode), pointer :: reference => null()
      class (AbstractMeterNode), pointer :: current => null()

      ! Subiterators are allocated after iterator goes beyond the root node
      type (MeterNodeVectorIterator), allocatable :: iterator_over_children
      class (AbstractMeterNodeIterator), allocatable :: iterator_of_current_child
   contains
      procedure :: get
      procedure :: get_name => get_name_iter
      procedure :: get_meter => get_meter_iter
      procedure :: equals
      procedure :: not_equals
      procedure :: next
   end type MeterNodeIterator


   interface MeterNode
      module procedure new_MeterNode
   end interface MeterNode

   interface MeterNodeIterator
      module procedure new_MeterNodeIterator
   end interface MeterNodeIterator


   integer, parameter :: NOT_FOUND = -1

contains


   function new_MeterNode(name, meter, depth) result(tree)
      type (MeterNode) :: tree
      character(*), intent(in) :: name
      class(AbstractMeter), intent(in) :: meter
      integer, optional, intent(in) :: depth

      tree%name = name
      tree%meter = meter

      if (present(depth)) then
         tree%depth = depth
      else
         tree%depth = 0
      end if

      tree%last_child_accessed = 0

   end function new_MeterNode


   function get_meter(this) result(meter)
      class (AbstractMeter), pointer :: meter
      class (MeterNode), target, intent(in) :: this
      meter => this%meter
   end function get_meter


   function get_name(this) result(name)
      character(:), pointer :: name
      class (MeterNode), target, intent(in) :: this
      name => this%name
   end function get_name


   function get_inclusive(this) result(inclusive)
      real(kind=REAL64) :: inclusive
      class (MeterNode), intent(in) :: this
      inclusive = this%meter%get_total()
   end function get_inclusive


   function get_exclusive(this) result(exclusive)
      real(kind=REAL64) :: exclusive
      class (MeterNode), intent(in) :: this

      type (MeterNodevectorIterator) :: iter
      class (AbstractMeterNode), pointer :: child
      real(kind=REAL64) :: tmp

      ! Subtract time of submeters from time of node meter.
      ! Previously, this used 128-bit precision to avoid negative
      ! exclusive times due to roundoff. But the GNU on M1 and NVHPC do
      ! not allow REAL128. So tmp is now 64-bit and we use a max(tmp,0)
      ! below to try and cap negatives

      tmp = this%get_inclusive()

      iter = this%children%begin()
      do while (iter /= this%children%end())
         child => iter%get()
         tmp = tmp - child%get_inclusive()
         call iter%next()
      end do

      exclusive = max(tmp, 0.0_REAL64)
   end function get_exclusive


   subroutine add_child(this, name, meter)
      class(MeterNode), target, intent(inout) :: this
      character(*), intent(in) :: name
      class(AbstractMeter), intent(in) :: meter

      type (MeterNode) :: tmp
      integer :: idx

      idx = this%find_child(name)

      if (idx == NOT_FOUND) then ! really add child
         tmp = MeterNode(name, meter, this%get_depth()+1)
         call this%children%push_back(tmp)
         ! Note: last still references the previous child because we are likely
         ! to follow this call with a get_child(), which should then be the 1st child
         ! tested.
         this%last_child_accessed = this%children%size() - 1
      else
         ! node exists - makes it easier on client code to not throw
         ! an exception here.
      end if

   end subroutine add_child


   function get_depth(this) result(depth)
      integer :: depth
      class (MeterNode), intent(in) :: this
      depth = this%depth
   end function get_depth


   ! TODO:  needs return code for failure
   function get_child(this, name) result(child)
      class (AbstractMeterNode), pointer :: child
      class (MeterNode), target, intent(inout) :: this
      character(*), intent(in) :: name

      integer :: idx

      idx = this%find_child(name)
      if (idx /= NOT_FOUND) then
         child => this%children%at(idx)
         this%last_child_accessed = idx
      else
         child => null()
         this%last_child_accessed = 0
      end if

   end function get_child

   ! We search by starting just after the last child accessed.  The
   ! theory is that meters are usually accessed cyclically in the same
   ! order as they are first created.  This is why the children
   ! are stored as a vector rather than a map with the names as keys.
   integer function find_child(this, name) result(idx)
      class (MeterNode), intent(in) :: this
      character(*), intent(in) :: name

      integer :: i, ii, n
      class (AbstractMeterNode), pointer :: t

      n = this%children%size()
      do i = 1, n
         ii = 1 + mod(i + this%last_child_accessed - 1, n)
         t => this%children%at(ii)
         select type (t)
         class is (MeterNode)
            if (name == t%name) then
               idx = ii
               return
            end if
         class default
            print*,'insert error handler'
         end select
      end do

      idx = NOT_FOUND

   end function find_child

   logical function has_child(this, name)
      class (MeterNode), target, intent(in) :: this
      character(*), intent(in) :: name
      has_child = (this%find_child(name) /= NOT_FOUND)
   end function has_child


   recursive integer function get_num_nodes(this) result(num_nodes)
      class (MeterNode), target, intent(in) :: this
      type (MeterNodeVectorIterator) :: iter

      class (AbstractMeterNode), pointer :: child

      num_nodes = 1
      iter = this%children%begin()
      do while (iter /= this%children%end())
         child => iter%get()
         num_nodes = num_nodes + child%get_num_nodes()
         call iter%next()
      end do

   end function get_num_nodes


   integer function get_num_children(this) result(num_children)
      class (MeterNode), target, intent(in) :: this

      num_children = this%children%size()

   end function get_num_children



   function new_MeterNodeIterator(meter_node) result(iterator)
      type (MeterNode), target, intent(in) :: meter_node
      type (MeterNodeIterator) :: iterator

      iterator%reference => meter_node
      iterator%current => meter_node

   end function new_MeterNodeIterator


   function begin(this) result(iterator)
      class (AbstractMeterNodeIterator), allocatable :: iterator
      class (MeterNode), target, intent(in) :: this

!!$      iterator = MeterNodeIterator(this)
      allocate(iterator, source=MeterNodeIterator(this))

   end function begin



   function end(this) result(iterator)
      class (AbstractMeterNodeIterator), allocatable :: iterator
      class (MeterNode), target, intent(in) :: this

      type (MeterNodeIterator) :: tmp

      tmp = MeterNodeIterator(this)
!!$      iterator = MeterNodeIterator(this)
      iterator = tmp

      select type (q => iterator)
      class is (MeterNodeIterator)
         q%current => null()
      class default
         print*,'uh oh'
      end select

   end function end


   recursive subroutine next(this)
      class (MeterNodeIterator), intent(inout) :: this
      class (AbstractMeterNode), pointer :: current_child


      if (.not. associated(this%current)) return ! done

      if (.not. allocated(this%iterator_over_children)) then
         this%iterator_over_children = this%reference%children%begin()
         if (this%iterator_over_children /= this%reference%children%end()) then
            current_child => this%iterator_over_children%get()
            this%iterator_of_current_child = current_child%begin()
            this%current => this%iterator_of_current_child%get()
         else
            this%current => null()
         end if
      else
         call this%iterator_of_current_child%next()
         this%current => this%iterator_of_current_child%get()

         if (.not. associated(this%current)) then ! go to next child
            deallocate(this%iterator_of_current_child)
            call this%iterator_over_children%next()
            if (this%iterator_over_children == this%reference%children%end()) then ! done
               deallocate(this%iterator_over_children)
            else
               current_child => this%iterator_over_children%get()
               this%iterator_of_current_child = current_child%begin() ! always at least one node
               this%current => this%iterator_of_current_child%get()
            end if
         end if
      end if

   end subroutine next


   function get(this) result(tree)
      class (AbstractMeterNode), pointer :: tree
      class (MeterNodeIterator), target, intent(in) :: this
      tree => this%current
   end function get


   function get_meter_iter(this) result(t)
      class (AbstractMeter), pointer :: t
      class (MeterNodeIterator), intent(in) :: this
      t => this%current%get_meter()
   end function get_meter_iter


   function get_name_iter(this) result(name)
      character(:), pointer :: name
      class (MeterNodeIterator), intent(in) :: this
      name => this%current%get_name()
   end function get_name_iter


   logical function equals(a, b)
      class (MeterNodeIterator), intent(in) :: a
      class (AbstractMeterNodeIterator), intent(in) :: b


      select type (b)
      type is (MeterNodeIterator)
         equals = associated(a%reference, b%reference)
         if (.not. equals) return

         equals = associated(a%current) .eqv. associated(b%current)
         if (.not. equals) return

         if (associated(a%current)) then
            equals = associated(a%current, b%current)
            if (.not. equals) return
         end if
      class default
         equals = .false.
      end select

   end function equals


   logical function not_equals(a, b)
      class (MeterNodeIterator), intent(in) :: a
      class (AbstractMeterNodeIterator), intent(in) :: b
      not_equals = .not. (a == b)
   end function not_equals


   ! Set all meters back to 0
   recursive subroutine reset(this)
      class (MeterNode), target, intent(inout) :: this
      type (MeterNodeVectorIterator) :: iter
      class (AbstractMeterNode), pointer :: child

      call this%meter%reset

      iter = this%children%begin()
      do while (iter /= this%children%end())
         child => iter%get()
         call child%reset()
         call iter%next()
      end do

   end subroutine reset

   recursive subroutine accumulate(this, other)
      class (MeterNode), intent(inout) :: this
      class (AbstractMeterNode), target, intent(in) :: other

      class (AbstractMeterNode), pointer :: child
      class (AbstractMeterNodeIterator), allocatable :: iter
      class (AbstractMeter), pointer :: t
      character(:), pointer :: name

      ! GFortran 8.2 complains about recursive call of nonrecursive
      ! procedure (nested copy of data structure)


      name => other%get_name()
      child => this%get_child(name)
      if (associated(child)) then
         t => child%get_meter()
      else
         call this%add_child(name, this%get_meter())
         child => this%get_child(name)
         t => child%get_meter()
         call t%reset()
      end if
      call t%accumulate(other%get_meter())

      ! recurse over children of other
      iter = other%begin()
      call iter%next() ! skip top node (already handled)
      do while (iter /= other%end())
         call child%accumulate(iter%get())
         call iter%next()
      end do

   end subroutine accumulate


end module MAPL_MeterNode