VirtualBase.f90

Go to the documentation of this file.

module virtualbasemodule
  use kindmodule, only: i4b, dp, lgp
  use listmodule
  use constantsmodule, only: lenvarname, lenmempath, lencomponentname
  use memorytypemodule, only: memorytype
  use memorymanagermodule, only: mem_allocate, mem_deallocate, &
                                 get_from_memorystore
  implicit none
  private
 
  public :: get_virtual_data_from_list
 
  integer(I4B), public, parameter :: map_all_type = 0
  integer(I4B), public, parameter :: map_node_type = 1
  integer(I4B), public, parameter :: map_conn_type = 2
  integer(I4B), public, parameter :: nr_vdc_element_maps = 2
 
  !> This is a generic data structure to virtualize pieces
  !! of memory in 2 distinct ways:
  !!
  !!  1) Virtualize remote memory
  !!  This concerns memory residing on another process.
  !!  Typically, these pieces are subsets of certain model
  !!  and exchange data and lookup tables are kept with the
  !!  data to manage their mapping. The stage(s) at which
  !!  to synchronize the virtual memory is stored as well.
  !!
  !!  2) Virtualize local memory
  !!  In this case no virtual memory item is created, no
  !!  lookup tables and synchronization are necessary.
  !!  The virtual memory item will be pointed to the
  !!  original memory location at the requested
  !!  synchronization stage.
  !<
  type, abstract, public :: virtualdatatype
    logical(LGP) :: is_remote = .false. !< is remote memory, when true (default is false)
    character(len=LENVARNAME) :: var_name !< variable name
    character(len=LENCOMPONENTNAME) :: subcmp_name !< subcomponent name, e.g. package name
    character(len=LENMEMPATH) :: mem_path !< memory path
    integer(I4B), dimension(:), allocatable :: sync_stages !< stage(s) at which to synchronize
    integer(I4B) :: map_type !< the type of map
    logical(LGP) :: is_reduced !< when true, the discontinuous remote data is compressed
                               !! into contiguous virtual memory
    integer(I4B), dimension(:), &
      pointer, contiguous :: remote_elem_shift => null() !< contiguous list with 0-based remote indexes
                                !! (this is important for creating mpi data types)
    integer(I4B), dimension(:), &
      pointer, contiguous :: remote_to_virtual => null() !< sparse list which maps remote index to virtual
    type(memorytype), pointer :: virtual_mt => null()
  contains
    procedure(vm_allocate_if), deferred :: vm_allocate
    procedure(vm_deallocate_if), deferred :: vm_deallocate
    procedure :: base => vm_to_base
    procedure :: check_stage => vm_check_stage
    procedure :: link => vm_link
    procedure :: get_element_map
  end type
 
  type, public, extends(virtualdatatype) :: virtualinttype
    integer(I4B), private, pointer :: intsclr
  contains
    procedure :: vm_allocate => vm_allocate_int
    procedure :: vm_deallocate => vm_deallocate_int
    procedure :: get => get_int
  end type
 
  type, public, extends(virtualdatatype) :: virtualint1dtype
    integer(I4B), dimension(:), pointer, contiguous :: int1d
  contains
    procedure :: vm_allocate => vm_allocate_int1d
    procedure :: vm_deallocate => vm_deallocate_int1d
    procedure :: get => get_int1d
    procedure :: get_array => get_array_int1d
  end type
 
  type, public, extends(virtualdatatype) :: virtualdbltype
    real(dp), private, pointer :: dblsclr
  contains
    procedure :: vm_allocate => vm_allocate_dbl
    procedure :: vm_deallocate => vm_deallocate_dbl
    procedure :: get => get_dbl
  end type
 
  type, public, extends(virtualdatatype) :: virtualdbl1dtype
    real(dp), dimension(:), pointer, contiguous :: dbl1d
  contains
    procedure :: vm_allocate => vm_allocate_dbl1d
    procedure :: vm_deallocate => vm_deallocate_dbl1d
    procedure :: get => get_dbl1d
    procedure :: get_array => get_array_dbl1d
  end type
 
  type, public, extends(virtualdatatype) :: virtualdbl2dtype
    real(dp), dimension(:, :), pointer, contiguous :: dbl2d
  contains
    procedure :: vm_allocate => vm_allocate_dbl2d
    procedure :: vm_deallocate => vm_deallocate_dbl2d
    procedure :: get => get_dbl2d
    procedure :: get_array => get_array_dbl2d
  end type
 
  ! etc...
  abstract interface
    subroutine vm_allocate_if(this, var_name, mem_path, shape)
      import virtualdatatype, i4b
      class(virtualdatatype) :: this
      character(len=*) :: var_name
      character(len=*) :: mem_path
      integer(I4B), dimension(:) :: shape
    end subroutine vm_allocate_if
    subroutine vm_deallocate_if(this)
      import virtualdatatype
      class(virtualdatatype) :: this
    end subroutine vm_deallocate_if
  end interface
 
contains
 
  function vm_to_base(this) result(base_ptr)
    class(virtualdatatype), target :: this
    class(virtualdatatype), pointer :: base_ptr
 
    base_ptr => this
 
  end function vm_to_base
 
  !> @brief Check if this data item requires syncing
  !< for this particular stage
  function vm_check_stage(this, stage) result(has_stage)
    use arrayhandlersmodule, only: ifind
    class(virtualdatatype), target :: this
    integer(I4B) :: stage, stg_idx
    logical(LGP) :: has_stage
 
    has_stage = .false.
    if (allocated(this%sync_stages)) then
      stg_idx = ifind(this%sync_stages, stage)
      has_stage = (stg_idx > 0)
    end if
 
  end function vm_check_stage
 
  subroutine vm_link(this)
    class(virtualdatatype), target :: this
    ! local
    logical(LGP) :: found
 
    call get_from_memorystore(this%var_name, this%mem_path, &
                              this%virtual_mt, found)
 
  end subroutine vm_link
 
  !> @brief Return array with offsets for elements
  !< mapped in this virtual data item
  function get_element_map(this) result(el_map)
    class(virtualdatatype), target :: this
    integer(I4B), dimension(:), pointer, contiguous :: el_map
 
    el_map => null()
    if (this%map_type > 0) then
      el_map => this%remote_elem_shift
    end if
 
  end function get_element_map
 
  subroutine vm_allocate_int(this, var_name, mem_path, shape)
    class(virtualinttype) :: this
    character(len=*) :: var_name
    character(len=*) :: mem_path
    integer(I4B), dimension(:) :: shape
 
    call mem_allocate(this%intsclr, var_name, mem_path)
 
  end subroutine vm_allocate_int
 
  subroutine vm_deallocate_int(this)
    class(virtualinttype) :: this
 
    if (this%is_remote) call mem_deallocate(this%intsclr)
 
  end subroutine vm_deallocate_int
 
  subroutine vm_allocate_int1d(this, var_name, mem_path, shape)
    class(virtualint1dtype) :: this
    character(len=*) :: var_name
    character(len=*) :: mem_path
    integer(I4B), dimension(:) :: shape
 
    call mem_allocate(this%int1d, shape(1), var_name, mem_path)
 
  end subroutine vm_allocate_int1d
 
  subroutine vm_deallocate_int1d(this)
    class(virtualint1dtype) :: this
 
    if (this%is_remote) call mem_deallocate(this%int1d)
 
  end subroutine vm_deallocate_int1d
 
  subroutine vm_allocate_dbl(this, var_name, mem_path, shape)
    class(virtualdbltype) :: this
    character(len=*) :: var_name
    character(len=*) :: mem_path
    integer(I4B), dimension(:) :: shape
 
    call mem_allocate(this%dblsclr, var_name, mem_path)
 
  end subroutine vm_allocate_dbl
 
  subroutine vm_deallocate_dbl(this)
    class(virtualdbltype) :: this
 
    if (this%is_remote) call mem_deallocate(this%dblsclr)
 
  end subroutine vm_deallocate_dbl
 
  subroutine vm_allocate_dbl1d(this, var_name, mem_path, shape)
    class(virtualdbl1dtype) :: this
    character(len=*) :: var_name
    character(len=*) :: mem_path
    integer(I4B), dimension(:) :: shape
 
    call mem_allocate(this%dbl1d, shape(1), var_name, mem_path)
 
  end subroutine vm_allocate_dbl1d
 
  subroutine vm_deallocate_dbl1d(this)
    class(virtualdbl1dtype) :: this
 
    if (this%is_remote) call mem_deallocate(this%dbl1d)
 
  end subroutine vm_deallocate_dbl1d
 
  subroutine vm_allocate_dbl2d(this, var_name, mem_path, shape)
    class(virtualdbl2dtype) :: this
    character(len=*) :: var_name
    character(len=*) :: mem_path
    integer(I4B), dimension(:) :: shape
 
    call mem_allocate(this%dbl2d, shape(1), shape(2), var_name, mem_path)
 
  end subroutine vm_allocate_dbl2d
 
  subroutine vm_deallocate_dbl2d(this)
    class(virtualdbl2dtype) :: this
 
    if (this%is_remote) call mem_deallocate(this%dbl2d)
 
  end subroutine vm_deallocate_dbl2d
 
  function get_int(this) result(val)
    class(virtualinttype) :: this
    integer(I4B) :: val
 
    val = this%virtual_mt%intsclr
 
  end function get_int
 
  function get_int1d(this, i_rmt) result(val)
    class(virtualint1dtype) :: this
    integer(I4B) :: i_rmt
    integer(I4B) :: val
    ! local
    integer(I4B) :: i_vrt
 
    if (this%is_reduced) then
      i_vrt = this%remote_to_virtual(i_rmt)
    else
      i_vrt = i_rmt
    end if
    val = this%virtual_mt%aint1d(i_vrt)
 
  end function get_int1d
 
  function get_array_int1d(this) result(array)
    class(virtualint1dtype) :: this
    integer(I4B), dimension(:), pointer, contiguous :: array
 
    array => this%virtual_mt%aint1d
 
  end function get_array_int1d
 
  function get_dbl(this) result(val)
    class(virtualdbltype) :: this
    real(dp) :: val
 
    val = this%virtual_mt%dblsclr
 
  end function get_dbl
 
  function get_dbl1d(this, i_rmt) result(val)
    class(virtualdbl1dtype) :: this
    integer(I4B) :: i_rmt
    real(dp) :: val
    ! local
    integer(I4B) :: i_vrt
 
    if (this%is_reduced) then
      i_vrt = this%remote_to_virtual(i_rmt)
    else
      i_vrt = i_rmt
    end if
    val = this%virtual_mt%adbl1d(i_vrt)
 
  end function get_dbl1d
 
  function get_array_dbl1d(this) result(array)
    class(virtualdbl1dtype) :: this
    real(dp), dimension(:), pointer, contiguous :: array
 
    array => this%virtual_mt%adbl1d
 
  end function get_array_dbl1d
 
  function get_dbl2d(this, j_cmp, i_rmt) result(val)
    class(virtualdbl2dtype) :: this
    integer(I4B) :: j_cmp
    integer(I4B) :: i_rmt
    real(dp) :: val
    ! local
    integer(I4B) :: i_vrt
 
    if (this%is_reduced) then
      i_vrt = this%remote_to_virtual(i_rmt)
    else
      i_vrt = i_rmt
    end if
    val = this%virtual_mt%adbl2d(j_cmp, i_vrt)
 
  end function get_dbl2d
 
  function get_array_dbl2d(this) result(array)
    class(virtualdbl2dtype) :: this
    real(dp), dimension(:, :), pointer, contiguous :: array
 
    array => this%virtual_mt%adbl2d
 
  end function get_array_dbl2d
 
  function get_virtual_data_from_list(list, idx) result(vd)
    type(listtype) :: list
    integer(I4B) :: idx
    class(virtualdatatype), pointer :: vd
    ! local
    class(*), pointer :: obj_ptr
 
    vd => null()
    obj_ptr => list%GetItem(idx)
    select type (obj_ptr)
    class is (virtualdatatype)
      vd => obj_ptr
    end select
 
  end function get_virtual_data_from_list
 
end module virtualbasemodule