profiling.F90

Go to the documentation of this file.

!! Copyright (C) 2005-2009 Heiko Appel, Florian Lorenzen, Xavier Andrade
!!
!! This program is free software; you can redistribute it and/or modify
!! it under the terms of the GNU General Public License as published by
!! the Free Software Foundation; either version 2, or (at your option)
!! any later version.
!!
!! This program is distributed in the hope that it will be useful,
!! but WITHOUT ANY WARRANTY; without even the implied warranty of
!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!! GNU General Public License for more details.
!!
!! You should have received a copy of the GNU General Public License
!! along with this program; if not, write to the Free Software
!! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
!! 02110-1301, USA.
!!
 
#include "global.h"
 
 !*/
module profiling_oct_m
  use debug_oct_m
  use global_oct_m
  use io_oct_m
  use, intrinsic :: iso_fortran_env
  use loct_oct_m
  use messages_oct_m
  use mpi_oct_m
  use parser_oct_m
  use namespace_oct_m
  use nvtx_oct_m
  use sort_oct_m
  use sphash_oct_m
  use string_oct_m
  use types_oct_m
  use varinfo_oct_m
 
  implicit none
  private
 
  public ::                             &
    profile_vars_t,                     &
    profiling_end,                      &
    profiling_init,                     &
    profiling_in,                       &
    profiling_out,                      &
    profiling_count_operations,         &
    profiling_count_transfers,          &
    profiling_memory_allocate,          &
    profiling_memory_deallocate
 
  integer, parameter ::              &
    LABEL_LENGTH = 40,               &  !< Max. number of characters of tag label.
    max_profiles = 300                  
 
  type profile_t
    private
    character(LABEL_LENGTH)  :: label
    real(real64)             :: entry_time
    real(real64)             :: total_time
    real(real64)             :: min_time
    real(real64)             :: self_time
    real(real64)             :: op_count_current
    real(real64)             :: op_count
    real(real64)             :: op_count_child
    real(real64)             :: op_count_child_current
    real(real64)             :: tr_count_current
    real(real64)             :: tr_count
    real(real64)             :: tr_count_child
    real(real64)             :: tr_count_child_current
    type(profile_t), pointer :: parent
    integer                  :: count
    logical                  :: initialized = .false.
    logical                  :: active = .false.
    logical                  :: exclude
    integer                  :: index
    logical                  :: has_child(MAX_PROFILES)
    real(real64)             :: timings(MAX_PROFILES)
  end type profile_t
 
  type profile_pointer_t
    private
    type(profile_t), pointer :: p
  end type profile_pointer_t
 
  interface profiling_count_transfers
    module procedure &
      profiling_count_tran_int,         &
      profiling_count_tran_int_8,       &
      profiling_count_tran_real_4,      &
      profiling_count_tran_real_8,      &
      profiling_count_tran_complex_4,   &
      profiling_count_tran_complex_8,   &
      profiling_count_tran_type
    module procedure &
      profiling_count_tran_int_l,         &
      profiling_count_tran_int_8_l,       &
      profiling_count_tran_real_4_l,      &
      profiling_count_tran_real_8_l,      &
      profiling_count_tran_complex_4_l,   &
      profiling_count_tran_complex_8_l,   &
      profiling_count_tran_type_l
  end interface profiling_count_transfers
 
  interface profiling_count_operations
    module procedure iprofiling_count_operations
    module procedure rprofiling_count_operations
    module procedure dprofiling_count_operations
  end interface profiling_count_operations
 
  integer, parameter, public  ::  &
    PROFILING_TIME        = 1, &
    profiling_memory      = 2, &
    profiling_memory_full = 4, &
    profiling_likwid      = 8, &
    profiling_io          = 16
 
  integer, parameter :: MAX_MEMORY_VARS = 25
 
  type profile_vars_t
    private
    integer, public          :: mode
 
    type(profile_pointer_t)  :: current
    type(profile_pointer_t)  :: profile_list(MAX_PROFILES)
    integer                  :: last_profile
 
    integer(int64)              :: alloc_count
    integer(int64)              :: dealloc_count
 
    integer(int64)              :: memory_limit = -1
    integer(int64)              :: total_memory
    integer(int64)              :: max_memory
    character(len=256)       :: max_memory_location
 
    integer(int64)              :: large_vars_size(max_memory_vars)
    character(len=256)       :: large_vars(max_memory_vars)
 
    real(real64)             :: start_time
    integer                  :: mem_iunit
 
    character(len=256)       :: output_dir
    character(len=6)         :: file_number
 
    logical                  :: all_nodes
 
    logical                  :: output_yaml
    logical                  :: output_tree
  end type profile_vars_t
 
  type(profile_vars_t), target, save, public :: prof_vars
 
  type(sphash_t), save :: profiling_map
 
contains
 
  ! ---------------------------------------------------------
  subroutine profiling_init(namespace)
    type(namespace_t),          intent(in)    :: namespace
 
    integer :: ii
 
    push_sub(profiling_init)
 
    ! FIXME: nothing is thread-safe here!
 
    !%Variable ProfilingMode
    !%Default no
    !%Type integer
    !%Section Execution::Optimization
    !%Description
    !% Use this variable to run <tt>Octopus</tt> in profiling mode. In this mode
    !% <tt>Octopus</tt> records the time spent in certain areas of the code and
    !% the number of times this code is executed. These numbers
    !% are written in <tt>./profiling.NNN/profiling.nnn</tt> with <tt>nnn</tt> being the
    !% node number (<tt>000</tt> in serial) and <tt>NNN</tt> the number of processors.
    !% This is mainly for development purposes. Note, however, that
    !% <tt>Octopus</tt> should be compiled with <tt>--disable-debug</tt> to do proper
    !% profiling. Warning: you may encounter strange results with OpenMP.
    !%Option no 0
    !% No profiling information is generated.
    !%Option prof_time 1
    !% Profile the time spent in defined profiling regions.
    !%Option prof_memory 2
    !% As well as the time, summary information on memory usage and the largest arrays are reported.
    !%Option prof_memory_full 4
    !% As well as the time and summary memory information, a
    !% log is reported of every allocation and deallocation.
    !%Option likwid 8
    !% Enable instrumentation using LIKWID.
    !%Option prof_io 16
    !% Count the number of file open and close.
    !%End
 
    call parse_variable(namespace, 'ProfilingMode', 0, prof_vars%mode)
    if (.not. varinfo_valid_option('ProfilingMode', prof_vars%mode)) then
      call messages_input_error(namespace, 'ProfilingMode')
    end if
 
    in_profiling_mode = (prof_vars%mode > 0)
    if (.not. in_profiling_mode) then
      pop_sub(profiling_init)
      return
    end if
 
    !%Variable ProfilingAllNodes
    !%Default no
    !%Type logical
    !%Section Execution::Optimization
    !%Description
    !% This variable controls whether all nodes print the time
    !% profiling output. If set to no, the default, only the root node
    !% will write the profile. If set to yes, all nodes will print it.
    !%End
 
    call parse_variable(namespace, 'ProfilingAllNodes', .false., prof_vars%all_nodes)
 
    call get_output_dir()
 
    if (bitand(prof_vars%mode, profiling_memory_full) /= 0) then
      prof_vars%mode = ior(prof_vars%mode, profiling_memory)
    end if
 
    ! initialize memory profiling
    if (bitand(prof_vars%mode, profiling_memory) /= 0) then
      prof_vars%alloc_count   = 0
      prof_vars%dealloc_count = 0
 
      prof_vars%total_memory  = 0
      prof_vars%max_memory    = 0
      prof_vars%max_memory_location = ''
      prof_vars%start_time = loct_clock()
 
      prof_vars%large_vars_size(:) = 0
      prof_vars%large_vars(:) = ''
 
      !%Variable MemoryLimit
      !%Default -1
      !%Type integer
      !%Section Execution::Optimization
      !%Description
      !% If positive, <tt>Octopus</tt> will stop if more memory than <tt>MemoryLimit</tt>
      !% is requested (in kb). Note that this variable only works when
      !% <tt>ProfilingMode = prof_memory(_full)</tt>.
      !%End
      call parse_variable(namespace, 'MemoryLimit', -1, ii)
      prof_vars%memory_limit = int(ii, int64)*1024
    end if
 
    if (bitand(prof_vars%mode, profiling_memory_full) /= 0) then
      ! make sure output directory is available before other processes try to write there
      call mpi_world%barrier()
 
      prof_vars%mem_iunit = io_open(trim(prof_vars%output_dir)//'/memory.'//prof_vars%file_number, &
        namespace, action='write')
      write(prof_vars%mem_iunit, '(5a16,a70)') 'Elapsed Time', 'Alloc/Dealloc', 'Size (words)', 'Prof Mem', &
        'Sys Mem', 'Variable Name(Filename:Line)'
    end if
 
    ! initialize time profiling
    prof_vars%last_profile = 0
    nullify(prof_vars%current%p)
 
    if (bitand(prof_vars%mode, profiling_likwid) /= 0) then
#ifdef HAVE_LIKWID
      call likwid_markerinit()
#endif
    end if
 
    !%Variable ProfilingOutputYAML
    !%Default no
    !%Type logical
    !%Section Execution::Optimization
    !%Description
    !% This variable controls whether the profiling output is additionally
    !% written to a YAML file.
    !%End
    call parse_variable(namespace, 'ProfilingOutputYAML', .false., prof_vars%output_yaml)
 
    !%Variable ProfilingOutputTree
    !%Default yes
    !%Type logical
    !%Section Execution::Optimization
    !%Description
    !% This variable controls whether the profiling output is additionally
    !% written as a tree.
    !%End
    call parse_variable(namespace, 'ProfilingOutputTree', .true., prof_vars%output_tree)
 
    call sphash_init(profiling_map)
 
    call profiling_in('COMPLETE_RUN')
 
    pop_sub(profiling_init)
 
  contains
 
    ! ---------------------------------------------------------
    subroutine get_output_dir()
 
      push_sub(profiling_init.get_output_dir)
 
      write(prof_vars%file_number, '(i6.6)') mpi_world%rank
 
      prof_vars%output_dir = 'profiling'
 
      if (mpi_world%is_root()) call io_mkdir(trim(prof_vars%output_dir), namespace)
 
      pop_sub(profiling_init.get_output_dir)
    end subroutine get_output_dir
 
  end subroutine profiling_init
 
 
  ! ---------------------------------------------------------
  subroutine profiling_end(namespace)
    type(namespace_t), intent(in) :: namespace
    integer :: ii
    real(real64), parameter :: megabyte = 1048576.0_real64
    integer(int64) :: io_open_count, io_close_count
    integer(int64) :: io_open_count_red, io_close_count_red
 
    if (.not. in_profiling_mode) return
    push_sub(profiling_end)
 
    call profiling_out('COMPLETE_RUN')
    call profiling_output(namespace)
 
    do ii = 1, prof_vars%last_profile
      prof_vars%profile_list(ii)%p%initialized = .false.
    end do
 
    call sphash_end(profiling_map)
 
    if (bitand(prof_vars%mode, profiling_memory) /= 0) then
      call messages_print_with_emphasis(msg="Memory profiling information", namespace=namespace)
      write(message(1), '(a,i10)') 'Number of   allocations = ', prof_vars%alloc_count
      write(message(2), '(a,i10)') 'Number of deallocations = ', prof_vars%dealloc_count
      write(message(3), '(a,f18.3,a)') 'Maximum total memory allocated = ', prof_vars%max_memory/megabyte, ' Mbytes'
      write(message(4), '(2x,a,a)') 'at ', trim(prof_vars%max_memory_location)
      call messages_info(4)
 
      message(1) = ''
      message(2) = 'Largest variables allocated:'
      call messages_info(2)
      do ii = 1, max_memory_vars
        write(message(1),'(i2,f18.3,2a)') ii, prof_vars%large_vars_size(ii)/megabyte, ' Mbytes ', trim(prof_vars%large_vars(ii))
        call messages_info(1)
      end do
 
      call messages_print_with_emphasis(namespace=namespace)
 
      if (prof_vars%alloc_count /= prof_vars%dealloc_count) then
        write(message(1),'(a,i10,a,i10,a)') "Not all memory was deallocated: ", prof_vars%alloc_count, &
          ' allocations and ', prof_vars%dealloc_count, ' deallocations'
        call messages_warning(1, all_nodes = .true.)
      end if
      if (prof_vars%total_memory > 0) then
        write(message(1),'(a,f18.3,a,f18.3,a)') "Remaining allocated memory: ", prof_vars%total_memory/megabyte, &
          ' Mbytes (out of maximum ', prof_vars%max_memory/megabyte, ' Mbytes)'
        call messages_warning(1, all_nodes = .true.)
      end if
    end if
 
    if (bitand(prof_vars%mode, profiling_memory_full) /= 0) then
      call io_close(prof_vars%mem_iunit)
    end if
 
    if (bitand(prof_vars%mode, profiling_likwid) /= 0) then
