interaction.F90

Go to the documentation of this file.

!! Copyright (C) 2020-2023 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_oct_m
  use debug_oct_m
  use global_oct_m
  use interaction_surrogate_oct_m
  use interaction_partner_oct_m
  use iteration_counter_oct_m
  use linked_list_oct_m
  use multisystem_debug_oct_m
  use namespace_oct_m
  use profiling_oct_m
  use quantity_oct_m
  implicit none
 
  private
  public ::                 &
    interaction_t,          &
    interaction_end,        &
    interaction_list_t,     &
    interaction_iterator_t
 
  integer, parameter, public :: &
    TIMING_EXACT    = 1,        &
    timing_retarded = 2
 
  !
  type, extends(interaction_surrogate_t), abstract :: interaction_t
    ! General information about the interaction
    type(iteration_counter_t)     :: iteration
    character(len=:), allocatable :: label
    logical                       :: intra_interaction
    integer                       :: timing
    real(real64)                  :: energy
 
    ! The interaction requires access to some quantities from a system to be evaluated.
    integer, allocatable :: system_quantities(:)
 
    ! Information regarding the partner
    class(interaction_partner_t), pointer     :: partner => null()
    integer,                      allocatable :: couplings_from_partner(:)
    logical                                   :: partner_couplings_up_to_date = .false. 
 
  contains
    procedure(interaction_calculate), deferred :: calculate
    procedure(interaction_calculate_energy), deferred :: calculate_energy
    procedure :: update => interaction_update 
    procedure :: update_partner_couplings => interaction_update_partner_couplings 
    procedure :: restart_read => interaction_restart_read   
    procedure :: restart_write => interaction_restart_write 
  end type interaction_t
 
  abstract interface
 
    subroutine interaction_calculate(this)
      import interaction_t
      class(interaction_t),              intent(inout) :: this
    end subroutine interaction_calculate
 
    subroutine interaction_calculate_energy(this)
      import interaction_t
      class(interaction_t),              intent(inout) :: this
    end subroutine interaction_calculate_energy
  end interface
 
 
  type, extends(linked_list_t) :: interaction_list_t
    private
  contains
    procedure :: add => interaction_list_add_node
  end type interaction_list_t
 
  type, extends(linked_list_iterator_t) :: interaction_iterator_t
    private
  contains
    procedure :: get_next => interaction_iterator_get_next
  end type interaction_iterator_t
 
contains
 
  ! ---------------------------------------------------------
  subroutine interaction_update_partner_couplings(this, requested_iteration)
    class(interaction_t),              intent(inout) :: this
    class(iteration_counter_t),        intent(in)    :: requested_iteration
 
    type(event_handle_t) :: debug_handle
 
    push_sub(interaction_update_partner_couplings)
 
    if (this%partner_couplings_up_to_date) then
      ! Couplings have already been updated
      pop_sub(interaction_update_partner_couplings)
      return
    end if
 
    if (.not. allocated(this%couplings_from_partner)) then
      ! No couplings to update
      this%partner_couplings_up_to_date = .true.
      pop_sub(interaction_update_partner_couplings)
      return
    end if
 
    debug_handle = multisystem_debug_write_event_in(system_namespace = this%partner%namespace, &
      event = event_function_call_t("system_update_exposed_quantities"), &
      requested_iteration = requested_iteration, &
      interaction_iteration = this%iteration)
 
    ! Update all the necessary couplings that are updated on demand
    call this%partner%update_on_demand_quantities(this%couplings_from_partner, requested_iteration, &
      retardation_allowed = this%timing == timing_retarded)
 
    ! Check the status of all the couplings and take the appropriate actions
    select case (this%partner%check_couplings_status(this%couplings_from_partner, requested_iteration))
    case (couplings_on_time)
      ! Update was successful and we need to copy the couplings to the interaction
      this%partner_couplings_up_to_date = .true.
      call this%partner%copy_quantities_to_interaction(this)
 
    case (couplings_ahead_in_time)
      ! Update is successful, only if retarded interaction is allowed. If that
      ! is the case, the interaction should use the couplings it already has, so
      ! there is no need to copy them to the interaction
      this%partner_couplings_up_to_date = (this%timing == timing_retarded)
 
    case (couplings_behind_in_time)
      ! For now we will mark this case as unsuccessfu, but it could be
      ! successfull if interpolation was allowed
      this%partner_couplings_up_to_date = .false.
 
    case (couplings_undefined)
      ! Partner couplings are in an undefined state (some are ahead of the
      ! requested iteration and some are at the requested iteration). This
      ! should never happen!
      assert(.false.)
    end select
 
    call multisystem_debug_write_event_out(debug_handle, update=this%partner_couplings_up_to_date, &
      requested_iteration = requested_iteration, &
      interaction_iteration = this%iteration)
 
    pop_sub(interaction_update_partner_couplings)
 
  end subroutine interaction_update_partner_couplings
 
  ! ---------------------------------------------------------
  subroutine interaction_update(this, requested_iteration)
    class(interaction_t),              intent(inout) :: this
    class(iteration_counter_t),        intent(in)    :: requested_iteration
 
    type(event_handle_t) :: debug_handle
 
    push_sub(interaction_update)
 
    ! We should only try to update the interaction if it is not yet at the requested iteration
    assert(.not. (this%iteration == requested_iteration))
 
    debug_handle = multisystem_debug_write_event_in(event = event_function_call_t("interaction_update"), &
      extra="target: "//trim(this%label)//"-"//trim(this%partner%namespace%get()), &
      interaction_iteration = this%iteration,      &
      requested_iteration = requested_iteration)
 
    call this%calculate()
 
    ! Set new interaction iteration
    call this%iteration%set(requested_iteration)
    call multisystem_debug_write_marker(event = event_iteration_update_t( "interaction", &
      trim(this%label)//"-"//trim(this%partner%namespace%get()), &
      this%iteration, "set"))
 
    ! After leaving this routine, the partner quantities will need to updated
    ! again for the next interaction update
    this%partner_couplings_up_to_date = .false.
 
    call multisystem_debug_write_event_out(debug_handle, update = .true.,  &
      interaction_iteration = this%iteration,  &
      requested_iteration = requested_iteration)
 
    pop_sub(interaction_update)
  end subroutine interaction_update
 
  ! ---------------------------------------------------------
  subroutine interaction_end(this)
    class(interaction_t),              intent(inout) :: this
 
    push_sub(interaction_end)
 
    if (allocated(this%couplings_from_partner)) then
      deallocate(this%couplings_from_partner)
    end if
    nullify(this%partner)
 
    if (allocated(this%system_quantities)) then
      deallocate(this%system_quantities)
    end if
 
    if (allocated(this%label)) then
      deallocate(this%label)
    end if
 
    pop_sub(interaction_end)
  end subroutine interaction_end
 
  ! ---------------------------------------------------------
  logical function interaction_restart_read(this, namespace)
    class(interaction_t),              intent(inout) :: this
    type(namespace_t),                 intent(in)    :: namespace
 
    push_sub(interaction_restart_read)
 
    interaction_restart_read = this%iteration%restart_read('restart_iteration_interaction_'//trim(this%label), &
      namespace)
 
    pop_sub(interaction_restart_read)
  end function interaction_restart_read
 
  ! ---------------------------------------------------------
  subroutine interaction_restart_write(this, namespace)
    class(interaction_t),              intent(inout) :: this
    type(namespace_t),                 intent(in)    :: namespace
 
    push_sub(interaction_restart_write)
 
    call this%iteration%restart_write('restart_iteration_interaction_'//trim(this%label), namespace)
 
    pop_sub(interaction_restart_write)
  end subroutine interaction_restart_write
 
  ! ---------------------------------------------------------
  subroutine interaction_list_add_node(this, interaction)
    class(interaction_list_t)                 :: this
    class(interaction_t),              target :: interaction
 
    push_sub(interaction_list_add_node)
 
    call this%add_ptr(interaction)
 
    pop_sub(interaction_list_add_node)
  end subroutine interaction_list_add_node
 
  ! ---------------------------------------------------------
  function interaction_iterator_get_next(this) result(interaction)
    class(interaction_iterator_t),     intent(inout) :: this
    class(interaction_t),              pointer       :: interaction
 
    push_sub(interaction_iterator_get_next)
 
    select type (ptr => this%get_next_ptr())
    class is (interaction_t)
      interaction => ptr
    class default
      assert(.false.)
    end select
 
    pop_sub(interaction_iterator_get_next)
  end function interaction_iterator_get_next
 
end module interaction_oct_m
 
!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End: