VirtualGwfExchange.f90

Go to the documentation of this file.

module virtualgwfexchangemodule
  use kindmodule, only: i4b, lgp
  use stlvecintmodule
  use simstagesmodule
  use virtualbasemodule
  use virtualdatacontainermodule, only: vdc_gwfexg_type
  use virtualexchangemodule
  use virtualdatalistsmodule, only: virtual_exchange_list
  implicit none
  private
 
  public :: add_virtual_gwf_exchange
 
  !> For synchronization of GWF specific exchange data:
  !< the exchange movers.
  type, public, extends(virtualexchangetype) :: virtualgwfexchangetype
    type(virtualinttype), pointer :: inmvr => null()
    type(virtualinttype), pointer :: mvr_maxmvr => null()
    type(virtualdbl1dtype), pointer :: mvr_qpactual_m1 => null()
    type(virtualdbl1dtype), pointer :: mvr_qpactual_m2 => null()
    type(virtualdbl1dtype), pointer :: mvr_qavailable_m1 => null()
    type(virtualdbl1dtype), pointer :: mvr_qavailable_m2 => null()
    type(virtualint1dtype), pointer :: mvr_id_mapped_m1 => null()
    type(virtualint1dtype), pointer :: mvr_id_mapped_m2 => null()
    ! private
    logical(LGP), private :: has_mvr !< backing field for function
  contains
    procedure :: create => vfx_create
    procedure :: prepare_stage => vfx_prepare_stage
    procedure :: destroy => vfx_destroy
    procedure :: get_send_items => vfx_get_send_items
    procedure :: get_recv_items => vfx_get_recv_items
    procedure :: has_mover => vfx_has_mover
    ! private
    procedure, private :: allocate_data
    procedure, private :: deallocate_data
    procedure, private :: init_virtual_data
  end type virtualgwfexchangetype
 
contains
 
!> @brief Add a virtual GWF-GWF exchange to the simulation
!<
  subroutine add_virtual_gwf_exchange(name, exchange_id, model1_id, model2_id)
    integer(I4B) :: exchange_id
    character(len=*) :: name
    integer(I4B) :: model1_id
    integer(I4B) :: model2_id
    ! local
    class(virtualgwfexchangetype), pointer :: v_exg
    class(*), pointer :: obj_ptr
 
    allocate (v_exg)
    call v_exg%create(name, exchange_id, model1_id, model2_id)
 
    obj_ptr => v_exg
    call virtual_exchange_list%Add(obj_ptr)
 
  end subroutine add_virtual_gwf_exchange
 
!> @brief Create a virtual GWF-GWF exchange
!<
  subroutine vfx_create(this, name, exg_id, m1_id, m2_id)
    class(virtualgwfexchangetype) :: this
    character(len=*) :: name
    integer(I4B) :: exg_id
    integer(I4B) :: m1_id
    integer(I4B) :: m2_id
 
    call this%VirtualExchangeType%create(name, exg_id, m1_id, m2_id)
    this%container_type = vdc_gwfexg_type
 
    call this%allocate_data()
    call this%init_virtual_data()
 
    this%has_mvr = .false.
 
  end subroutine vfx_create
 
  subroutine init_virtual_data(this)
    class(virtualgwfexchangetype) :: this
    ! local
    logical(LGP) :: is_nodem1_local
    logical(LGP) :: is_nodem2_local
 
    is_nodem1_local = this%v_model1%is_local
    is_nodem2_local = this%v_model2%is_local
    call this%set(this%inmvr%base(), 'INMVR', '', map_all_type)
    call this%set(this%mvr_maxmvr%base(), 'MAXMVR', 'MVR', map_all_type)
    ! these follow locality of nodem1,2
    call this%set(this%mvr_qpactual_m1%base(), 'QPACTUAL_M1', 'MVR', &
                  map_all_type, is_nodem1_local)
    call this%set(this%mvr_qpactual_m2%base(), 'QPACTUAL_M2', 'MVR', &
                  map_all_type, is_nodem2_local)
    call this%set(this%mvr_qavailable_m1%base(), 'QAVAILABLE_M1', 'MVR', &
                  map_all_type, is_nodem1_local)
    call this%set(this%mvr_qavailable_m2%base(), 'QAVAILABLE_M2', 'MVR', &
                  map_all_type, is_nodem2_local)
    call this%set(this%mvr_id_mapped_m1%base(), 'ID_MAPPED_M1', 'MVR', &
                  map_all_type, is_nodem1_local)
    call this%set(this%mvr_id_mapped_m2%base(), 'ID_MAPPED_M2', 'MVR', &
                  map_all_type, is_nodem2_local)
 
  end subroutine init_virtual_data
 
  subroutine vfx_prepare_stage(this, stage)
    class(virtualgwfexchangetype) :: this
    integer(I4B) :: stage
    ! local
    integer(I4B) :: nmax
 
    ! prepare base exchange data items
    call this%VirtualExchangeType%prepare_stage(stage)
 
    if (stage == stg_aft_exg_df) then
 
      ! always synchronize mover flag
      call this%map(this%inmvr%base(), (/stg_aft_exg_df/))
 
    else if (stage == stg_aft_con_cr) then
 
      ! at this point we know:
      if (this%inmvr%get() > 0) then
        this%has_mvr = .true.
      end if
 
    else if (stage == stg_bfr_con_ar) then
 
      ! only when MVR is locally active (i.e. primary exchange)
      if (this%has_mvr .and. this%is_local) then
        call this%map(this%mvr_maxmvr%base(), (/stg_bfr_con_ar/))
      end if
 
    else if (stage == stg_aft_con_ar) then
 
      ! only when MVR is locally active
      nmax = 0
      if (this%has_mvr .and. this%is_local) nmax = this%mvr_maxmvr%get()
 
      if (nmax > 0) then
        call this%map(this%mvr_qpactual_m1%base(), nmax, (/stg_bfr_exg_fc/))
        call this%map(this%mvr_qpactual_m2%base(), nmax, (/stg_bfr_exg_fc/))
        call this%map(this%mvr_qavailable_m1%base(), nmax, (/stg_bfr_exg_fc/))
        call this%map(this%mvr_qavailable_m2%base(), nmax, (/stg_bfr_exg_fc/))
        call this%map(this%mvr_id_mapped_m1%base(), nmax, (/stg_aft_con_rp/))
        call this%map(this%mvr_id_mapped_m2%base(), nmax, (/stg_aft_con_rp/))
      else
        call this%map(this%mvr_qpactual_m1%base(), 0, (/stg_never/))
        call this%map(this%mvr_qpactual_m2%base(), 0, (/stg_never/))
        call this%map(this%mvr_qavailable_m1%base(), 0, (/stg_never/))
        call this%map(this%mvr_qavailable_m2%base(), 0, (/stg_never/))
        call this%map(this%mvr_id_mapped_m1%base(), 0, (/stg_never/))
        call this%map(this%mvr_id_mapped_m2%base(), 0, (/stg_never/))
      end if
 
    end if
 
  end subroutine vfx_prepare_stage
 
  subroutine vfx_get_recv_items(this, stg, rank, vi)
    class(virtualgwfexchangetype) :: this
    integer(I4B) :: stg !< stage
    integer(I4B) :: rank !< rank of remote process
    type(stlvecint) :: vi !< virtual data items
 
    ! get base items to receive
    call this%VirtualExchangeType%get_recv_items(stg, rank, vi)
 
    ! add more MVR items that follow nodem1/nodem2 pattern,
    ! see comments in VirtualExchange for more details
    if (this%is_local .and. rank == this%orig_rank) then
      if (this%mvr_id_mapped_m1%is_remote) then
        ! only receive for model1
        call this%add_vdi_for_stage(this%mvr_qpactual_m1%base(), stg, vi)
        call this%add_vdi_for_stage(this%mvr_qavailable_m1%base(), stg, vi)
        call this%add_vdi_for_stage(this%mvr_id_mapped_m1%base(), stg, vi)
      end if
      if (this%mvr_id_mapped_m2%is_remote) then
        ! only receive for model2
        call this%add_vdi_for_stage(this%mvr_qpactual_m2%base(), stg, vi)
        call this%add_vdi_for_stage(this%mvr_qavailable_m2%base(), stg, vi)
        call this%add_vdi_for_stage(this%mvr_id_mapped_m2%base(), stg, vi)
      end if
    end if
 
  end subroutine vfx_get_recv_items
 
  subroutine vfx_get_send_items(this, stg, rank, vi)
    class(virtualgwfexchangetype) :: this
    integer(I4B) :: stg !< stage
    integer(I4B) :: rank !< rank of remote process
    type(stlvecint) :: vi !< virtual data items
 
    ! get base items to send
    call this%VirtualExchangeType%get_send_items(stg, rank, vi)
 
    ! add more MVR items that follow nodem1/nodem2 pattern,
    ! see comments in VirtualExchange for more details
    if (this%is_local .and. rank == this%orig_rank) then
      if (.not. this%mvr_id_mapped_m1%is_remote) then
        ! only receive for model1
        call this%add_vdi_for_stage(this%mvr_qpactual_m1%base(), stg, vi)
        call this%add_vdi_for_stage(this%mvr_qavailable_m1%base(), stg, vi)
        call this%add_vdi_for_stage(this%mvr_id_mapped_m1%base(), stg, vi)
      end if
      if (.not. this%mvr_id_mapped_m2%is_remote) then
        ! only receive for model2
        call this%add_vdi_for_stage(this%mvr_qpactual_m2%base(), stg, vi)
        call this%add_vdi_for_stage(this%mvr_qavailable_m2%base(), stg, vi)
        call this%add_vdi_for_stage(this%mvr_id_mapped_m2%base(), stg, vi)
      end if
    end if
 
  end subroutine vfx_get_send_items
 
  !> @brief Override
  !<
  function vfx_has_mover(this) result(has_mover)
    class(virtualgwfexchangetype) :: this
    logical(LGP) :: has_mover
 
    has_mover = this%has_mvr
 
  end function vfx_has_mover
 
  subroutine allocate_data(this)
    class(virtualgwfexchangetype) :: this
 
    allocate (this%inmvr)
    allocate (this%mvr_maxmvr)
    allocate (this%mvr_qpactual_m1)
    allocate (this%mvr_qpactual_m2)
    allocate (this%mvr_qavailable_m1)
    allocate (this%mvr_qavailable_m2)
    allocate (this%mvr_id_mapped_m1)
    allocate (this%mvr_id_mapped_m2)
 
  end subroutine allocate_data
 
  subroutine deallocate_data(this)
    class(virtualgwfexchangetype) :: this
 
    deallocate (this%inmvr)
    deallocate (this%mvr_maxmvr)
    deallocate (this%mvr_qpactual_m1)
    deallocate (this%mvr_qpactual_m2)
    deallocate (this%mvr_qavailable_m1)
    deallocate (this%mvr_qavailable_m2)
    deallocate (this%mvr_id_mapped_m1)
    deallocate (this%mvr_id_mapped_m2)
 
  end subroutine deallocate_data
 
  subroutine vfx_destroy(this)
    class(virtualgwfexchangetype) :: this
 
    call this%VirtualExchangeType%destroy()
    call this%deallocate_data()
 
  end subroutine vfx_destroy
 
end module virtualgwfexchangemodule