#ifdef HAVE_LIKWID
      call likwid_markerclose()
#endif
    end if
 
    if (bitand(prof_vars%mode, profiling_io) /= 0) then
      call messages_print_with_emphasis(msg="IO profiling information", namespace=namespace)
      io_open_count = io_get_open_count()
      io_close_count = io_get_close_count()
      write(message(1), '(a,i10)') 'Number of file open  = ', io_open_count
      write(message(2), '(a,i10)') 'Number of file close = ', io_close_count
      call mpi_world%allreduce(io_open_count, io_open_count_red, 1, mpi_integer8, mpi_sum)
      call mpi_world%allreduce(io_close_count, io_close_count_red, 1, mpi_integer8, mpi_sum)
      write(message(3), '(a,i10)') 'Global number of file open  = ', io_open_count_red
      write(message(4), '(a,i10)') 'Global number of file close = ', io_close_count_red
      call messages_info(4)
      call messages_print_with_emphasis(namespace=namespace)
    end if
 
    pop_sub(profiling_end)
  end subroutine profiling_end
 
 
  ! ---------------------------------------------------------
  subroutine profile_init(this, label)
    type(profile_t), target, intent(out)   :: this
    character(*),            intent(in)    :: label
 
    integer :: iprofile
 
    push_sub(profile_init)
 
    if(len(label) > label_length) then
      message(1) = "Label " // trim(label) // " is too long for the internal profiler"
      call messages_fatal(1)
    end if
 
    this%label = label
    this%total_time = m_zero
    this%min_time   = m_huge
    this%self_time  = m_zero
    this%entry_time = huge(this%entry_time)
    this%count  = 0
    this%op_count_current      = m_zero
    this%op_count              = m_zero
    this%op_count_child        = m_zero
    this%tr_count_current      = m_zero
    this%tr_count              = m_zero
    this%tr_count_child        = m_zero
    this%active = .false.
    nullify(this%parent)
    this%has_child = .false.
    this%timings = m_zero
    this%index = 0
 
    if (.not. in_profiling_mode) then
      pop_sub(profile_init)
      return
    end if
 
    prof_vars%last_profile = prof_vars%last_profile + 1
 
    assert(prof_vars%last_profile  <=  max_profiles)
 
    prof_vars%profile_list(prof_vars%last_profile)%p => this
    this%index = prof_vars%last_profile
    this%initialized = .true.
 
    ! print out a warning if a name is used more than once
    do iprofile = 1, prof_vars%last_profile - 1
      if (prof_vars%profile_list(iprofile)%p%label == this%label) then
        message(1) = "Label "//label//" used more than once."
        call messages_fatal(1)
        exit
      end if
    end do
 
    pop_sub(profile_init)
  end subroutine profile_init
 
 
  ! ---------------------------------------------------------
  subroutine profiling_in(label, exclude)
    character(*),               intent(in)    :: label
    logical,         optional,  intent(in)    :: exclude
 
    real(real64) :: now
    class(*), pointer :: profile_p
    type(profile_t), allocatable :: profile
    logical :: found
    character(len=len(label)) :: label_
 
    if (.not. in_profiling_mode) return
    if (.not. not_in_openmp()) return
 
    ! no PUSH_SUB, called too often
 
    label_ = to_upper(trim(label))
    profile_p => sphash_lookup(profiling_map, trim(label_), found)
    if (.not. found) then
      allocate(profile)
      call sphash_insert(profiling_map, trim(label_), profile, clone=.true.)
      deallocate(profile)
      profile_p => sphash_lookup(profiling_map, trim(label_), found)
    end if
    select type(this => profile_p)
    type is (profile_t)
      if (.not. this%initialized) then
        call profile_init(this, label_)
      end if
 
      if (this%active) then
        message(1) = " The region with label "//trim(label)//" is already active."
        message(2) = " This is likely caused by a missing or incorrect profiling_out call."
        call messages_fatal(2)
      end if
      assert(.not. this%active)
 
      this%active = .true.
      now = mpi_get_wtime()
 
      if (associated(prof_vars%current%p)) then
        !keep a pointer to the parent
        this%parent => prof_vars%current%p
        this%parent%has_child(this%index) = .true.
      else
        !we are orphans
        nullify(this%parent)
      end if
 
      this%op_count_current = m_zero
      this%tr_count_current = m_zero
      this%op_count_child_current = m_zero
      this%tr_count_child_current = m_zero
 
      prof_vars%current%p => this
      this%entry_time = now
 
      this%exclude = optional_default(exclude, .false.)
 
