registry_entry.f90

Go to the documentation of this file.

! Copyright (c) 2025-2026, The Neko Authors
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
!
!   * Redistributions of source code must retain the above copyright
!     notice, this list of conditions and the following disclaimer.
!
!   * Redistributions in binary form must reproduce the above
!     copyright notice, this list of conditions and the following
!     disclaimer in the documentation and/or other materials provided
!     with the distribution.
!
!   * Neither the name of the authors nor the names of its
!     contributors may be used to endorse or promote products derived
!     from this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
! FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
! INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
! BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
! ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
module registry_entry
  use num_types, only : rp
  use host_array, only : host_array_t
  use device_array, only : device_array_t
  use vector, only : vector_t
  use matrix, only : matrix_t
  use tensor3, only : tensor3_t
  use tensor4, only : tensor4_t
  use field, only : field_t
 
  use dofmap, only : dofmap_t
  use utils, only : neko_error
  implicit none
  private
 
  type, public :: registry_entry_t
     character(len=80), private :: name = ""
     character(len=80), private :: type = ""
     logical, private :: allocated = .false.
 
     ! Storage. Only one of these will be allocated at a time.
     real(kind=rp), private :: real_scalar = 0.0_rp
     integer, private :: integer_scalar = 0
 
     ! Array objects
     type(host_array_t), private, pointer :: host_array_ptr => null()
     type(device_array_t), private, pointer :: device_array_ptr => null()
 
     ! Mathematical objects
     type(vector_t), private, pointer :: vector_ptr => null()
     type(matrix_t), private, pointer :: matrix_ptr => null()
     type(tensor3_t), private, pointer :: tensor3_ptr => null()
     type(tensor4_t), private, pointer :: tensor4_ptr => null()
 
     ! Complex objects
     type(field_t), private, pointer :: field_ptr => null()
 
   contains
     ! Constructors
     procedure, pass(this) :: init_real_scalar => init_register_real_scalar
     procedure, pass(this) :: init_integer_scalar => &
          init_register_integer_scalar
     procedure, pass(this) :: init_host_array => init_register_host_array
     procedure, pass(this) :: init_device_array => init_register_device_array
     procedure, pass(this) :: init_vector => init_register_vector
     procedure, pass(this) :: init_matrix => init_register_matrix
     procedure, pass(this) :: init_tensor3 => init_register_tensor3
     procedure, pass(this) :: init_tensor4 => init_register_tensor4
     procedure, pass(this) :: init_field => init_register_field
 
     procedure, pass(this) :: free => free_register
 
     procedure, pass(this) :: get_name
     procedure, pass(this) :: get_type
     procedure, pass(this) :: get_real_scalar
     procedure, pass(this) :: get_integer_scalar
     procedure, pass(this) :: get_host_array
     procedure, pass(this) :: get_device_array
     procedure, pass(this) :: get_vector
     procedure, pass(this) :: get_matrix
     procedure, pass(this) :: get_tensor3
     procedure, pass(this) :: get_tensor4
     procedure, pass(this) :: get_field
 
     procedure, pass(this) :: is_allocated
     procedure, pass(this) :: is_type
     procedure, pass(this) :: move_from => move_from_registry_entry
  end type registry_entry_t
 
