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
 
    type(integer_list_t), public :: supported_interactions_as_partner
 
    type(quantity_t),  public :: quantities(MAX_QUANTITIES)
  contains
    procedure :: update_quantity  => interaction_partner_update_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
 
  ! ---------------------------------------------------------
  subroutine interaction_partner_update_quantity(this, iq)
    class(interaction_partner_t), intent(inout) :: this
    integer,                      intent(in)    :: iq
 
    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(quantity_label(iq)), '".'
    call messages_fatal(1, namespace=this%namespace)
 
    pop_sub(interaction_partner_update_quantity)
  end subroutine interaction_partner_update_quantity
 
  ! ---------------------------------------------------------
  subroutine interaction_partner_update_on_demand_quantities(this, quantities, requested_iteration, retardation_allowed)
    class(interaction_partner_t), target, intent(inout) :: this
    integer,                              intent(in)    :: quantities(:)
    class(iteration_counter_t),           intent(in)    :: requested_iteration
    logical,                              intent(in)    :: retardation_allowed
 
    integer :: iq, q_id
    type(quantity_t), pointer :: quantity
 
    do iq = 1, size(quantities)
      ! Get the requested quantity ID and a shortcut to the quantity
      q_id = quantities(iq)
      quantity => this%quantities(q_id)
 
      ! 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
        quantity%iteration = requested_iteration
 
        call multisystem_debug_write_marker(this%namespace, event_iteration_update_t("quantity", quantity_label(q_id), &
          quantity%iteration, "set"))
        call this%update_quantity(q_id)
 
      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
        quantity%iteration = quantity%iteration + 1
 
        call multisystem_debug_write_marker(this%namespace, event_iteration_update_t("quantity", quantity_label(q_id), &
          quantity%iteration, "set"))
        call this%update_quantity(q_id)
      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
    integer,                      intent(in)    :: couplings(:)
    class(iteration_counter_t),   intent(in)    :: requested_iteration
 
    integer, allocatable :: relevant_couplings(:)
    integer :: ahead, on_time
 
    push_sub(interaction_partner_check_couplings_status)
 
    ! Couplings that are available at any time do not affect the status, so we will ignore them
    relevant_couplings = pack(couplings, .not. this%quantities(couplings)%always_available)
 
    ! Count couplings behind, on time and ahead
    on_time = count(this%quantities(relevant_couplings)%iteration == requested_iteration)
    ahead = count(this%quantities(relevant_couplings)%iteration > requested_iteration)
 
    ! Determine status
    if (on_time > 0 .and. ahead > 0) then
      status = couplings_undefined
    else if (on_time + ahead < size(relevant_couplings)) then
      status = couplings_behind_in_time
    else if (on_time == size(relevant_couplings)) then
      status = couplings_on_time
    else if (ahead == size(relevant_couplings)) then
      status = couplings_ahead_in_time
    end if
 
    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: