VirtualModel.f90

Go to the documentation of this file.

module virtualmodelmodule
  use virtualbasemodule
  use virtualdatacontainermodule
  use constantsmodule, only: lenmempath
  use kindmodule, only: i4b, lgp
  use listmodule, only: listtype
  use simstagesmodule
  use numericalmodelmodule, only: numericalmodeltype
  implicit none
  private
 
  public :: cast_as_virtual_model
  public :: get_virtual_model_from_list
  public :: get_virtual_model
 
  interface get_virtual_model
    module procedure get_virtual_model_by_id, &
      get_virtual_model_by_name
  end interface
 
  type, public, extends(virtualdatacontainertype) :: virtualmodeltype
    class(numericalmodeltype), pointer :: local_model
    ! CON
    type(virtualinttype), pointer :: con_ianglex => null()
    type(virtualint1dtype), pointer :: con_ia => null()
    type(virtualint1dtype), pointer :: con_ja => null()
    type(virtualint1dtype), pointer :: con_jas => null()
    type(virtualint1dtype), pointer :: con_ihc => null()
    type(virtualdbl1dtype), pointer :: con_hwva => null()
    type(virtualdbl1dtype), pointer :: con_cl1 => null()
    type(virtualdbl1dtype), pointer :: con_cl2 => null()
    type(virtualdbl1dtype), pointer :: con_anglex => null()
    ! DIS
    type(virtualinttype), pointer :: dis_ndim => null()
    type(virtualinttype), pointer :: dis_nodes => null()
    type(virtualinttype), pointer :: dis_nodesuser => null()
    type(virtualint1dtype), pointer :: dis_nodeuser => null()
    type(virtualinttype), pointer :: dis_nja => null()
    type(virtualinttype), pointer :: dis_njas => null()
    type(virtualdbltype), pointer :: dis_xorigin => null()
    type(virtualdbltype), pointer :: dis_yorigin => null()
    type(virtualdbltype), pointer :: dis_angrot => null()
    type(virtualinttype), pointer :: dis_icondir => null()
    type(virtualdbl1dtype), pointer :: dis_xc => null()
    type(virtualdbl1dtype), pointer :: dis_yc => null()
    type(virtualdbl1dtype), pointer :: dis_top => null()
    type(virtualdbl1dtype), pointer :: dis_bot => null()
    type(virtualdbl1dtype), pointer :: dis_area => null()
    ! Numerical Model fields
    type(virtualinttype), pointer :: moffset => null()
    type(virtualdbl1dtype), pointer :: x => null()
    type(virtualdbl1dtype), pointer :: x_old => null()
    type(virtualint1dtype), pointer :: ibound => null()
    ! Base Model fields
    type(virtualinttype), pointer :: idsoln => null()
  contains
    ! public
    procedure :: create => vm_create
    procedure :: prepare_stage => vm_prepare_stage
    procedure :: destroy => vm_destroy
    generic :: operator(==) => eq_virtual_model, eq_numerical_model
 
    procedure :: dis_get_nodeuser
    procedure :: dis_noder_to_string
 
    ! private
    procedure, private :: init_virtual_data
    procedure, private :: allocate_data
    procedure, private :: deallocate_data
    procedure, private :: eq_virtual_model
    procedure, private :: eq_numerical_model
  end type virtualmodeltype
 
contains
 
  subroutine vm_create(this, name, id, model)
    class(virtualmodeltype) :: this
    character(len=*) :: name
    integer(I4B) :: id
    class(numericalmodeltype), pointer :: model
    ! local
    logical(LGP) :: is_local
 
    is_local = associated(model)
    call this%VirtualDataContainerType%vdc_create(name, id, is_local)
 
    this%local_model => model
 
    call this%allocate_data()
    call this%init_virtual_data()
 
  end subroutine vm_create
 
  subroutine init_virtual_data(this)
    class(virtualmodeltype) :: this
 
    ! CON
    call this%set(this%con_ianglex%base(), 'IANGLEX', 'CON', map_all_type)
    call this%set(this%con_ia%base(), 'IA', 'CON', map_all_type)
    call this%set(this%con_ja%base(), 'JA', 'CON', map_all_type)
    call this%set(this%con_jas%base(), 'JAS', 'CON', map_all_type)
    call this%set(this%con_ihc%base(), 'IHC', 'CON', map_all_type)
    call this%set(this%con_hwva%base(), 'HWVA', 'CON', map_all_type)
    call this%set(this%con_cl1%base(), 'CL1', 'CON', map_all_type)
    call this%set(this%con_cl2%base(), 'CL2', 'CON', map_all_type)
    call this%set(this%con_anglex%base(), 'ANGLEX', 'CON', map_all_type)
    ! DIS
    call this%set(this%dis_ndim%base(), 'NDIM', 'DIS', map_all_type)
    call this%set(this%dis_nodes%base(), 'NODES', 'DIS', map_all_type)
    call this%set(this%dis_nodesuser%base(), 'NODESUSER', 'DIS', map_all_type)
    call this%set(this%dis_nodeuser%base(), 'NODEUSER', 'DIS', map_all_type)
    call this%set(this%dis_nja%base(), 'NJA', 'DIS', map_all_type)
    call this%set(this%dis_njas%base(), 'NJAS', 'DIS', map_all_type)
    call this%set(this%dis_icondir%base(), 'ICONDIR', 'DIS', map_all_type)
    call this%set(this%dis_xorigin%base(), 'XORIGIN', 'DIS', map_all_type)
    call this%set(this%dis_yorigin%base(), 'YORIGIN', 'DIS', map_all_type)
    call this%set(this%dis_angrot%base(), 'ANGROT', 'DIS', map_all_type)
    call this%set(this%dis_xc%base(), 'XC', 'DIS', map_all_type)
    call this%set(this%dis_yc%base(), 'YC', 'DIS', map_all_type)
    call this%set(this%dis_top%base(), 'TOP', 'DIS', map_all_type)
    call this%set(this%dis_bot%base(), 'BOT', 'DIS', map_all_type)
    call this%set(this%dis_area%base(), 'AREA', 'DIS', map_all_type)
    ! Numerical model
    call this%set(this%moffset%base(), 'MOFFSET', '', map_all_type)
    call this%set(this%x%base(), 'X', '', map_node_type)
    call this%set(this%x_old%base(), 'XOLD', '', map_node_type)
    call this%set(this%ibound%base(), 'IBOUND', '', map_node_type)
    ! Base model
    call this%set(this%idsoln%base(), 'IDSOLN', '', map_all_type)
 
  end subroutine init_virtual_data
 
  subroutine vm_prepare_stage(this, stage)
    class(virtualmodeltype) :: this
    integer(I4B) :: stage
    ! local
    integer(I4B) :: nodes, nodesuser, nja, njas, icondir
    logical(LGP) :: is_reduced
 
    if (stage == stg_aft_mdl_df) then
 
      call this%map(this%idsoln%base(), (/stg_aft_mdl_df/))
      call this%map(this%con_ianglex%base(), (/stg_aft_mdl_df/))
      call this%map(this%dis_icondir%base(), (/stg_aft_mdl_df/))
      call this%map(this%dis_ndim%base(), (/stg_aft_mdl_df/))
      call this%map(this%dis_nodes%base(), (/stg_aft_mdl_df/))
      call this%map(this%dis_nodesuser%base(), (/stg_aft_mdl_df/))
      call this%map(this%dis_nja%base(), (/stg_aft_mdl_df/))
      call this%map(this%dis_njas%base(), (/stg_aft_mdl_df/))
 
    else if (stage == stg_bfr_exg_ac) then
 
      nodes = this%dis_nodes%get()
      nodesuser = this%dis_nodesuser%get()
      is_reduced = (nodes /= nodesuser)
      call this%map(this%moffset%base(), (/stg_bfr_exg_ac/))
      if (is_reduced) then
        call this%map(this%dis_nodeuser%base(), nodes, (/stg_bfr_exg_ac/))
      else
        ! no reduction, zero sized array, never synchronize
        call this%map(this%dis_nodeuser%base(), 0, (/stg_never/))
      end if
 
    else if (stage == stg_bfr_con_df) then
 
      nodes = this%dis_nodes%get()
      nja = this%dis_nja%get()
      njas = this%dis_njas%get()
      icondir = this%dis_icondir%get()
      ! DIS
      call this%map(this%dis_xorigin%base(), (/stg_bfr_con_df/))
      call this%map(this%dis_yorigin%base(), (/stg_bfr_con_df/))
      call this%map(this%dis_angrot%base(), (/stg_bfr_con_df/))
      if (icondir > 0) then
        call this%map(this%dis_xc%base(), nodes, (/stg_bfr_con_df/))
        call this%map(this%dis_yc%base(), nodes, (/stg_bfr_con_df/))
      else
        call this%map(this%dis_xc%base(), 0, (/stg_never/))
        call this%map(this%dis_yc%base(), 0, (/stg_never/))
      end if
      call this%map(this%dis_top%base(), nodes, (/stg_bfr_con_df/))
      call this%map(this%dis_bot%base(), nodes, (/stg_bfr_con_df/))
      call this%map(this%dis_area%base(), nodes, (/stg_bfr_con_df/))
      ! CON
      call this%map(this%con_ia%base(), nodes + 1, (/stg_bfr_con_df/))
      call this%map(this%con_ja%base(), nja, (/stg_bfr_con_df/))
      call this%map(this%con_jas%base(), nja, (/stg_bfr_con_df/))
      call this%map(this%con_ihc%base(), njas, (/stg_bfr_con_df/))
      call this%map(this%con_hwva%base(), njas, (/stg_bfr_con_df/))
      call this%map(this%con_cl1%base(), njas, (/stg_bfr_con_df/))
      call this%map(this%con_cl2%base(), njas, (/stg_bfr_con_df/))
      if (this%con_ianglex%get() > 0) then
        call this%map(this%con_anglex%base(), njas, (/stg_bfr_con_df/))
      else
        call this%map(this%con_anglex%base(), 0, (/stg_never/))
      end if
 
    end if
 
  end subroutine vm_prepare_stage
 
  !> @brief Get user node number from reduced number
  !<
  function dis_get_nodeuser(this, node_reduced) result(node_user)
    class(virtualmodeltype) :: this !< this virtual model
    integer(I4B), intent(in) :: node_reduced !< the reduced node number
    integer(I4B) :: node_user !< the returned user node number
 
    if (this%dis_nodes%get() < this%dis_nodesuser%get()) then
      node_user = this%dis_nodeuser%get(node_reduced)
    else
      node_user = node_reduced
    end if
 
  end function dis_get_nodeuser
 
  subroutine dis_noder_to_string(this, node_reduced, node_str)
    class(virtualmodeltype) :: this !< this virtual model
    integer(I4B), intent(in) :: node_reduced !< reduced node number
    character(len=*), intent(inout) :: node_str !< the string representative of the user node number
    ! local
    character(len=11) :: nr_str
 
    if (this%is_local) then
      call this%local_model%dis%noder_to_string(node_reduced, node_str)
    else
      ! for now this will look like: (102r)
      write (nr_str, '(i0)') node_reduced
      node_str = '('//trim(adjustl(nr_str))//'r)'
    end if
 
  end subroutine dis_noder_to_string
 
  subroutine vm_destroy(this)
    class(virtualmodeltype) :: this
 
    call this%VirtualDataContainerType%destroy()
    call this%deallocate_data()
 
  end subroutine vm_destroy
 
  subroutine allocate_data(this)
    class(virtualmodeltype) :: this
 
    allocate (this%con_ianglex)
    allocate (this%con_ia)
    allocate (this%con_ja)
    allocate (this%con_jas)
    allocate (this%con_ihc)
    allocate (this%con_hwva)
    allocate (this%con_cl1)
    allocate (this%con_cl2)
    allocate (this%con_anglex)
    allocate (this%dis_ndim)
    allocate (this%dis_nodes)
    allocate (this%dis_nodesuser)
    allocate (this%dis_nodeuser)
    allocate (this%dis_nja)
    allocate (this%dis_njas)
    allocate (this%dis_xorigin)
    allocate (this%dis_yorigin)
    allocate (this%dis_angrot)
    allocate (this%dis_icondir)
    allocate (this%dis_xc)
    allocate (this%dis_yc)
    allocate (this%dis_top)
    allocate (this%dis_bot)
    allocate (this%dis_area)
    allocate (this%moffset)
    allocate (this%x)
    allocate (this%x_old)
    allocate (this%ibound)
    allocate (this%idsoln)
 
  end subroutine allocate_data
 
  subroutine deallocate_data(this)
    class(virtualmodeltype) :: this
 
    ! CON
    deallocate (this%con_ianglex)
    deallocate (this%con_ia)
    deallocate (this%con_ja)
    deallocate (this%con_jas)
    deallocate (this%con_ihc)
    deallocate (this%con_hwva)
    deallocate (this%con_cl1)
    deallocate (this%con_cl2)
    deallocate (this%con_anglex)
    ! DIS
    deallocate (this%dis_ndim)
    deallocate (this%dis_nodes)
    deallocate (this%dis_nodesuser)
    deallocate (this%dis_nodeuser)
    deallocate (this%dis_nja)
    deallocate (this%dis_njas)
    deallocate (this%dis_xorigin)
    deallocate (this%dis_yorigin)
    deallocate (this%dis_angrot)
    deallocate (this%dis_icondir)
    deallocate (this%dis_xc)
    deallocate (this%dis_yc)
    deallocate (this%dis_top)
    deallocate (this%dis_bot)
    deallocate (this%dis_area)
    ! Numerical model
    deallocate (this%moffset)
    deallocate (this%x)
    deallocate (this%x_old)
    deallocate (this%ibound)
    ! Base model
    deallocate (this%idsoln)
 
  end subroutine deallocate_data
 
  function get_virtual_model_from_list(model_list, idx) result(v_model)
    type(listtype) :: model_list
    integer(I4B) :: idx
    class(virtualmodeltype), pointer :: v_model
    ! local
    class(*), pointer :: obj_ptr
 
    obj_ptr => model_list%GetItem(idx)
    v_model => cast_as_virtual_model(obj_ptr)
  end function get_virtual_model_from_list
 
  function cast_as_virtual_model(obj_ptr) result(v_model)
    class(*), pointer :: obj_ptr
    class(virtualmodeltype), pointer :: v_model
 
    v_model => null()
    select type (obj_ptr)
    class is (virtualmodeltype)
      v_model => obj_ptr
    end select
 
  end function cast_as_virtual_model
 
  function eq_virtual_model(this, v_model) result(is_equal)
    class(virtualmodeltype), intent(in) :: this
    class(virtualmodeltype), intent(in) :: v_model
    logical(LGP) :: is_equal
 
    is_equal = (this%id == v_model%id)
 
  end function eq_virtual_model
 
  function eq_numerical_model(this, num_model) result(is_equal)
    class(virtualmodeltype), intent(in) :: this
    class(numericalmodeltype), intent(in) :: num_model
    logical(LGP) :: is_equal
 
    is_equal = (this%id == num_model%id)
 
  end function eq_numerical_model
 
  !> @brief Returns a virtual model with the specified id
  !< from the global list, or null
  function get_virtual_model_by_id(model_id) result(virtual_model)
    use virtualdatalistsmodule, only: virtual_model_list
    integer(I4B) :: model_id
    class(virtualmodeltype), pointer :: virtual_model
    ! local
    integer(I4B) :: i
    class(*), pointer :: vm
 
    virtual_model => null()
    do i = 1, virtual_model_list%Count()
      vm => virtual_model_list%GetItem(i)
      select type (vm)
      class is (virtualmodeltype)
        if (vm%id == model_id) then
          virtual_model => vm
          return
        end if
      end select
    end do
 
  end function get_virtual_model_by_id
 
  !> @brief Returns a virtual model with the specified name
  !< from the global list, or null
  function get_virtual_model_by_name(model_name) result(virtual_model)
    use virtualdatalistsmodule, only: virtual_model_list
    character(len=*) :: model_name
    class(virtualmodeltype), pointer :: virtual_model
    ! local
    integer(I4B) :: i
    class(*), pointer :: vm
 
    virtual_model => null()
    do i = 1, virtual_model_list%Count()
      vm => virtual_model_list%GetItem(i)
      select type (vm)
      class is (virtualmodeltype)
        if (vm%name == model_name) then
          virtual_model => vm
          return
        end if
      end select
    end do
 
  end function get_virtual_model_by_name
 
end module virtualmodelmodule