multisystem_debug.F90

Go to the documentation of this file.

!! Copyright (C) 2021 M. Lueders
!!
!! This Source Code Form is subject to the terms of the Mozilla Public
!! License, v. 2.0. If a copy of the MPL was not distributed with this
!! file, You can obtain one at https://mozilla.org/MPL/2.0/.
!!
 
#include "global.h"
 
module multisystem_debug_oct_m
  use algorithm_oct_m
  use debug_oct_m
  use global_oct_m
  use io_oct_m
  use iteration_counter_oct_m
  use mpi_oct_m
  use namespace_oct_m
  use profiling_oct_m
 
  implicit none
 
  private
 
  public &
    multisystem_debug_init,            &
    multisystem_debug_end,             &
    multisystem_debug_write_marker,    &
    multisystem_debug_write_event_in,  &
    multisystem_debug_write_event_out, &
    event_info_t,                      &
    event_function_call_t,             &
    event_iteration_update_t,              &
    event_marker_t,                    &
    event_handle_t
 
  integer, parameter, public :: MAX_INFO_LEN = 256
 
 
  !-------------------------------------------------------------------
 
  type, abstract :: event_info_t
    private
  contains
    procedure(event_info_get_info),  deferred :: get_info
  end type event_info_t
 
  abstract interface
 
    function event_info_get_info(this) result(result)
      import event_info_t
      import max_info_len
      class(event_info_t), intent(in) :: this
      character(len=MAX_INFO_LEN)     :: result
    end function  event_info_get_info
 
  end interface
 
  !-------------------------------------------------------------------
 
  type, extends(event_info_t) :: event_function_call_t
    private
    character(len=MAX_INFO_LEN) :: function_name
    character(len=ALGO_LABEL_LEN) :: op_label
  contains
    procedure :: get_info => event_function_call_get_info
  end type event_function_call_t
 
  interface event_function_call_t
    procedure :: event_function_call_constructor
  end interface event_function_call_t
 
  !-------------------------------------------------------------------
 
  type, extends(event_info_t) :: event_iteration_update_t
    private
    character(len=MAX_INFO_LEN) :: name
    character(len=MAX_INFO_LEN) :: detail
    class(iteration_counter_t), allocatable :: iteration
    character(len=MAX_INFO_LEN) :: action
  contains
    procedure :: get_info => event_iteration_update_get_info
  end type event_iteration_update_t
 
  interface event_iteration_update_t
    procedure :: event_iteration_update_constructor
  end interface event_iteration_update_t
 
  !-------------------------------------------------------------------
 
  type, extends(event_info_t) :: event_marker_t
    private
    character(len=MAX_INFO_LEN) :: text
  contains
    procedure :: get_info => event_marker_get_info
  end type event_marker_t
 
  interface event_marker_t
    procedure :: event_marker_constructor
  end interface event_marker_t
 
  !-------------------------------------------------------------------
 
  type :: event_handle_t
    private
    integer, public :: enter_ID
  end type event_handle_t
 
  interface event_handle_t
    procedure :: event_handle_constructor
  end interface event_handle_t
 
  !-------------------------------------------------------------------
 
  type(mpi_grp_t) :: mpi_grp
  integer iunit
  integer event_ID
 