#if defined(HAVE_NVTX) || (defined(HAVE_HIP) && defined(__HIP_PLATFORM_AMD__))
      call nvtx_range_push(string_f_to_c(trim(label_)), this%index)
#endif
    end select
 
    if (bitand(prof_vars%mode, profiling_likwid) /= 0) then
#ifdef HAVE_LIKWID
      call likwid_markerstartregion(trim(label_))
#endif
    end if
 
  end subroutine profiling_in
 
 
  ! ---------------------------------------------------------
  subroutine profiling_out(label)
    character(*), intent(in) :: label
 
    real(real64) :: now, time_spent
    class(*), pointer :: profile_p
    logical :: found
 
    if (.not. in_profiling_mode) return
    if (.not. not_in_openmp()) return
 
    ! no PUSH_SUB, called too often
    profile_p => sphash_lookup(profiling_map, to_upper(trim(label)), found)
 
    if (.not. found) then
      message(1) = " No profiling region with label "//trim(label)//" found."
      message(2) = " This is likely caused by a missing or incorrect profiling_in call."
      call messages_fatal(2)
    end if
    assert(found)
 
    select type(this => profile_p)
    type is (profile_t)
      assert(this%initialized)
      assert(this%active)
      this%active = .false.
      now = mpi_get_wtime()
 
      time_spent = now - this%entry_time
      this%total_time = this%total_time + time_spent
      this%self_time  = this%self_time + time_spent
      this%count = this%count + 1
      if (time_spent < this%min_time) then
        this%min_time = time_spent
      end if
 
      this%op_count = this%op_count + this%op_count_current
      this%tr_count = this%tr_count + this%tr_count_current
      this%op_count_child = this%op_count_child + this%op_count_child_current
      this%tr_count_child = this%tr_count_child + this%tr_count_child_current
 
      if (associated(this%parent)) then
        !remove the spent from the self time of our parent
        this%parent%self_time = this%parent%self_time - time_spent
        if (this%exclude) this%parent%total_time = this%parent%total_time - time_spent
 
        ! add the operations to the parent
        this%parent%op_count_child_current = this%parent%op_count_child_current &
          + this%op_count_current + this%op_count_child_current
        this%parent%tr_count_child_current = this%parent%tr_count_child_current &
          + this%tr_count_current + this%tr_count_child_current
 
        this%parent%timings(this%index) = this%parent%timings(this%index) + time_spent
 
        !and set parent as current
        prof_vars%current%p => this%parent
 
      else
        nullify(prof_vars%current%p)
      end if
 
      if (bitand(prof_vars%mode, profiling_likwid) /= 0) then
#ifdef HAVE_LIKWID
        call likwid_markerstopregion(trim(this%label))
#endif
      end if
    end select
 
#if defined(HAVE_NVTX) || (defined(HAVE_HIP) && defined(__HIP_PLATFORM_AMD__))
    call nvtx_range_pop()
#endif
 
  end subroutine profiling_out
 
 
  ! ---------------------------------------------------------
 
  subroutine iprofiling_count_operations(ops)
    integer,         intent(in)    :: ops
 
    if (.not. in_profiling_mode) return
    ! no PUSH_SUB, called too often
 
    prof_vars%current%p%op_count_current = prof_vars%current%p%op_count_current + real(ops, real64)
  end subroutine iprofiling_count_operations
 
 
  ! ---------------------------------------------------------
 
  subroutine rprofiling_count_operations(ops)
    real(4),         intent(in)    :: ops
 
    if (.not. in_profiling_mode) return
    ! no PUSH_SUB, called too often
 
    prof_vars%current%p%op_count_current = prof_vars%current%p%op_count_current + real(ops, real64)
  end subroutine rprofiling_count_operations
 
 
  ! ---------------------------------------------------------
 
  subroutine dprofiling_count_operations(ops)
    real(real64),         intent(in)    :: ops
 
    if (.not. in_profiling_mode) return
    ! no PUSH_SUB, called too often
 
    prof_vars%current%p%op_count_current = prof_vars%current%p%op_count_current + ops
 
  end subroutine dprofiling_count_operations
 
 
  ! ---------------------------------------------------------
 
  subroutine profiling_count_tran_int_l(trf, type)
    integer(int64),     intent(in)    :: trf
    integer,         intent(in)    :: type
 
    if (.not. in_profiling_mode) return
    ! no PUSH_SUB, called too often
 
    prof_vars%current%p%tr_count_current = prof_vars%current%p%tr_count_current + 4*real(trf, real64)
  end subroutine profiling_count_tran_int_l
 
 
  ! ---------------------------------------------------------
 
  subroutine profiling_count_tran_int_8_l(trf, type)
    integer(int64),     intent(in)    :: trf
    integer(int64),     intent(in)    :: type
 
    if (.not. in_profiling_mode) return
    ! no PUSH_SUB, called too often
 
    prof_vars%current%p%tr_count_current = prof_vars%current%p%tr_count_current + 4*real(trf, real64)
  end subroutine profiling_count_tran_int_8_l
 
 
  ! ---------------------------------------------------------
 
  subroutine profiling_count_tran_real_4_l(trf, type)
    integer(int64),     intent(in)    :: trf
    real(4),         intent(in)    :: type
 
    if (.not. in_profiling_mode) return
    ! no PUSH_SUB, called too often
 
    prof_vars%current%p%tr_count_current = prof_vars%current%p%tr_count_current + 4*real(trf, real64)
 
  end subroutine profiling_count_tran_real_4_l
 
 
  ! ---------------------------------------------------------
 
  subroutine profiling_count_tran_real_8_l(trf, type)
    integer(int64),     intent(in)    :: trf
    real(real64),         intent(in)    :: type
 
    if (.not. in_profiling_mode) return
    ! no PUSH_SUB, called too often
 
    prof_vars%current%p%tr_count_current = prof_vars%current%p%tr_count_current + 8*real(trf, real64)
 
  end subroutine profiling_count_tran_real_8_l
 
 
  ! ---------------------------------------------------------
 
  subroutine profiling_count_tran_complex_4_l(trf, type)
    integer(int64),     intent(in)    :: trf
    complex(4),      intent(in)    :: type
 
    if (.not. in_profiling_mode) return
    ! no PUSH_SUB, called too often
 
    prof_vars%current%p%tr_count_current = prof_vars%current%p%tr_count_current + 8*real(trf, real64)
 
  end subroutine profiling_count_tran_complex_4_l
 
 
  ! ---------------------------------------------------------
 
  subroutine profiling_count_tran_complex_8_l(trf, type)
    integer(int64),     intent(in)    :: trf
    complex(real64),      intent(in)    :: type
 
    if (.not. in_profiling_mode) return
    ! no PUSH_SUB, called too often
 
    prof_vars%current%p%tr_count_current = prof_vars%current%p%tr_count_current + 16*real(trf, real64)
 
  end subroutine profiling_count_tran_complex_8_l
 
 
  ! ---------------------------------------------------------
 
  subroutine profiling_count_tran_type_l(trf, type)
    integer(int64),     intent(in)    :: trf
    type(type_t),    intent(in)    :: type
 
    if (.not. in_profiling_mode) return
    ! no PUSH_SUB, called too often
 
    prof_vars%current%p%tr_count_current = prof_vars%current%p%tr_count_current + real(trf, real64) *types_get_size(type)
 
  end subroutine profiling_count_tran_type_l
 
 
  ! ---------------------------------------------------------
 
  subroutine profiling_count_tran_int(trf, type)
    integer,         intent(in)    :: trf
    integer,         intent(in)    :: type
 
    if (.not. in_profiling_mode) return
    ! no PUSH_SUB, called too often
 
    prof_vars%current%p%tr_count_current = prof_vars%current%p%tr_count_current + 4*real(trf, real64)
  end subroutine profiling_count_tran_int
 
 
  ! ---------------------------------------------------------
 
  subroutine profiling_count_tran_int_8(trf, type)
    integer,         intent(in)    :: trf
    integer(int64),     intent(in)    :: type
 
    if (.not. in_profiling_mode) return
    ! no PUSH_SUB, called too often
 
    prof_vars%current%p%tr_count_current = prof_vars%current%p%tr_count_current + 8*real(trf, real64)
  end subroutine profiling_count_tran_int_8
 
 
  ! ---------------------------------------------------------
 
  subroutine profiling_count_tran_real_4(trf, type)
    integer,         intent(in)    :: trf
    real(4),         intent(in)    :: type
 
    if (.not. in_profiling_mode) return
    ! no PUSH_SUB, called too often
 
    prof_vars%current%p%tr_count_current = prof_vars%current%p%tr_count_current + 4*real(trf, real64)
 
  end subroutine profiling_count_tran_real_4
 
 
  ! ---------------------------------------------------------
 
  subroutine profiling_count_tran_real_8(trf, type)
    integer,         intent(in)    :: trf
    real(real64),         intent(in)    :: type
 
    if (.not. in_profiling_mode) return
    ! no PUSH_SUB, called too often
 
    prof_vars%current%p%tr_count_current = prof_vars%current%p%tr_count_current + 8*real(trf, real64)
 
  end subroutine profiling_count_tran_real_8
 
 
  ! ---------------------------------------------------------
 
  subroutine profiling_count_tran_complex_4(trf, type)
    integer,         intent(in)    :: trf
    complex(4),      intent(in)    :: type
 
    if (.not. in_profiling_mode) return
    ! no PUSH_SUB, called too often
 
    prof_vars%current%p%tr_count_current = prof_vars%current%p%tr_count_current + 8*real(trf, real64)
 
  end subroutine profiling_count_tran_complex_4
 
 
  ! ---------------------------------------------------------
 
  subroutine profiling_count_tran_complex_8(trf, type)
    integer,         intent(in)    :: trf
    complex(real64),      intent(in)    :: type
 
    if (.not. in_profiling_mode) return
    ! no PUSH_SUB, called too often
 
    prof_vars%current%p%tr_count_current = prof_vars%current%p%tr_count_current + 16*real(trf, real64)
 
  end subroutine profiling_count_tran_complex_8
 
 
  ! ---------------------------------------------------------
 
  subroutine profiling_count_tran_type(trf, type)
    integer,         intent(in)    :: trf
    type(type_t),    intent(in)    :: type
 
    if (.not. in_profiling_mode) return
    ! no PUSH_SUB, called too often
 
    prof_vars%current%p%tr_count_current = prof_vars%current%p%tr_count_current + real(trf, real64) *types_get_size(type)
 
  end subroutine profiling_count_tran_type
 
  ! ---------------------------------------------------------
  real(real64) function profile_total_time(this)
    type(profile_t), intent(in) :: this
 
    push_sub(profile_total_time)
    profile_total_time = this%total_time
 
    pop_sub(profile_total_time)
  end function profile_total_time
 
 
  ! ---------------------------------------------------------
  real(real64) function profile_self_time(this)
    type(profile_t), intent(in) :: this
 
    push_sub(profile_self_time)
    profile_self_time = this%self_time
 
    pop_sub(profile_self_time)
  end function profile_self_time
 
 
  ! ---------------------------------------------------------
  real(real64) function profile_total_time_per_call(this)
    type(profile_t), intent(in) :: this
 
    push_sub(profile_total_time_per_call)
    profile_total_time_per_call = this%total_time / real(this%count, real64)
 
    pop_sub(profile_total_time_per_call)
  end function profile_total_time_per_call
 
 
  ! ---------------------------------------------------------
  real(real64) function profile_min_time(this)
    type(profile_t), intent(in) :: this
 
    push_sub(profile_self_time)
    profile_min_time = this%min_time
 
    pop_sub(profile_self_time)
  end function profile_min_time
 
 
  ! ---------------------------------------------------------
  real(real64) function profile_self_time_per_call(this)
    type(profile_t), intent(in) :: this
 
    push_sub(profile_self_time_per_call)
    profile_self_time_per_call = this%self_time / real(this%count, real64)
 
    pop_sub(profile_self_time_per_call)
  end function profile_self_time_per_call
 
 
  ! ---------------------------------------------------------
  real(real64) function profile_total_throughput(this)
    type(profile_t), intent(in) :: this
 
    push_sub(profile_throughput)
 
    if (this%total_time > epsilon(this%total_time)) then
      profile_total_throughput = (this%op_count + this%op_count_child)/this%total_time*1.0e-6_real64
    else
      profile_total_throughput = 0.0_real64
    end if
 
    pop_sub(profile_throughput)
  end function profile_total_throughput
 
 
  ! ---------------------------------------------------------
 
  real(real64) function profile_total_bandwidth(this)
    type(profile_t), intent(in) :: this
 
    push_sub(profile_bandwidth)
 
    if (this%total_time > epsilon(this%total_time)) then
      profile_total_bandwidth = (this%tr_count + this%tr_count_child)/(this%total_time*1024.0_real64**2)
    else
      profile_total_bandwidth = 0.0_real64
    end if
 
    pop_sub(profile_bandwidth)
  end function profile_total_bandwidth
 
  ! ---------------------------------------------------------
 
  real(real64) function profile_self_throughput(this)
    type(profile_t), intent(in) :: this
 
    push_sub(profile_throughput)
 
    if (this%self_time > epsilon(this%self_time)) then
      profile_self_throughput = this%op_count/this%self_time*1.0e-6_real64
    else
      profile_self_throughput = 0.0_real64
    end if
 
    pop_sub(profile_throughput)
  end function profile_self_throughput
 
  ! ---------------------------------------------------------
 
  real(real64) function profile_self_bandwidth(this)
    type(profile_t), intent(in) :: this
 
    push_sub(profile_bandwidth)
 
    if (this%self_time > epsilon(this%self_time)) then
      profile_self_bandwidth = this%tr_count/(this%self_time*1024.0_real64**2)
    else
      profile_self_bandwidth = 0.0_real64
    end if
 
    pop_sub(profile_bandwidth)
  end function profile_self_bandwidth
 
 
  ! ---------------------------------------------------------
  integer function profile_num_calls(this)
    type(profile_t), intent(in) :: this
 
    push_sub(profile_num_calls)
    profile_num_calls = this%count
 
    pop_sub(profile_num_calls)
  end function profile_num_calls
 
 
  ! ---------------------------------------------------------
  character(LABEL_LENGTH) function profile_label(this)
    type(profile_t), intent(in) :: this
 
    push_sub(profile_label)
    profile_label = this%label
 
    pop_sub(profile_label)
  end function profile_label
 
 
  ! ---------------------------------------------------------
  subroutine profiling_output(namespace)
    type(namespace_t), intent(in) :: namespace
 
    integer          :: ii
    integer          :: iunit
    real(real64)     :: total_time
    type(profile_t), pointer :: prof
    character(len=256) :: filename
    real(real64),   allocatable :: selftime(:)
    integer, allocatable :: position(:)
    class(*), pointer :: profile_p
    logical :: found
 
    if (.not. in_profiling_mode) return
    push_sub(profiling_output)
 
    call mpi_world%barrier()
 
    if (.not. prof_vars%all_nodes .and. .not. mpi_world%is_root()) then
      pop_sub(profiling_output)
      return
    end if
 
    filename = trim(prof_vars%output_dir)//'/time.'//prof_vars%file_number
    iunit = io_open(trim(filename), namespace, action='write', die=.false.)
    if (iunit == -1) then
      message(1) = 'Failed to open file ' // trim(filename) // ' to write profiling results.'
      call messages_warning(1)
      pop_sub(profiling_output)
      return
    end if
 
    write(iunit, '(2a)')                                                                                    &
      '                                                                                   CUMULATIVE TIME                ', &
      '                 |                         SELF TIME'
    write(iunit, '(2a)')                                                                                    &
      '                                          ----------------------------------------------------------', &
      '----------------|-------------------------------------------------------------'
    write(iunit, '(2a)')                                                                                    &
      'TAG                                          NUM_CALLS      TOTAL_TIME   TIME_PER_CALL        MIN_TIME   ', &
      ' MFLOPS  MBYTES/S   %TIME |       TOTAL_TIME   TIME_PER_CALL    MFLOPS  MBYTES/S   %TIME'
    write(iunit, '(2a)')                                                                    &
      '===================================================================================================', &
      '=================|============================================================='
 
    profile_p => sphash_lookup(profiling_map, "COMPLETE_RUN", found)
    assert(found)
    select type(complete_run => profile_p)
    type is (profile_t)
      total_time = profile_total_time(complete_run)
    end select
 
    safe_allocate(selftime(1:prof_vars%last_profile))
    safe_allocate(position(1:prof_vars%last_profile))
 
    do ii = 1, prof_vars%last_profile
      selftime(ii) = -profile_self_time(prof_vars%profile_list(ii)%p)
      position(ii) = ii
    end do
 
    call sort(selftime, position)
 
    do ii = 1, prof_vars%last_profile
      prof =>  prof_vars%profile_list(position(ii))%p
      if (.not. prof%initialized) then
        write(message(1),'(a,i6,a)') "Internal error: Profile number ", position(ii), " is not initialized."
        call messages_fatal(1)
      end if
      if (prof%active) then
        write(message(1),'(a)') "Internal error: Profile '" // trim(profile_label(prof)) // &
          "' is active, i.e. profiling_out was not called."
        call messages_warning(1)
      end if
 
      if (profile_num_calls(prof) == 0) cycle
 
      write(iunit, '(a,i14,3f16.6,2f10.1,f8.1,a,2f16.6,2f10.1,f8.1)')     &
        profile_label(prof),                             &
        profile_num_calls(prof),                         &
        profile_total_time(prof),                        &
        profile_total_time_per_call(prof),               &
        profile_min_time(prof),                          &
        profile_total_throughput(prof),                  &
        profile_total_bandwidth(prof),                   &
        profile_total_time(prof)/total_time*100.0_real64, &
        ' | ',                                           &
        profile_self_time(prof),                         &
        profile_self_time_per_call(prof),                &
        profile_self_throughput(prof),                   &
        profile_self_bandwidth(prof),                    &
        profile_self_time(prof)/total_time*100.0_real64
    end do
 
    call io_close(iunit)
 
    if (prof_vars%output_yaml) then
      filename = trim(prof_vars%output_dir)//'/time.'//prof_vars%file_number//'.yaml'
      iunit = io_open(trim(filename), namespace, action='write', die=.false.)
      if (iunit == -1) then
        message(1) = 'Failed to open file ' // trim(filename) // ' to write profiling results.'
        call messages_warning(1)
        pop_sub(profiling_output)
        return
      end if
      write(iunit, '(2a)') 'schema: [num_calls, total_time, total_throughput, ', &
        'total_bandwidth, self_time, self_throughput, self_bandwidth]'
      write(iunit, '(a)') 'data:'
 
      do ii = 1, prof_vars%last_profile
        prof =>  prof_vars%profile_list(position(ii))%p
        if (profile_num_calls(prof) == 0) cycle
        write(iunit, '(a,a,a,i6,a,e10.3,a,e10.3,a,e10.3,a,e10.3,a,e10.3,a,e10.3,a)')         &
          '  ', profile_label(prof), ': [',     &
          profile_num_calls(prof),        ', ', &
          profile_total_time(prof),       ', ', &
          profile_total_throughput(prof), ', ', &
          profile_total_bandwidth(prof),  ', ', &
          profile_self_time(prof),        ', ', &
          profile_self_throughput(prof),  ', ', &
          profile_self_bandwidth(prof),   ']'
      end do
 
      call io_close(iunit)
    end if
 
    safe_deallocate_a(selftime)
    safe_deallocate_a(position)
 
    if (prof_vars%output_tree) then
      filename = trim(prof_vars%output_dir)//'/time.'//prof_vars%file_number//'.tree'
      iunit = io_open(trim(filename), namespace, action='write', die=.false.)
      if (iunit == -1) then
        message(1) = 'Failed to open file ' // trim(filename) // ' to write profiling results.'
        call messages_warning(1)
        pop_sub(profiling_output)
        return
      end if
      write(iunit, '(a40,a11,a11,a12)') &
        "Tree level, region                      ", &
        "% of total ", "% of parent", &
        "   Full time"
 
      select type(complete_run => profile_p)
      type is (profile_t)
        ! output of top-level node
        write(iunit, '(a,a25,a,f8.2,a,f8.2,a,f12.4)') &
          repeat('-', 0) // '| ', &
          profile_label(complete_run), &
          repeat(' ', 15-0-2), &
          100.0, "%  ", &
          100.0, "%  ", &
          total_time
        call output_tree_level(complete_run, 1, total_time, iunit)
      end select
      write(iunit, '(a)') "// modeline for vim to enable folding (put in ~/.vimrc: set modeline modelineexpr)"
      write(iunit, '(a)') "// vim: fdm=expr fde=getline(v\:lnum)=~'.*\|.*'?len(split(getline(v\:lnum))[0])-1\:0"
      call io_close(iunit)
    end if
 
    pop_sub(profiling_output)
  contains
    ! Traverse the tree depth-first, pre-order
    recursive subroutine output_tree_level(profile, level, total_time, iunit)
      type(profile_t), intent(in) :: profile
      integer,         intent(in) :: level
      real(real64),    intent(in) :: total_time
      integer,         intent(in) :: iunit
 
      integer :: ichild, width
 
      push_sub(profiling_output.output_tree_level)
      width = 15
      ! loop over children
      do ichild = 1, max_profiles
        if (profile%has_child(ichild)) then
          ! print out information on current child with the first marker
          ! placed according to the level of the tree
          write(iunit, '(a,a25,a,f8.2,a,f8.2,a,f12.4)') &
            repeat('-', level) // '| ', &
            profile_label(prof_vars%profile_list(ichild)%p), &
            repeat(' ', width-level-2), &
            profile%timings(ichild)/total_time * 100, "%  ", &
            profile%timings(ichild)/profile%total_time * 100, "%  ", &
            profile%timings(ichild)
          call output_tree_level(prof_vars%profile_list(ichild)%p, &
            level+1, total_time, iunit)
        end if
      end do
      pop_sub(profiling_output.output_tree_level)
    end subroutine output_tree_level
  end subroutine profiling_output
 
 
  ! ---------------------------------------------------------
  subroutine profiling_make_position_str(var, file, line, str)
    character(len=*), intent(in)  :: var
    character(len=*), intent(in)  :: file
    integer,          intent(in)  :: line
    character(len=*), intent(out) :: str
 
    integer            :: ii, jj, nn
 
    ! no push_sub, called too many times
 
    jj = len(var)
    if (var(jj:jj) == ')') then
      nn = 1
      do ii = len(var)-1, 1, -1
        jj = ii - 1
        if (var(ii:ii) == ')') nn = nn + 1
        if (var(ii:ii) == '(') nn = nn - 1
        if (nn == 0) exit
      end do
      if (jj == 0) then
        message(1) = "Internal Error in profiling_memory_log"
        call messages_fatal(1)
      end if
    end if
    ii = index(file, '/', back=.true.)+1
 
    write(str, '(4a,i5,a)') var(1:jj), "(", trim(file(ii:len(file))), ":", line, ")"
    call compact(str)
 
  end subroutine profiling_make_position_str
 
 
  ! ---------------------------------------------------------
  subroutine profiling_memory_log(type, var, file, line, size)
    character(len=*), intent(in) :: type
    character(len=*), intent(in) :: var
    character(len=*), intent(in) :: file
    integer,          intent(in) :: line
    integer(int64),      intent(in) :: size
 
    character(len=256) :: str
    integer(int64) :: mem
 
    ! no push_sub, called too many times
 
    call profiling_make_position_str(var, file, line, str)
 
    ! get number of pages
    mem = loct_get_memory_usage()
 
    write(prof_vars%mem_iunit, '(f16.6,a16,3i16,a70)') loct_clock() - prof_vars%start_time, &
      trim(type), size, prof_vars%total_memory, mem, trim(str)
 
  end subroutine profiling_memory_log
 
 
  !-----------------------------------------------------
  subroutine profiling_memory_allocate(var, file, line, size_)
    character(len=*), intent(in) :: var
    character(len=*), intent(in) :: file
    integer,          intent(in) :: line
    integer(int64),      intent(in) :: size_
 
    integer :: ii, jj
    integer(int64) :: size
    character(len=256) :: str
 
    ! no push_sub, called too many times
 
    size = size_ ! make a copy that we can change
 
    prof_vars%alloc_count  = prof_vars%alloc_count + 1
    prof_vars%total_memory = prof_vars%total_memory + size
 
    if (bitand(prof_vars%mode, profiling_memory_full) /= 0) then
      call profiling_memory_log('A ', var, file, line, size)
    end if
 
    if (prof_vars%memory_limit > 0) then
      if (prof_vars%total_memory > prof_vars%memory_limit) then
        message(1) = "Memory limit set in the input file was passed"
        call messages_fatal(1)
      end if
    end if
 
    if (prof_vars%total_memory > prof_vars%max_memory) then
      prof_vars%max_memory = prof_vars%total_memory
      call profiling_make_position_str(var, file, line, prof_vars%max_memory_location)
    end if
 
    call profiling_make_position_str(var, file, line, str)
 
    ! check if variable is already in stack
    do ii = 1, max_memory_vars
      if (str == prof_vars%large_vars(ii)) then
        if (size > prof_vars%large_vars_size(ii)) then
          ! delete variable by moving stack up
          do jj = ii,  max_memory_vars - 1
            prof_vars%large_vars(jj)      = prof_vars%large_vars(jj + 1)
            prof_vars%large_vars_size(jj) = prof_vars%large_vars_size(jj + 1)
          end do
          prof_vars%large_vars(max_memory_vars) = ""
          prof_vars%large_vars_size(max_memory_vars) = 0
        else
          ! do not consider this variable any longer
          size = -1
        end if
        exit
      end if
    end do
 
    do ii = 1, max_memory_vars
      if (size > prof_vars%large_vars_size(ii)) then
        ! move the stack one position down
        do jj = max_memory_vars, ii + 1,  -1
          prof_vars%large_vars(jj)      = prof_vars%large_vars(jj - 1)
          prof_vars%large_vars_size(jj) = prof_vars%large_vars_size(jj - 1)
        end do
        prof_vars%large_vars_size(ii) = size
        prof_vars%large_vars(ii) = str
        exit
      end if
    end do
 
  end subroutine profiling_memory_allocate
 
 
  !-----------------------------------------------------
  subroutine profiling_memory_deallocate(var, file, line, size)
    character(len=*), intent(in) :: var
    character(len=*), intent(in) :: file
    integer,          intent(in) :: line
    integer(int64),      intent(in) :: size
 
    ! no push_sub, called too many times
 
    prof_vars%dealloc_count  = prof_vars%dealloc_count + 1
    prof_vars%total_memory   = prof_vars%total_memory - size
 
    if (bitand(prof_vars%mode, profiling_memory_full) /= 0) then
      call profiling_memory_log('D ', var, file, line, -size)
    end if
 
  end subroutine profiling_memory_deallocate
 
 
  ! string handling functions from fortran stdlib, licensed unter MIT,
  ! available at https://github.com/fortran-lang/stdlib
  ! Returns the corresponding uppercase letter, if `c_in` is a lowercase
  ! ASCII character, otherwise `c` itself.
  pure function char_to_upper(c_in) result(c_out)
    character(len=1), intent(in) :: c_in
    character(len=1)             :: c_out
 
    integer, parameter :: difference=iachar('a')-iachar('A'), la=iachar('a'), lz=iachar('z')
    integer :: ascii_decimal
 
    ! no push_sub/pop_sub, called too often
    ascii_decimal = iachar(c_in)
    if (ascii_decimal >= la .and. ascii_decimal <= lz) then
      ascii_decimal = ascii_decimal - difference
    end if
    c_out = achar(ascii_decimal)
  end function char_to_upper
 
  ! Convert string to upper case
  pure function to_upper(string) result(upper_string)
    character(len=*), intent(in) :: string
    character(len=len(string))   :: upper_string
 
    integer :: i
 
    ! no push_sub/pop_sub, called too often
    do i = 1, len(string)
      upper_string(i:i) = char_to_upper(string(i:i))
    end do
  end function to_upper
end module profiling_oct_m
 
!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End: