registry.f90

Go to the documentation of this file.

! Copyright (c) 2018-2025, 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
  use, intrinsic :: iso_fortran_env, only: error_unit
  use field, only : field_t
  use vector, only : vector_t
  use matrix, only : matrix_t
  use registry_entry, only : registry_entry_t
  use dofmap, only : dofmap_t
  use utils, only : neko_error
  use htable, only : h_cptr_t
  use utils, only: neko_error
  use comm, only : pe_rank
  use json_module, only : json_file
  use json_utils, only : json_get
  use logger, only : neko_log, log_size
  implicit none
  private
 
  type, public :: registry_t
     type(registry_entry_t), private, allocatable :: entries(:)
     type(json_file), private :: aliases
     integer, private :: n_entries_ = 0
     integer, private :: n_aliases_ = 0
     integer, private :: expansion_size_ = 5
   contains
     procedure, pass(this) :: init => registry_init
     procedure, pass(this) :: free => registry_free
     procedure, private, pass(this) :: expand => registry_expand
 
     procedure, pass(this) :: add_field => registry_add_field
     procedure, pass(this) :: add_vector => registry_add_vector
     procedure, pass(this) :: add_matrix => registry_add_matrix
     procedure, pass(this) :: add_alias => registry_add_alias
 
     procedure, pass(this) :: get_field_by_index => registry_get_field_by_index
     procedure, pass(this) :: get_vector_by_index => &
          registry_get_vector_by_index
     procedure, pass(this) :: get_matrix_by_index => &
          registry_get_matrix_by_index
 
     procedure, pass(this) :: get_field_by_name => registry_get_field_by_name
     procedure, pass(this) :: get_vector_by_name => registry_get_vector_by_name
     procedure, pass(this) :: get_matrix_by_name => registry_get_matrix_by_name
 
     generic :: get_field => get_field_by_index, get_field_by_name
     generic :: get_vector => get_vector_by_index, get_vector_by_name
     generic :: get_matrix => get_matrix_by_index, get_matrix_by_name
 
     procedure, pass(this) :: entry_exists => registry_entry_exists
     procedure, pass(this) :: field_exists => registry_field_exists
     procedure, pass(this) :: vector_exists => registry_vector_exists
     procedure, pass(this) :: matrix_exists => registry_matrix_exists
 
     procedure, pass(this) :: get_size => registry_get_size
     procedure, pass(this) :: n_entries => registry_n_entries
     procedure, pass(this) :: n_fields => registry_n_fields
     procedure, pass(this) :: n_vectors => registry_n_vectors
     procedure, pass(this) :: n_matrices => registry_n_matrices
     procedure, pass(this) :: n_aliases => registry_n_aliases
     procedure, pass(this) :: get_expansion_size => registry_get_expansion_size
  end type registry_t
 
  type(registry_t), public, target :: neko_registry
 
contains
  ! ========================================================================== !
  ! Constructors/Destructors
 
  subroutine registry_init(this, size, expansion_size)
    class(registry_t), intent(inout):: this
    integer, optional, intent(in) :: size
    integer, optional, intent(in) :: expansion_size
 
    call this%free()
 
    if (present(size)) then
       allocate(this%entries(size))
    else
       allocate(this%entries(25))
    end if
 
    call this%aliases%initialize()
 
    if (present(expansion_size)) then
       this%expansion_size_ = expansion_size
    end if
 
  end subroutine registry_init
 
  subroutine registry_free(this)
    class(registry_t), intent(inout):: this
    integer :: i
 
    if (allocated(this%entries)) then
       do i = 1, this%n_entries()
          call this%entries(i)%free()
       end do
       deallocate(this%entries)
    end if
 
    call this%aliases%destroy()
 
    this%n_entries_ = 0
    this%n_aliases_ = 0
    this%expansion_size_ = 5
  end subroutine registry_free
 
  subroutine registry_expand(this)
    class(registry_t), intent(inout) :: this
    type(registry_entry_t), allocatable :: temp(:)
 
    allocate(temp(this%n_entries_ + this%expansion_size_))
    temp(1:this%n_entries_) = this%entries(1:this%n_entries_)
    call move_alloc(temp, this%entries)
  end subroutine registry_expand
 
  ! ========================================================================== !
  ! Methods for adding objects to the registry
 
  subroutine registry_add_field(this, dof, name, ignore_existing)
    class(registry_t), intent(inout) :: this
    type(dofmap_t), target, intent(in) :: dof
    character(len=*), target, intent(in) :: name
    logical, optional, intent(in) :: ignore_existing
    logical :: ignore_existing_
 
    ignore_existing_ = .false.
    if (present(ignore_existing)) then
       ignore_existing_ = ignore_existing
    end if
 
    if (this%field_exists(name)) then
       if (ignore_existing_) then
          return
       else
          call neko_error("Field with name " // name // &
               " is already registered")
       end if
    end if
 
    if (this%n_entries() .eq. this%get_size()) then
       call this%expand()
    end if
 
    this%n_entries_ = this%n_entries_ + 1
 
    ! initialize the field at the appropriate index
    call this%entries(this%n_entries_)%init_field(dof, name)
 
  end subroutine registry_add_field
 
  subroutine registry_add_vector(this, n, name, ignore_existing)
    class(registry_t), intent(inout) :: this
    integer, intent(in) :: n
    character(len=*), target, intent(in) :: name
    logical, optional, intent(in) :: ignore_existing
    logical :: ignore_existing_
 
    ignore_existing_ = .false.
    if (present(ignore_existing)) then
       ignore_existing_ = ignore_existing
    end if
 
    if (this%vector_exists(name)) then
       if (ignore_existing_) then
          return
       else
          call neko_error("Vector with name " // name // &
               " is already registered")
       end if
    end if
 
    if (this%n_entries() .eq. this%get_size()) then
       call this%expand()
    end if
 
    this%n_entries_ = this%n_entries_ + 1
 
    ! Initialize the named vector at the appropriate index
    call this%entries(this%n_entries_)%init_vector(n, name)
 
  end subroutine registry_add_vector
 
  subroutine registry_add_matrix(this, nrows, ncols, name, ignore_existing)
    class(registry_t), intent(inout) :: this
    integer, intent(in) :: nrows, ncols
    character(len=*), target, intent(in) :: name
    logical, optional, intent(in) :: ignore_existing
    logical :: ignore_existing_
 
    ignore_existing_ = .false.
    if (present(ignore_existing)) then
       ignore_existing_ = ignore_existing
    end if
 
    if (this%matrix_exists(name)) then
       if (ignore_existing_) then
          return
       else
          call neko_error("Vector with name " // name // &
               " is already registered")
       end if
    end if
 
    if (this%n_entries() .eq. this%get_size()) then
       call this%expand()
    end if
 
    this%n_entries_ = this%n_entries_ + 1
 
    ! Initialize the named matrix at the appropriate index
    call this%entries(this%n_entries_)%init_matrix(nrows, ncols, name)
 
  end subroutine registry_add_matrix
 
  subroutine registry_add_alias(this, alias, name)
    class(registry_t), intent(inout) :: this
    character(len=*), intent(in) :: alias
    character(len=*), intent(in) :: name
 
    if (this%entry_exists(alias)) then
       call neko_error("Cannot create alias. Entry " // alias // &
            " already exists in the registry")
    end if
 
    if (this%entry_exists(name)) then
       this%n_aliases_ = this%n_aliases_ + 1
       call this%aliases%add(trim(alias), trim(name))
    else
       call neko_error("Cannot create alias. Entry " // name // &
            " could not be found in the registry")
    end if
  end subroutine registry_add_alias
 
  ! ========================================================================== !
  ! Methods for retrieving objects from the registry by index
 
  function registry_get_field_by_index(this, i) result(f)
    class(registry_t), target, intent(in) :: this
    integer, intent(in) :: i
    type(field_t), pointer :: f
    character(len=:), allocatable :: buffer
 
    if (i < 1) then
       call neko_error("Field index must be > 1")
    else if (i > this%n_entries()) then
       call neko_error("Field index exceeds number of stored fields")
    endif
 
    if (this%entries(i)%get_type() .ne. 'field') then
       write(buffer, *) "Requested index ", i, " is not a field, but a ", &
            this%entries(i)%get_type()
       call neko_error(buffer)
    end if
 
    f => this%entries(i)%get_field()
  end function registry_get_field_by_index
 
  function registry_get_vector_by_index(this, i) result(f)
    class(registry_t), target, intent(in) :: this
    integer, intent(in) :: i
    type(vector_t), pointer :: f
    character(len=:), allocatable :: buffer
 
    if (i < 1) then
       call neko_error("Vector index must be > 1")
    else if (i > this%n_entries()) then
       call neko_error("Vector index exceeds number of stored vectors")
    endif
 
    if (this%entries(i)%get_type() .ne. 'vector') then
       write(buffer, *) "Requested index ", i, " is not a vector, but a ", &
            this%entries(i)%get_type()
       call neko_error(buffer)
    end if
 
    f => this%entries(i)%get_vector()
  end function registry_get_vector_by_index
 
  function registry_get_matrix_by_index(this, i) result(f)
    class(registry_t), target, intent(in) :: this
    integer, intent(in) :: i
    type(matrix_t), pointer :: f
    character(len=:), allocatable :: buffer
 
    if (i < 1) then
       call neko_error("Matrix index must be > 1")
    else if (i > this%n_entries()) then
       call neko_error("Matrix index exceeds number of stored matrices")
    endif
 
    if (this%entries(i)%get_type() .ne. 'matrix') then
       write(buffer, *) "Requested index ", i, " is not a matrix, but a ", &
            this%entries(i)%get_type()
       call neko_error(buffer)
    end if
 
    f => this%entries(i)%get_matrix()
  end function registry_get_matrix_by_index
 
  ! ========================================================================== !
  ! Methods for retrieving objects from the registry by name
 
  recursive function registry_get_field_by_name(this, name) result(f)
    class(registry_t), target, intent(inout) :: this
    character(len=*), intent(in) :: name
    character(len=:), allocatable :: alias_target
    type(field_t), pointer :: f
    logical :: found
    integer :: i
 
    do i = 1, this%n_entries()
       if (this%entries(i)%get_type() .eq. 'field' .and. &
            this%entries(i)%get_name() .eq. trim(name)) then
          f => this%entries(i)%get_field()
          return
       end if
    end do
 
    call this%aliases%get(name, alias_target, found)
    if (found) then
       f => this%get_field_by_name(alias_target)
       return
    end if
 
    if (pe_rank .eq. 0) then
       write(error_unit, *) "Current registry contents:"
 
       do i = 1, this%n_entries()
          write(error_unit, *) "- ", this%entries(i)%get_name()
       end do
    end if
    call neko_error("Field " // name // " could not be found in the registry")
 
  end function registry_get_field_by_name
 
 
  recursive function registry_get_vector_by_name(this, name) result(f)
    class(registry_t), target, intent(inout) :: this
    character(len=*), intent(in) :: name
    character(len=:), allocatable :: alias_target
    type(vector_t), pointer :: f
    logical :: found
    integer :: i
 
    found = .false.
 
    do i = 1, this%n_entries()
       if (this%entries(i)%get_type() .eq. 'vector' .and. &
            this%entries(i)%get_name() .eq. trim(name)) then
          f => this%entries(i)%get_vector()
          return
       end if
    end do
 
    call this%aliases%get(name, alias_target, found)
    if (found) then
       f => this%get_vector_by_name(alias_target)
       return
    end if
 
    if (pe_rank .eq. 0) then
       write(error_unit, *) "Current registry contents:"
 
       do i = 1, this%n_entries()
          write(error_unit, *) "- ", this%entries(i)%get_name()
       end do
    end if
    call neko_error("Vector " // name // " could not be found in the registry")
 
  end function registry_get_vector_by_name
 
  recursive function registry_get_matrix_by_name(this, name) result(f)
    class(registry_t), target, intent(inout) :: this
    character(len=*), intent(in) :: name
    character(len=:), allocatable :: alias_target
    type(matrix_t), pointer :: f
    logical :: found
    integer :: i
 
    found = .false.
 
    do i = 1, this%n_entries()
       if (this%entries(i)%get_type() .eq. 'matrix' .and. &
            this%entries(i)%get_name() .eq. trim(name)) then
          f => this%entries(i)%get_matrix()
          return
       end if
    end do
 
    call this%aliases%get(name, alias_target, found)
    if (found) then
       f => this%get_matrix_by_name(alias_target)
       return
    end if
 
    if (pe_rank .eq. 0) then
       write(error_unit, *) "Current registry contents:"
 
       do i = 1, this%n_entries()
          write(error_unit, *) "- ", this%entries(i)%get_name()
       end do
    end if
    call neko_error("Matrix " // name // " could not be found in the registry")
 
  end function registry_get_matrix_by_name
 
  ! ========================================================================== !
  ! Methods for checking existence of objects in the registry
 
  function registry_entry_exists(this, name) result(found)
    class(registry_t), target, intent(inout) :: this
    character(len=*), intent(in) :: name
    logical :: found
    integer :: i
 
    found = .false.
    do i = 1, this%n_entries()
       if (trim(this%entries(i)%get_name()) .eq. trim(name)) then
          found = .true.
          return
       end if
    end do
 
    found = this%aliases%valid_path(name)
  end function registry_entry_exists
 
  function registry_field_exists(this, name) result(found)
    class(registry_t), target, intent(inout) :: this
    character(len=*), intent(in) :: name
    logical :: found
    integer :: i
 
    found = .false.
    do i = 1, this%n_entries()
       if (this%entries(i)%get_type() .eq. 'field' .and. &
            this%entries(i)%get_name() .eq. trim(name)) then
          found = .true.
          return
       end if
    end do
 
    found = this%aliases%valid_path(name)
  end function registry_field_exists
 
  function registry_vector_exists(this, name) result(found)
    class(registry_t), target, intent(inout) :: this
    character(len=*), intent(in) :: name
    logical :: found
    integer :: i
 
    found = .false.
    do i = 1, this%n_entries()
       if (this%entries(i)%get_type() .eq. 'vector' .and. &
            this%entries(i)%get_name() .eq. trim(name)) then
          found = .true.
          return
       end if
    end do
 
    found = this%aliases%valid_path(name)
  end function registry_vector_exists
 
  function registry_matrix_exists(this, name) result(found)
    class(registry_t), target, intent(inout) :: this
    character(len=*), intent(in) :: name
    logical :: found
    integer :: i
 
    found = .false.
    do i = 1, this%n_entries()
       if (this%entries(i)%get_type() .eq. 'matrix' .and. &
            this%entries(i)%get_name() .eq. trim(name)) then
          found = .true.
          return
       end if
    end do
 
    found = this%aliases%valid_path(name)
  end function registry_matrix_exists
 
  ! ========================================================================== !
  ! Generic component accessor methods
 
  pure function registry_n_entries(this) result(n)
    class(registry_t), intent(in) :: this
    integer :: n
 
    n = this%n_entries_
  end function registry_n_entries
 
  pure function registry_n_fields(this) result(n)
    class(registry_t), intent(in) :: this
    integer :: n, i
 
    n = 0
    do i = 1, this%n_entries()
       if (this%entries(i)%get_type() .eq. 'field') then
          n = n + 1
       end if
    end do
  end function registry_n_fields
 
  pure function registry_n_vectors(this) result(n)
    class(registry_t), intent(in) :: this
    integer :: n, i
 
    n = 0
    do i = 1, this%n_entries()
       if (this%entries(i)%get_type() .eq. 'vector') then
          n = n + 1
       end if
    end do
  end function registry_n_vectors
 
  pure function registry_n_matrices(this) result(n)
    class(registry_t), intent(in) :: this
    integer :: n, i
 
    n = 0
    do i = 1, this%n_entries()
       if (this%entries(i)%get_type() .eq. 'matrix') then
          n = n + 1
       end if
    end do
  end function registry_n_matrices
 
  pure function registry_n_aliases(this) result(n)
    class(registry_t), intent(in) :: this
    integer :: n
 
    n = this%n_aliases_
  end function registry_n_aliases
 
  pure function registry_get_size(this) result(n)
    class(registry_t), intent(in) :: this
    integer :: n
 
    if (allocated(this%entries)) then
       n = size(this%entries)
    else
       n = 0
    end if
  end function registry_get_size
 
  pure function registry_get_expansion_size(this) result(n)
    class(registry_t), intent(in) :: this
    integer :: n
 
    n = this%expansion_size_
  end function registry_get_expansion_size
 
  subroutine registry_print(this)
    class(registry_t), intent(in) :: this
    character(len=LOG_SIZE), allocatable :: buffer
    integer :: i
 
    call neko_log%section("Field Registry Contents")
    do i = 1, this%n_entries()
       write(buffer, '(A,I4,A,A)') "- [", i, "] ", &
            this%entries(i)%get_type(), ": ", this%entries(i)%get_name()
       call neko_log%message(trim(buffer))
    end do
 
    call neko_log%end_section()
  end subroutine registry_print
 
end module registry