interaction_partner.F90

Go to the documentation of this file.

!! Copyright (C) 2020 M. Oliveira
!!
!! 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 interaction_partner_oct_m
  use debug_oct_m
  use global_oct_m
  use interaction_surrogate_oct_m
  use iteration_counter_oct_m
  use linked_list_oct_m
  use messages_oct_m
  use multisystem_debug_oct_m
  use namespace_oct_m
  use quantity_oct_m
  implicit none
 
  private
  public ::                &
    interaction_partner_t, &
    partner_list_t,        &
    partner_iterator_t
 
  integer, parameter, public ::   &
    COUPLINGS_UNDEFINED      = 0, &
    couplings_behind_in_time = 1, &
    couplings_on_time        = 2, &
    couplings_ahead_in_time  = 3
 
  type, abstract :: interaction_partner_t
    private
    type(namespace_t), public :: namespace
 
    integer, allocatable, public :: supported_interactions_as_partner(:)
 
    type(quantity_list_t), public :: quantities
  contains
    procedure :: add_partners_to_list => interaction_partner_add_partners_to_list
    procedure :: update_quantity  => interaction_partner_update_quantity
    
    procedure :: update_on_demand_quantity => interaction_partner_update_on_demand_quantity
    
    procedure :: update_on_demand_quantities  => interaction_partner_update_on_demand_quantities
    
    procedure :: check_couplings_status  => interaction_partner_check_couplings_status
    
    procedure(interaction_partner_init_interaction_as_partner),    deferred :: init_interaction_as_partner
    
    procedure(interaction_partner_copy_quantities_to_interaction), deferred :: copy_quantities_to_interaction
    
  end type interaction_partner_t
 
  abstract interface
    ! ---------------------------------------------------------
    subroutine interaction_partner_init_interaction_as_partner(partner, interaction)
      import interaction_partner_t
      import interaction_surrogate_t
      class(interaction_partner_t),     intent(in)    :: partner
      class(interaction_surrogate_t),   intent(inout) :: interaction
    end subroutine interaction_partner_init_interaction_as_partner
 
    ! ---------------------------------------------------------
    subroutine interaction_partner_copy_quantities_to_interaction(partner, interaction)
      import interaction_partner_t
      import interaction_surrogate_t
      class(interaction_partner_t),     intent(inout) :: partner
      class(interaction_surrogate_t),   intent(inout) :: interaction
    end subroutine interaction_partner_copy_quantities_to_interaction
 
  end interface
 
  type, extends(linked_list_t) :: partner_list_t
    private
  contains
    procedure :: add => partner_list_add_node 
  end type partner_list_t
 
  type, extends(linked_list_iterator_t) :: partner_iterator_t
    private
  contains
    procedure :: get_next => partner_iterator_get_next 
  end type partner_iterator_t
 
contains
 
  ! ---------------------------------------------------------
  recursive subroutine interaction_partner_add_partners_to_list(this, list, interaction_type)
    class(interaction_partner_t),           intent(in)    :: this
    class(partner_list_t),                  intent(inout) :: list
    integer,                      optional, intent(in)    :: interaction_type
 
    if (present(interaction_type)) then
      if (any(this%supported_interactions_as_partner == interaction_type)) then
        call list%add(this)
      end if
    else
      call list%add(this)
    end if
 
  end subroutine interaction_partner_add_partners_to_list
 
  ! ---------------------------------------------------------
  subroutine interaction_partner_update_quantity(this, label)
    class(interaction_partner_t), intent(inout) :: this
    character(len=*),             intent(in)    :: label
 
    push_sub(interaction_partner_update_quantity)
 
    write(message(1), '(a,a,a,a,a)') 'Interation partner "', trim(this%namespace%get()), &
      '"does not know how to update quantity"', trim(label), '".'
    call messages_fatal(1, namespace=this%namespace)
 
    pop_sub(interaction_partner_update_quantity)
  end subroutine interaction_partner_update_quantity
 
  !! NOTE: here we update the quantity to be exactly at
  !! requested_iteration. This is different than what is done in
  !! interaction_partner_update_on_demand_quantities and it means the caller
  !! needs to pass the correct requested_iteration.
  recursive subroutine interaction_partner_update_on_demand_quantity(this, quantity, requested_iteration)
    class(interaction_partner_t), intent(inout) :: this
 
    type(quantity_t),             intent(inout) :: quantity
    class(iteration_counter_t),   intent(in)    :: requested_iteration
 
    integer :: i
    type(quantity_t), pointer :: parent
 
    ! Before updating this quantity, we also need to update its parents
    do i = 1, size(quantity%parents)
      parent => this%quantities%get(quantity%parents(i))
 
      ! We are only allowed to update on demand quantities that are behind the requested iteration
      if (parent%iteration >= requested_iteration .or. .not. parent%updated_on_demand) cycle
 
      call this%update_on_demand_quantity(parent, requested_iteration)
    end do
 
    ! If all parents are at the requested time, we can proceed with updating the quantity itself
    ! Note that here we ignore quantities that are available at any time.
    if (all(this%quantities%iteration_equal(quantity%parents, requested_iteration) .or. &
      this%quantities%always_available(quantity%parents))) then
 
      quantity%iteration = requested_iteration
      call multisystem_debug_write_marker(this%namespace, event_iteration_update_t("quantity", quantity%label, &
        quantity%iteration, "set"))
      call this%update_quantity(quantity%label)
    end if
 
  end subroutine interaction_partner_update_on_demand_quantity
 
 
  ! ---------------------------------------------------------
  subroutine interaction_partner_update_on_demand_quantities(this, labels, requested_iteration, retardation_allowed)
    class(interaction_partner_t), target, intent(inout) :: this
    character(len=*),                     intent(in)    :: labels(:)
    class(iteration_counter_t),           intent(in)    :: requested_iteration
    logical,                              intent(in)    :: retardation_allowed
 
    integer :: iq
    type(quantity_t), pointer :: quantity
 
    do iq = 1, size(labels)
      ! Get a pointer to the quantity
      quantity => this%quantities%get(labels(iq))
 
      ! We are only updating on demand quantities that are behind the requested iteration
      if (quantity%iteration >= requested_iteration .or. .not. quantity%updated_on_demand) cycle
 
      if (quantity%always_available) then
        ! We set the quantity iteration to the requested one, so that the partner
        ! can use this information when updating the quantity
        call this%update_on_demand_quantity(quantity, requested_iteration)
 
      else if (quantity%iteration + 1 <= requested_iteration .or. &
        (retardation_allowed .and. quantity%iteration + 1 > requested_iteration)) then
        ! We can update because the partner will reach this iteration in the next algorithmic step
        ! For retarded interactions, we need to allow the quantity to get ahead by one iteration
        call this%update_on_demand_quantity(quantity, quantity%iteration + 1)
 
      end if
    end do
 
  end subroutine interaction_partner_update_on_demand_quantities
 
  ! ---------------------------------------------------------
  integer function interaction_partner_check_couplings_status(this, couplings, requested_iteration) result(status)
    class(interaction_partner_t), intent(inout) :: this
    character(len=*),             intent(in)    :: couplings(:)
    class(iteration_counter_t),   intent(in)    :: requested_iteration
 
    type(quantity_t), pointer :: coupling
    integer :: i, ahead, on_time, relevant_couplings
    character(len=200) :: marker_info
    character(len=20) :: status_string
    type(event_handle_t) :: debug_handle
 
 
    push_sub(interaction_partner_check_couplings_status)
 
    debug_handle = multisystem_debug_write_event_in(system_namespace = this%namespace, &
      event = event_function_call_t("check_couplings_status"), &
      requested_iteration = requested_iteration)
 
 
    ! Count couplings on time and ahead
    on_time = 0
    ahead = 0
    relevant_couplings = 0
    do i = 1, size(couplings)
      coupling => this%quantities%get(couplings(i))
 
      ! Couplings that are available at any time do not affect the status, so we will ignore them
      if (coupling%always_available) cycle
 
      relevant_couplings = relevant_couplings + 1
      if (coupling%iteration == requested_iteration) on_time = on_time + 1
      if (coupling%iteration > requested_iteration) ahead = ahead + 1
    end do
 
    ! Determine status
    if (on_time > 0 .and. ahead > 0) then
      status = couplings_undefined
      status_string = "UNDEFINED"
    else if (on_time + ahead < relevant_couplings) then
      status = couplings_behind_in_time
      status_string = "BEHIND"
    else if (on_time == relevant_couplings) then
      status = couplings_on_time
      status_string = "ON_TIME"
    else if (ahead == relevant_couplings) then
      status = couplings_ahead_in_time
      status_string = "AHEAD"
    end if
 
    write(marker_info, '(A20," check_couplings_status: ahead = ",I5,", on_time = ",I5,", relevant = ",I5, ", status = ",A9)') &
      trim(this%namespace%get()), ahead, on_time, relevant_couplings, trim(status_string)
    call multisystem_debug_write_event_out(debug_handle, extra=marker_info, requested_iteration=requested_iteration)
 
    pop_sub(interaction_partner_check_couplings_status)
  end function interaction_partner_check_couplings_status
 
  ! ---------------------------------------------------------
  subroutine partner_list_add_node(this, partner)
    class(partner_list_t)                :: this
    class(interaction_partner_t), target :: partner
 
    push_sub(partner_list_add_node)
 
    call this%add_ptr(partner)
 
    pop_sub(partner_list_add_node)
  end subroutine partner_list_add_node
 
  ! ---------------------------------------------------------
  function partner_iterator_get_next(this) result(partner)
    class(partner_iterator_t),    intent(inout) :: this
    class(interaction_partner_t), pointer       :: partner
 
    push_sub(partner_iterator_get_next)
 
    select type (ptr => this%get_next_ptr())
    class is (interaction_partner_t)
      partner => ptr
    class default
      assert(.false.)
    end select
 
    pop_sub(partner_iterator_get_next)
  end function partner_iterator_get_next
 
end module interaction_partner_oct_m
 
!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End: