VirtualExchange.f90

Go to the documentation of this file.

module virtualexchangemodule
  use virtualbasemodule
  use virtualdatacontainermodule
  use virtualmodelmodule, only: virtualmodeltype, get_virtual_model
  use kindmodule, only: i4b, lgp
  use listmodule, only: listtype
  use stlvecintmodule
  use constantsmodule, only: lenexchangename
  use simstagesmodule
  implicit none
  private
 
  public :: get_virtual_exchange
  public :: get_virtual_exchange_from_list
  private :: cast_as_virtual_exchange
 
  !> The Virtual Exchange is based on two Virtual Models
  !! and is therefore not always strictly local or remote.
  !! We have to consider three different cases:
  !!
  !! 1) both virtual models are local
  !!
  !!   RECV: In this case this virtual data container will have
  !!         no data items to receive from other processes.
  !!   SEND: Whenever it is called to send its virtual data items
  !!         to other processes, it simply sends everything.
  !!
  !! 2) one model is local, one model is remote
  !!
  !!   Consequently, there is another exchange which
  !!   has the reverse, we call this our _dual_ exchange.
  !!
  !!   RECV: The sender is our dual exchange, and we have all data
  !!         except its list of reduced model node numbers, either
  !!         this%nodem1 or this%nodem2. We receive the missing
  !!         array. Receiving from a sender that is not the dual
  !!         exchange cannot occur.
  !!
  !!   SEND: here we have to consider two cases
  !!      a) The receiver is our dual exchange, we return the favor
  !!         and send the list of model node numbers that is present
  !!         on this process, this
  !!         would be either this%nodem1 or this%nodem2
  !!      b) The receiver is not the dual exchange. And here we will
  !!         send everything.
  !!
  !! 3) both models are remote
  !!
  !!   RECV: we will receive everything. In case the source
  !!         exchange is fully local, i.e. type 1) above, we get
  !!         all the data at the first attempt. Otherwise, it will
  !!         take a second attempt before all the data is in.
  !!         (To allow for two attempts, the nodem1 and nodem2
  !!         arrays are registered to be synchronized at two
  !!         consecutive stages)
  !!
  !!  SEND: nothing to be sent.
  !!
  !!
  !! This behavior is different from the general VirtualDataContainer,
  !! so the get_send_items and get_recv_items subroutines are
  !! overridden accordingly.
  !! Additionally, for case 2) the container will have a mix of
  !< local and remote virtual data items.
  type, public, extends(virtualdatacontainertype) :: virtualexchangetype
    class(virtualmodeltype), pointer :: v_model1 => null()
    class(virtualmodeltype), pointer :: v_model2 => null()
    ! scalars
    type(virtualinttype), pointer :: nexg => null()
    type(virtualinttype), pointer :: naux => null()
    type(virtualinttype), pointer :: ianglex => null()
    ! arrays
    type(virtualint1dtype), pointer :: nodem1 => null()
    type(virtualint1dtype), pointer :: nodem2 => null()
    type(virtualint1dtype), pointer :: ihc => null()
    type(virtualdbl1dtype), pointer :: cl1 => null()
    type(virtualdbl1dtype), pointer :: cl2 => null()
    type(virtualdbl1dtype), pointer :: hwva => null()
    type(virtualdbl2dtype), pointer :: auxvar => null()
  contains
    procedure :: create => vx_create
    procedure :: prepare_stage => vx_prepare_stage
    procedure :: get_send_items => vx_get_send_items
    procedure :: get_recv_items => vx_get_recv_items
    procedure :: has_mover => vx_has_mover
    procedure :: destroy => vx_destroy
    ! private
    procedure, private :: init_virtual_data
    procedure, private :: allocate_data
    procedure, private :: deallocate_data
  end type virtualexchangetype
 
contains
 
  !> @brief Create the virtual exchange base
  !<
  subroutine vx_create(this, name, exg_id, m1_id, m2_id)
    class(virtualexchangetype) :: this
    character(len=*) :: name
    integer(I4B) :: exg_id
    integer(I4B) :: m1_id
    integer(I4B) :: m2_id
    ! local
    logical(LGP) :: is_local
 
    this%v_model1 => get_virtual_model(m1_id)
    this%v_model2 => get_virtual_model(m2_id)
 
    ! 1) both models local:  is_local = true
    ! 2) only one of them:   is_local = true
    ! 3) both models remote: is_local = false
    is_local = this%v_model1%is_local .or. this%v_model2%is_local
    call this%VirtualDataContainerType%vdc_create(name, exg_id, is_local)
 
    call this%allocate_data()
    call this%init_virtual_data()
 
  end subroutine vx_create
 
  subroutine init_virtual_data(this)
    class(virtualexchangetype) :: this
    ! local
    logical(LGP) :: is_nodem1_local
    logical(LGP) :: is_nodem2_local
 
    ! exchanges can be hybrid with both local and remote
    ! fields, nodem1/2 array only local when corresponding
    ! model sits on the same process
    is_nodem1_local = this%v_model1%is_local
    is_nodem2_local = this%v_model2%is_local
    call this%set(this%nexg%base(), 'NEXG', '', map_all_type)
    call this%set(this%naux%base(), 'NAUX', '', map_all_type)
    call this%set(this%ianglex%base(), 'IANGLEX', '', map_all_type)
    call this%set(this%nodem1%base(), 'NODEM1', '', &
                  map_all_type, is_nodem1_local)
    call this%set(this%nodem2%base(), 'NODEM2', '', &
                  map_all_type, is_nodem2_local)
    call this%set(this%ihc%base(), 'IHC', '', map_all_type)
    call this%set(this%cl1%base(), 'CL1', '', map_all_type)
    call this%set(this%cl2%base(), 'CL2', '', map_all_type)
    call this%set(this%hwva%base(), 'HWVA', '', map_all_type)
    call this%set(this%auxvar%base(), 'AUXVAR', '', map_all_type)
 
  end subroutine init_virtual_data
 
  subroutine vx_prepare_stage(this, stage)
    class(virtualexchangetype) :: this
    integer(I4B) :: stage
    ! local
    integer(I4B) :: nexg, naux
 
    if (stage == stg_aft_exg_df) then
 
      call this%map(this%nexg%base(), (/stg_aft_exg_df/))
      call this%map(this%naux%base(), (/stg_aft_exg_df/))
      call this%map(this%ianglex%base(), (/stg_aft_exg_df/))
 
    else if (stage == stg_aft_con_cr) then
 
      nexg = this%nexg%get()
      naux = this%naux%get()
      call this%map(this%nodem1%base(), nexg, (/stg_aft_con_cr, &
                                                stg_bfr_con_df/))
      call this%map(this%nodem2%base(), nexg, (/stg_aft_con_cr, &
                                                stg_bfr_con_df/))
      call this%map(this%ihc%base(), nexg, (/stg_aft_con_cr/))
      call this%map(this%cl1%base(), nexg, (/stg_aft_con_cr/))
      call this%map(this%cl2%base(), nexg, (/stg_aft_con_cr/))
      call this%map(this%hwva%base(), nexg, (/stg_aft_con_cr/))
      call this%map(this%auxvar%base(), naux, nexg, (/stg_aft_con_cr/))
 
    end if
 
  end subroutine vx_prepare_stage
 
  subroutine vx_get_recv_items(this, stage, rank, virtual_items)
    class(virtualexchangetype) :: this
    integer(I4B) :: stage
    integer(I4B) :: rank
    type(stlvecint) :: virtual_items
    ! local
    integer(I4B) :: nodem1_idx, nodem2_idx
    class(*), pointer :: vdi
 
    vdi => this%nodem1
    nodem1_idx = this%virtual_data_list%GetIndex(vdi)
    vdi => this%nodem2
    nodem2_idx = this%virtual_data_list%GetIndex(vdi)
 
    if (this%v_model1%is_local .and. &
        this%v_model2%orig_rank == rank) then
      ! this is our dual exchange on the other rank,
      ! only receive nodem2
      if (this%nodem2%check_stage(stage)) then
        call virtual_items%push_back(nodem2_idx)
      end if
    else if (this%v_model2%is_local .and. &
             this%v_model1%orig_rank == rank) then
      ! the reverse case...
      if (this%nodem1%check_stage(stage)) then
        call virtual_items%push_back(nodem1_idx)
      end if
    else
      ! receive all using base
      call this%VirtualDataContainerType%get_recv_items(stage, rank, &
                                                        virtual_items)
    end if
 
  end subroutine vx_get_recv_items
 
  subroutine vx_get_send_items(this, stage, rank, virtual_items)
    class(virtualexchangetype) :: this
    integer(I4B) :: stage
    integer(I4B) :: rank
    type(stlvecint) :: virtual_items
    ! local
    integer(I4B) :: nodem1_idx, nodem2_idx
    class(*), pointer :: vdi
 
    vdi => this%nodem1
    nodem1_idx = this%virtual_data_list%GetIndex(vdi)
    vdi => this%nodem2
    nodem2_idx = this%virtual_data_list%GetIndex(vdi)
    if (this%v_model1%is_local .and. &
        this%v_model2%orig_rank == rank) then
      ! this is our dual exchange on the other rank,
      ! only send nodem1
      if (this%nodem1%check_stage(stage)) then
        call virtual_items%push_back(nodem1_idx)
      end if
    else if (this%v_model2%is_local .and. &
             this%v_model1%orig_rank == rank) then
      ! the reverse case...
      if (this%nodem2%check_stage(stage)) then
        call virtual_items%push_back(nodem2_idx)
      end if
    else
      ! send all of it
      call this%VirtualDataContainerType%get_send_items(stage, rank, &
                                                        virtual_items)
    end if
 
  end subroutine vx_get_send_items
 
  !> @brief Checks if there is an active mover in the exchange
  !<
  function vx_has_mover(this) result(has_mover)
    class(virtualexchangetype) :: this
    logical(LGP) :: has_mover
 
    has_mover = .false.
 
  end function vx_has_mover
 
  subroutine vx_destroy(this)
    class(virtualexchangetype) :: this
 
    call this%VirtualDataContainerType%destroy()
    call this%deallocate_data()
 
  end subroutine vx_destroy
 
  subroutine allocate_data(this)
    class(virtualexchangetype) :: this
 
    allocate (this%nexg)
    allocate (this%naux)
    allocate (this%ianglex)
    allocate (this%nodem1)
    allocate (this%nodem2)
    allocate (this%ihc)
    allocate (this%cl1)
    allocate (this%cl2)
    allocate (this%hwva)
    allocate (this%auxvar)
 
  end subroutine allocate_data
 
  subroutine deallocate_data(this)
    class(virtualexchangetype) :: this
 
    deallocate (this%nexg)
    deallocate (this%naux)
    deallocate (this%ianglex)
    deallocate (this%nodem1)
    deallocate (this%nodem2)
    deallocate (this%ihc)
    deallocate (this%cl1)
    deallocate (this%cl2)
    deallocate (this%hwva)
    deallocate (this%auxvar)
 
  end subroutine deallocate_data
 
  !> @brief Returns a virtual exchange with the specified id
  !< from the global list
  function get_virtual_exchange(exg_id) result(virtual_exg)
    use virtualdatalistsmodule, only: virtual_exchange_list
    integer(I4B) :: exg_id
    class(virtualexchangetype), pointer :: virtual_exg
    ! local
    integer(I4B) :: i
    class(*), pointer :: ve
 
    virtual_exg => null()
    do i = 1, virtual_exchange_list%Count()
      ve => virtual_exchange_list%GetItem(i)
      select type (ve)
      class is (virtualexchangetype)
        if (ve%id == exg_id) then
          virtual_exg => ve
          return
        end if
      end select
    end do
 
  end function get_virtual_exchange
 
  function get_virtual_exchange_from_list(list, idx) result(virtual_exg)
    type(listtype) :: list
    integer(I4B) :: idx
    class(virtualexchangetype), pointer :: virtual_exg
    ! local
    class(*), pointer :: obj_ptr
 
    obj_ptr => list%GetItem(idx)
    virtual_exg => cast_as_virtual_exchange(obj_ptr)
 
  end function get_virtual_exchange_from_list
 
  function cast_as_virtual_exchange(obj_ptr) result(virtual_exg)
    class(*), pointer :: obj_ptr
    class(virtualexchangetype), pointer :: virtual_exg
 
    virtual_exg => null()
    select type (obj_ptr)
    class is (virtualexchangetype)
      virtual_exg => obj_ptr
    end select
 
  end function cast_as_virtual_exchange
 
end module virtualexchangemodule