contains
 
 
  function event_handle_constructor(id) result(handle)
    integer, intent(in)                               :: id
    type(event_handle_t)                              :: handle
 
    push_sub(event_handle_constructor)
 
    handle%enter_ID = id
 
    pop_sub(event_handle_constructor)
  end function event_handle_constructor
  !-------------------------------------------------------------------
 
  function event_function_call_constructor(name, op) result(event)
    character(*),                   intent(in)           :: name
    type(algorithmic_operation_t),  intent(in), optional :: op
    type(event_function_call_t)                          :: event
 
    push_sub(event_function_call_constructor)
 
    event%function_name = name
 
    if (present(op)) then
      event%op_label = op%label
    else
      event%op_label = "NULL"
    end if
 
    pop_sub(event_function_call_constructor)
  end function event_function_call_constructor
 
 
  function event_function_call_get_info(this) result(info)
    class(event_function_call_t), intent(in) :: this
    character(len=MAX_INFO_LEN)  :: info
 
    push_sub(event_function_call_get_info)
 
    info = "type: function_call | function: " // trim(this%function_name)
    if (this%op_label /= "NULL") then
      info = trim(info) // " | operation: " // trim(this%op_label)
    end if
 
    pop_sub(event_function_call_get_info)
  end function event_function_call_get_info
 
  !-------------------------------------------------------------------
 
  function event_iteration_update_constructor(name, detail, iteration, action) result(event)
    character(*),               intent(in) :: name
    character(*),               intent(in) :: detail
    class(iteration_counter_t), intent(in) :: iteration
    character(len=*),           intent(in) :: action
    type(event_iteration_update_t)   :: event
 
    push_sub(event_function_call_constructor)
 
    event%iteration = iteration
    event%name = name
    event%detail = detail
    event%action = action
 
    pop_sub(event_function_call_constructor)
  end function event_iteration_update_constructor
 
 
  function event_iteration_update_get_info(this) result(info)
    class(event_iteration_update_t), intent(in) :: this
    character(len=MAX_INFO_LEN)  :: info
 
    push_sub(event_function_call_get_info)
 
    write(info, '("type: clock_update | clock_name: ",a," | clock_detail: ",a," | clock: ",E15.5," | action: ",a)') &
      trim(this%name), trim(this%detail), this%iteration%value(), trim(this%action)
 
    pop_sub(event_function_call_get_info)
  end function event_iteration_update_get_info
 
  !-------------------------------------------------------------------
 
  function event_marker_constructor(text) result(event)
    character(*),  intent(in)   :: text
    type(event_marker_t)  :: event
 
    push_sub(event_function_call_constructor)
 
    event%text = text
 
    pop_sub(event_function_call_constructor)
  end function event_marker_constructor
 
 
  function event_marker_get_info(this) result(info)
    class(event_marker_t), intent(in) :: this
    character(len=MAX_INFO_LEN)  :: info
 
    push_sub(event_function_call_get_info)
 
    write(info, '("type: marker | text: ",a)') trim(this%text)
 
    pop_sub(event_function_call_get_info)
  end function event_marker_get_info
 
  !-------------------------------------------------------------------
 
  subroutine multisystem_debug_init(filename, namespace, group)
    character(*),      intent(in)      :: filename
    type(namespace_t), intent(in)      :: namespace
    type(mpi_grp_t),   intent(in)      :: group
 
    push_sub(multisystem_debug_init)
 
    mpi_grp = group
 
    event_id = 0
    if (debug%propagation_graph .and. mpi_grp%is_root()) then
      iunit = io_open(filename, namespace, action="write", status="unknown")
    end if
 
    pop_sub(multisystem_debug_init)
  end subroutine multisystem_debug_init
 
  subroutine multisystem_debug_end()
 
    push_sub(multisystem_debug_end)
 
    if (debug%propagation_graph .and. mpi_grp%is_root()) then
      call io_close(iunit)
    end if
 
    pop_sub(multisystem_debug_end)
  end subroutine multisystem_debug_end
 
 
  subroutine multisystem_debug_write_marker(system_namespace, event)
 
    class(namespace_t),  intent(in), optional           :: system_namespace
    class(event_info_t), intent(in)                     :: event
 
    character(len = MAX_NAMESPACE_LEN) ::  system_name
 
    push_sub(multisystem_debug_write_marker)
 
    if (debug%propagation_graph .and. mpi_grp%is_root()) then
 
      if (present(system_namespace)) then
        system_name = '.'//trim(system_namespace%get())
        if (system_name == '.') system_name = ''
      else
        system_name = 'KEEP'
      end if
 
      write(iunit, '("MARKER:   ",I10," | system: ",a,"| ",a)' , advance='yes') event_id, &
        trim(system_name), trim(event%get_info())
      event_id = event_id + 1
 
    end if
 
    pop_sub(multisystem_debug_write_marker)
 
  end subroutine multisystem_debug_write_marker
 
  function multisystem_debug_write_event_in(system_namespace, event, extra,  system_iteration, algo_iteration, &
    interaction_iteration, partner_iteration, requested_iteration) result(handle)
    class(namespace_t),  intent(in), optional           :: system_namespace
    class(event_info_t), intent(in)                     :: event
    character(*), optional                              :: extra
    class(iteration_counter_t), intent(in), optional                 :: system_iteration
    class(iteration_counter_t), intent(in), optional                 :: algo_iteration
    class(iteration_counter_t), intent(in), optional                 :: interaction_iteration
    class(iteration_counter_t), intent(in), optional                 :: partner_iteration
    class(iteration_counter_t), intent(in), optional                 :: requested_iteration
    type(event_handle_t)         :: handle
 
    character(len = MAX_NAMESPACE_LEN) ::  system_name
 
    push_sub(multisystem_debug_write_event_in)
 
    if (debug%propagation_graph .and. mpi_grp%is_root()) then
 
      if (present(system_namespace)) then
        system_name = '.'//trim(system_namespace%get())
        if (system_name == '.') system_name = ''
      else
        system_name = 'KEEP'
      end if
 
      handle = event_handle_t(event_id)
 
      write(iunit, '("IN  step: ",I10," | system: ",a,"| ",a)' , advance='no') event_id, trim(system_name), trim(event%get_info())
 
      if (present(extra)) then
        write(iunit, '(" | ",a)' , advance='no')  trim(extra)
      end if
 
      if (present(system_iteration)) then
        write(iunit, '(" | system_clock:", E15.5)' , advance='no')  system_iteration%value()
      end if
 
      if (present(algo_iteration)) then
        write(iunit, '(" | algo_clock:", E15.5)' , advance='no')  algo_iteration%value()
      end if
 
      if (present(interaction_iteration)) then
        write(iunit, '(" | interaction_clock:", E15.5)' , advance='no')  interaction_iteration%value()
      end if
 
      if (present(partner_iteration)) then
        write(iunit, '(" | partner_clock:", E15.5)' , advance='no')  partner_iteration%value()
      end if
 
      if (present(requested_iteration)) then
        write(iunit, '(" | requested_clock:", E15.5)' , advance='no')  requested_iteration%value()
      end if
 
      write(iunit, '()' , advance='yes')
 
      event_id = event_id + 1
 
    end if
 
    pop_sub(multisystem_debug_write_event_in)
  end function multisystem_debug_write_event_in
 
  subroutine multisystem_debug_write_event_out(handle, extra, update, system_iteration, algo_iteration, &
    interaction_iteration, partner_iteration, requested_iteration)
    class(event_handle_t),      intent(in)            :: handle
    character(*),                           optional  :: extra
    logical,                                optional  :: update
    class(iteration_counter_t), intent(in), optional  :: system_iteration
    class(iteration_counter_t), intent(in), optional  :: algo_iteration
    class(iteration_counter_t), intent(in), optional  :: interaction_iteration
    class(iteration_counter_t), intent(in), optional  :: partner_iteration
    class(iteration_counter_t), intent(in), optional  :: requested_iteration
 
    character(17)                        :: update_string
 
    push_sub(multisystem_debug_write_event_out)
 
    if (debug%propagation_graph .and. mpi_grp%is_root()) then
 
      if (present(update)) then
        if (update) then
          update_string = " | updated: true"
        else
          update_string = " | updated: false"
        end if
      else
        update_string = ""
      end if
 
      write(iunit, '("OUT step: ",I10," | closes: ",I10)', advance='no')  &
        event_id, handle%enter_ID
 
      if (present(update)) then
        if (update) then
          write(iunit, '(" | updated: true")', advance='no')
        else
          write(iunit, '(" | updated: false")', advance='no')
        end if
      end if
 
      if (present(extra)) then
        write(iunit, '(" | ",a)' , advance='no')  trim(extra)
      end if
 
      if (present(system_iteration)) then
        write(iunit, '(" | system_clock:", E15.5)' , advance='no')  system_iteration%value()
      end if
 
      if (present(algo_iteration)) then
        write(iunit, '(" | prop_clock:", E15.5)' , advance='no')  algo_iteration%value()
      end if
 
      if (present(interaction_iteration)) then
        write(iunit, '(" | interaction_clock:", E15.5)' , advance='no')  interaction_iteration%value()
      end if
 
      if (present(partner_iteration)) then
        write(iunit, '(" | partner_clock:", E15.5)' , advance='no')  partner_iteration%value()
      end if
 
      if (present(requested_iteration)) then
        write(iunit, '(" | requested_clock:", E15.5)' , advance='no')  requested_iteration%value()
      end if
 
      write(iunit, '()' , advance='yes')
 
      event_id = event_id + 1
 
    end if
 
 
    pop_sub(multisystem_debug_write_event_out)
  end subroutine multisystem_debug_write_event_out
 
end module multisystem_debug_oct_m