contains
 
  subroutine init_register_host_array(this, n, name)
    class(registry_entry_t), intent(inout) :: this
    integer, intent(in) :: n
    character(len=*), optional, intent(in) :: name
 
    if (this%allocated) then
       call neko_error("init_register_host_array: " // &
            "Register entry is already allocated.")
    end if
 
    call this%free()
 
    allocate(this%host_array_ptr)
    call this%host_array_ptr%init(n)
 
    if (present(name)) this%name = trim(name)
    this%type = 'host_array'
    this%allocated = .true.
 
  end subroutine init_register_host_array
 
  subroutine init_register_device_array(this, n, name)
    class(registry_entry_t), intent(inout) :: this
    integer, intent(in) :: n
    character(len=*), optional, intent(in) :: name
 
    if (this%allocated) then
       call neko_error("init_register_device_array: " // &
            "Register entry is already allocated.")
    end if
 
    call this%free()
 
    allocate(this%device_array_ptr)
    call this%device_array_ptr%init(n)
 
    if (present(name)) this%name = trim(name)
    this%type = 'device_array'
    this%allocated = .true.
 
  end subroutine init_register_device_array
 
  subroutine init_register_vector(this, n, name)
    class(registry_entry_t), intent(inout) :: this
    integer, intent(in) :: n
    character(len=*), optional, intent(in) :: name
 
    if (this%allocated) then
       call neko_error("init_register_vector: " &
            // "Register entry is already allocated.")
    end if
 
    call this%free()
 
    allocate(this%vector_ptr)
    call this%vector_ptr%init(n)
 
    if (present(name)) this%name = trim(name)
    this%type = 'vector'
    this%allocated = .true.
 
  end subroutine init_register_vector
 
  subroutine init_register_matrix(this, nrows, ncols, name)
    class(registry_entry_t), intent(inout) :: this
    integer, intent(in) :: nrows, ncols
    character(len=*), optional, intent(in) :: name
 
    if (this%allocated) then
       call neko_error("init_register_matrix: " &
            // "Register entry is already allocated.")
    end if
 
    call this%free()
 
    allocate(this%matrix_ptr)
    call this%matrix_ptr%init(nrows, ncols)
 
    if (present(name)) this%name = trim(name)
    this%type = 'matrix'
    this%allocated = .true.
 
  end subroutine init_register_matrix
 
  subroutine init_register_tensor3(this, n, m, l, name)
    class(registry_entry_t), intent(inout) :: this
    integer, intent(in) :: n, m, l
    character(len=*), optional, intent(in) :: name
 
    if (this%allocated) then
       call neko_error("init_register_tensor3: " &
            // "Register entry is already allocated.")
    end if
 
    call this%free()
 
    allocate(this%tensor3_ptr)
    call this%tensor3_ptr%init(n, m, l)
 
    if (present(name)) this%name = trim(name)
    this%type = 'tensor3'
    this%allocated = .true.
 
  end subroutine init_register_tensor3
 
  subroutine init_register_tensor4(this, n, m, l, k, name)
    class(registry_entry_t), intent(inout) :: this
    integer, intent(in) :: n, m, l, k
    character(len=*), optional, intent(in) :: name
 
    if (this%allocated) then
       call neko_error("init_register_tensor4: " &
            // "Register entry is already allocated.")
    end if
 
    call this%free()
 
    allocate(this%tensor4_ptr)
    call this%tensor4_ptr%init(n, m, l, k)
 
    if (present(name)) this%name = trim(name)
    this%type = 'tensor4'
    this%allocated = .true.
 
  end subroutine init_register_tensor4
 
  subroutine init_register_field(this, dof, name)
    class(registry_entry_t), intent(inout) :: this
    type(dofmap_t), target, intent(in) :: dof
    character(len=*), intent(in) :: name
 
    if (this%allocated) then
       call neko_error("init_register_field: " &
            // "Register entry is already allocated.")
    end if
 
    call this%free()
 
    allocate(this%field_ptr)
    call this%field_ptr%init(dof, trim(name))
 
    this%name = trim(name)
    this%type = 'field'
    this%allocated = .true.
 
  end subroutine init_register_field
 
  subroutine init_register_real_scalar(this, val, name)
    class(registry_entry_t), intent(inout) :: this
    real(kind=rp), intent(in) :: val
    character(len=*), optional, intent(in) :: name
 
    if (this%allocated) then
       call neko_error("init_register_real_scalar: " &
            // "Register entry is already allocated.")
    end if
 
    call this%free()
 
    this%real_scalar = val
 
    if (present(name)) this%name = trim(name)
    this%type = 'real_scalar'
    this%allocated = .true.
 
  end subroutine init_register_real_scalar
 
  subroutine init_register_integer_scalar(this, val, name)
    class(registry_entry_t), intent(inout) :: this
    integer, intent(in) :: val
    character(len=*), optional, intent(in) :: name
 
    if (this%allocated) then
       call neko_error("init_register_integer_scalar: " &
            // "Register entry is already allocated.")
    end if
 
    call this%free()
 
    this%integer_scalar = val
 
    if (present(name)) this%name = trim(name)
    this%type = 'integer_scalar'
    this%allocated = .true.
 
  end subroutine init_register_integer_scalar
 
  subroutine free_register(this)
    class(registry_entry_t), intent(inout) :: this
 
    if (associated(this%host_array_ptr)) then
       call this%host_array_ptr%free()
       deallocate(this%host_array_ptr)
    end if
 
    if (associated(this%device_array_ptr)) then
       call this%device_array_ptr%free()
       deallocate(this%device_array_ptr)
    end if
 
    if (associated(this%vector_ptr)) then
       call this%vector_ptr%free()
       deallocate(this%vector_ptr)
    end if
 
    if (associated(this%matrix_ptr)) then
       call this%matrix_ptr%free()
       deallocate(this%matrix_ptr)
    end if
 
    if (associated(this%tensor3_ptr)) then
       call this%tensor3_ptr%free()
       deallocate(this%tensor3_ptr)
    end if
 
    if (associated(this%tensor4_ptr)) then
       call this%tensor4_ptr%free()
       deallocate(this%tensor4_ptr)
    end if
 
    if (associated(this%field_ptr)) then
       call this%field_ptr%free()
       deallocate(this%field_ptr)
    end if
 
    this%real_scalar = 0.0_rp
    this%integer_scalar = 0
 
    this%name = ""
    this%type = ""
    this%allocated = .false.
 
  end subroutine free_register
 
  pure function get_name(this) result(name)
    class(registry_entry_t), intent(in) :: this
    character(len=:), allocatable :: name
    name = trim(this%name)
  end function get_name
 
  pure function get_type(this) result(type)
    class(registry_entry_t), intent(in) :: this
    character(len=:), allocatable :: type
    type = trim(this%type)
  end function get_type
 
  pure function is_allocated(this) result(allocated)
    class(registry_entry_t), intent(in) :: this
    logical :: allocated
    allocated = this%allocated
  end function is_allocated
 
  pure logical function is_type(this, type_str)
    class(registry_entry_t), intent(in) :: this
    character(len=*), intent(in) :: type_str
    is_type = trim(this%type) .eq. trim(type_str)
  end function is_type
 
  function get_host_array(this) result(host_array_ptr)
    class(registry_entry_t), target, intent(in) :: this
    type(host_array_t), pointer :: host_array_ptr
    if (this%get_type() .ne. 'host_array') then
       call neko_error("registry_entry::get_host_array: " &
            // "Registry entry is not of type 'host_array'.")
    end if
    host_array_ptr => this%host_array_ptr
  end function get_host_array
 
  function get_device_array(this) result(device_array_ptr)
    class(registry_entry_t), target, intent(in) :: this
    type(device_array_t), pointer :: device_array_ptr
    if (this%get_type() .ne. 'device_array') then
       call neko_error("registry_entry::get_device_array: " &
            // "Registry entry is not of type 'device_array'.")
    end if
    device_array_ptr => this%device_array_ptr
  end function get_device_array
 
  function get_vector(this) result(vector_ptr)
    class(registry_entry_t), target, intent(in) :: this
    type(vector_t), pointer :: vector_ptr
    if (this%get_type() .ne. 'vector') then
       call neko_error("registry_entry::get_vector: " &
            // "Registry entry is not of type 'vector'.")
    end if
    vector_ptr => this%vector_ptr
  end function get_vector
 
  function get_matrix(this) result(matrix_ptr)
    class(registry_entry_t), target, intent(in) :: this
    type(matrix_t), pointer :: matrix_ptr
    if (this%get_type() .ne. 'matrix') then
       call neko_error("registry_entry::get_field: " &
            // "Registry entry is not of type 'matrix'.")
    end if
    matrix_ptr => this%matrix_ptr
  end function get_matrix
 
  function get_tensor3(this) result(tensor3_ptr)
    class(registry_entry_t), target, intent(in) :: this
    type(tensor3_t), pointer :: tensor3_ptr
    if (this%get_type() .ne. 'tensor3') then
       call neko_error("registry_entry::get_field: " &
            // "Registry entry is not of type 'tensor3'.")
    end if
    tensor3_ptr => this%tensor3_ptr
  end function get_tensor3
 
  function get_tensor4(this) result(tensor4_ptr)
    class(registry_entry_t), target, intent(in) :: this
    type(tensor4_t), pointer :: tensor4_ptr
    if (this%get_type() .ne. 'tensor4') then
       call neko_error("registry_entry::get_field: " &
            // "Registry entry is not of type 'tensor4'.")
    end if
    tensor4_ptr => this%tensor4_ptr
  end function get_tensor4
 
  function get_field(this) result(field_ptr)
    class(registry_entry_t), target, intent(in) :: this
    type(field_t), pointer :: field_ptr
    if (this%get_type() .ne. 'field') then
       call neko_error("registry_entry::get_field: " &
            // "Registry entry is not of type 'field'.")
    end if
    field_ptr => this%field_ptr
  end function get_field
 
  function get_real_scalar(this) result(scalar_ptr)
    class(registry_entry_t), target, intent(in) :: this
    real(kind=rp), pointer :: scalar_ptr
    if (this%get_type() .ne. 'real_scalar') then
       call neko_error("registry_entry::get_real_scalar: " &
            // "Registry entry is not of type 'real_scalar'.")
    end if
    scalar_ptr => this%real_scalar
  end function get_real_scalar
 
  function get_integer_scalar(this) result(scalar_ptr)
    class(registry_entry_t), target, intent(in) :: this
    integer, pointer :: scalar_ptr
    if (this%get_type() .ne. 'integer_scalar') then
       call neko_error("registry_entry::get_integer_scalar: " &
            // "Registry entry is not of type 'integer_scalar'.")
    end if
    scalar_ptr => this%integer_scalar
  end function get_integer_scalar
 
  subroutine move_from_registry_entry(this, source)
    class(registry_entry_t), intent(inout) :: this
    class(registry_entry_t), intent(inout) :: source
 
    if (.not. source%is_allocated()) return
    call this%free()
 
    this%name = source%name
    this%type = source%type
    this%allocated = source%allocated
 
    select case (trim(this%type))
    case ('real_scalar')
       this%real_scalar = source%real_scalar
    case ('integer_scalar')
       this%integer_scalar = source%integer_scalar
    case ('host_array')
       this%host_array_ptr => source%host_array_ptr
       nullify(source%host_array_ptr)
    case ('device_array')
       this%device_array_ptr => source%device_array_ptr
       nullify(source%device_array_ptr)
    case ('vector')
       this%vector_ptr => source%vector_ptr
       nullify(source%vector_ptr)
    case ('matrix')
       this%matrix_ptr => source%matrix_ptr
       nullify(source%matrix_ptr)
    case ('tensor3')
       this%tensor3_ptr => source%tensor3_ptr
       nullify(source%tensor3_ptr)
    case ('tensor4')
       this%tensor4_ptr => source%tensor4_ptr
       nullify(source%tensor4_ptr)
    case ('field')
       this%field_ptr => source%field_ptr
       nullify(source%field_ptr)
    case default
       call neko_error("move_from_registry_entry: " // &
            "Unsupported registry entry type: " // trim(this%type))
    end select
 
    ! Free the source entry after moving
    call source%free()
 
  end subroutine move_from_registry_entry
end module registry_entry