uset.f90

Go to the documentation of this file.

! Copyright (c) 2019-2023, 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 uset
  use utils, only : neko_error
  use num_types, only : i8, dp
  use htable, only : htable_i4_t, htable_iter_i4_t, &
                     htable_i8_t, htable_iter_i8_t, &
                     htable_r8_t, htable_iter_r8_t
  implicit none
  private
 
  type, private, abstract :: uset_t
   contains
     procedure(uset_init), pass(this), deferred :: init
     procedure(uset_free), pass(this), deferred :: free
     procedure(uset_size), pass(this), deferred :: size
     procedure(uset_clear), pass(this), deferred :: clear
     procedure(uset_element), pass(this), deferred :: element
     procedure(uset_add), pass(this), deferred :: add
     procedure(uset_remove), pass(this), deferred :: remove
  end type uset_t
 
  type, extends(uset_t), public :: uset_i4_t
     type(htable_i4_t) :: t
     type(htable_iter_i4_t) :: it
   contains
     procedure, pass(this) :: init => uset_i4_init
     procedure, pass(this) :: free => uset_i4_free
     procedure, pass(this) :: size => uset_i4_size
     procedure, pass(this) :: clear => uset_i4_clear
     procedure, pass(this) :: element => uset_i4_element
     procedure, pass(this) :: add => uset_i4_add
     procedure, pass(this) :: remove => uset_i4_remove
     procedure, pass(this) :: iter_init => uset_i4_iter_init
     procedure, pass(this) :: iter_next => uset_i4_iter_next
     procedure, pass(this) :: iter_value => uset_i4_iter_value
  end type uset_i4_t
 
  type, extends(uset_t), public :: uset_i8_t
     type(htable_i8_t) :: t
     type(htable_iter_i8_t) :: it
   contains
     procedure, pass(this) :: init => uset_i8_init
     procedure, pass(this) :: free => uset_i8_free
     procedure, pass(this) :: size => uset_i8_size
     procedure, pass(this) :: clear => uset_i8_clear
     procedure, pass(this) :: element => uset_i8_element
     procedure, pass(this) :: add => uset_i8_add
     procedure, pass(this) :: remove => uset_i8_remove
     procedure, pass(this) :: iter_init => uset_i8_iter_init
     procedure, pass(this) :: iter_next => uset_i8_iter_next
     procedure, pass(this) :: iter_value => uset_i8_iter_value
  end type uset_i8_t
 
  type, extends(uset_t), public :: uset_r8_t
     type(htable_r8_t) :: t
     type(htable_iter_r8_t) :: it
   contains
     procedure, pass(this) :: init => uset_r8_init
     procedure, pass(this) :: free => uset_r8_free
     procedure, pass(this) :: size => uset_r8_size
     procedure, pass(this) :: clear => uset_r8_clear
     procedure, pass(this) :: element => uset_r8_element
     procedure, pass(this) :: add => uset_r8_add
     procedure, pass(this) :: remove => uset_r8_remove
     procedure, pass(this) :: iter_init => uset_r8_iter_init
     procedure, pass(this) :: iter_next => uset_r8_iter_next
     procedure, pass(this) :: iter_value => uset_r8_iter_value
  end type uset_r8_t
 
  abstract interface
     subroutine uset_init(this, n)
       import uset_t
       class(uset_t), intent(inout) :: this
       integer, optional :: n
     end subroutine uset_init
  end interface
 
  abstract interface
     subroutine uset_free(this)
       import uset_t
       class(uset_t), intent(inout) :: this
     end subroutine uset_free
  end interface
 
  abstract interface
     pure function uset_size(this) result(entries)
       import uset_t
       class(uset_t), intent(in) :: this
       integer :: entries
     end function uset_size
  end interface
 
  abstract interface
     subroutine uset_clear(this)
       import uset_t
       class(uset_t), intent(inout) :: this
     end subroutine uset_clear
  end interface
 
  abstract interface
     function uset_element(this, key) result(res)
       import uset_t
       class(uset_t), intent(inout) :: this
       class(*), intent(inout) :: key
       logical :: res
     end function uset_element
  end interface
 
  abstract interface
     subroutine uset_add(this, key)
       import uset_t
       class(uset_t), intent(inout) :: this
       class(*), intent(inout) :: key
     end subroutine uset_add
  end interface
 
  abstract interface
     subroutine uset_remove(this, key)
       import uset_t
       class(uset_t), intent(inout) :: this
       class(*), intent(inout) :: key
     end subroutine uset_remove
  end interface
 
contains
 
  subroutine uset_i4_init(this, n)
    class(uset_i4_t), intent(inout) :: this
    integer, optional :: n
 
    if (present(n)) then
       call this%t%init(n)
    else
       call this%t%init(64)
    end if
  end subroutine uset_i4_init
 
  subroutine uset_i4_free(this)
    class(uset_i4_t), intent(inout) :: this
 
    nullify(this%it%t)
    call this%t%free()
 
  end subroutine uset_i4_free
 
  pure function uset_i4_size(this) result(entries)
    class(uset_i4_t), intent(in) :: this
    integer :: entries
 
    entries = this%t%num_entries()
 
  end function uset_i4_size
 
  subroutine uset_i4_clear(this)
    class(uset_i4_t), intent(inout) :: this
 
    call this%t%clear()
  end subroutine uset_i4_clear
 
  function uset_i4_element(this, key) result(res)
    class(uset_i4_t), intent(inout) :: this
    class(*), intent(inout) :: key
    integer :: data
    logical :: res
 
    select type(key)
    type is (integer)
       res = (this%t%get(key, data) .eq. 0)
    class default
       res = .false.
    end select
  end function uset_i4_element
 
  subroutine uset_i4_add(this, key)
    class(uset_i4_t), intent(inout) :: this
    class(*), intent(inout) :: key
    integer :: data
 
    select type(key)
    type is (integer)
       data = key
       call this%t%set(key, data)
    class default
       call neko_error("Invalid key")
    end select
  end subroutine uset_i4_add
 
  subroutine uset_i4_remove(this, key)
    class(uset_i4_t), intent(inout) :: this
    class(*), intent(inout) :: key
 
    select type(key)
    type is (integer)
       call this%t%remove(key)
    class default
       call neko_error("Invalid key")
    end select
  end subroutine uset_i4_remove
 
  subroutine uset_i4_iter_init(this)
    class(uset_i4_t), target, intent(inout) :: this
    call this%it%init(this%t)
  end subroutine uset_i4_iter_init
 
  function uset_i4_iter_next(this) result(valid)
    class(uset_i4_t), intent(inout) :: this
    logical :: valid
    valid = this%it%next()
  end function uset_i4_iter_next
 
  function uset_i4_iter_value(this) result(value)
    class(uset_i4_t), target, intent(inout) :: this
    integer, pointer :: value
    value => this%it%value()
  end function uset_i4_iter_value
 
  subroutine uset_i8_init(this, n)
    class(uset_i8_t), intent(inout) :: this
    integer, optional :: n
 
    if (present(n)) then
       call this%t%init(n)
    else
       call this%t%init(64)
    end if
  end subroutine uset_i8_init
 
  subroutine uset_i8_free(this)
    class(uset_i8_t), intent(inout) :: this
 
    nullify(this%it%t)
    call this%t%free()
 
  end subroutine uset_i8_free
 
  pure function uset_i8_size(this) result(entries)
    class(uset_i8_t), intent(in) :: this
    integer :: entries
 
    entries = this%t%num_entries()
 
  end function uset_i8_size
 
  subroutine uset_i8_clear(this)
    class(uset_i8_t), intent(inout) :: this
 
    call this%t%clear()
  end subroutine uset_i8_clear
 
  function uset_i8_element(this, key) result(res)
    class(uset_i8_t), intent(inout) :: this
    class(*), intent(inout) :: key
    integer(kind=i8) :: data
    logical :: res
 
    select type(key)
    type is (integer(i8))
       res = (this%t%get(key, data) .eq. 0)
    class default
       res = .false.
    end select
  end function uset_i8_element
 
  subroutine uset_i8_add(this, key)
    class(uset_i8_t), intent(inout) :: this
    class(*), intent(inout) :: key
    integer(kind=i8) :: data
 
    select type(key)
    type is (integer(i8))
       data = key
       call this%t%set(key, data)
    class default
       call neko_error("Invalid key")
    end select
  end subroutine uset_i8_add
 
  subroutine uset_i8_remove(this, key)
    class(uset_i8_t), intent(inout) :: this
    class(*), intent(inout) :: key
 
    select type(key)
    type is (integer(i8))
       call this%t%remove(key)
    class default
       call neko_error("Invalid key")
    end select
  end subroutine uset_i8_remove
 
  subroutine uset_i8_iter_init(this)
    class(uset_i8_t), target, intent(inout) :: this
    call this%it%init(this%t)
  end subroutine uset_i8_iter_init
 
  function uset_i8_iter_next(this) result(valid)
    class(uset_i8_t), intent(inout) :: this
    logical :: valid
    valid = this%it%next()
  end function uset_i8_iter_next
 
  function uset_i8_iter_value(this) result(value)
    class(uset_i8_t), target, intent(inout) :: this
    integer(kind=i8), pointer :: value
 
    ! We should not need this extra select block, and it works great
    ! without it for GNU, Intel and NEC, but breaks horribly on Cray
    ! (>11.0.x) when using high opt. levels.
    select type(hp => this)
    type is (uset_i8_t)
       value => hp%it%value()
    class default
       call neko_error('Invalid uset htable iter (i8)')
    end select
  end function uset_i8_iter_value
 
  subroutine uset_r8_init(this, n)
    class(uset_r8_t), intent(inout) :: this
    integer, optional :: n
 
    if (present(n)) then
       call this%t%init(n)
    else
       call this%t%init(64)
    end if
  end subroutine uset_r8_init
 
  subroutine uset_r8_free(this)
    class(uset_r8_t), intent(inout) :: this
 
    call this%t%free()
 
  end subroutine uset_r8_free
 
  pure function uset_r8_size(this)  result(entries)
    class(uset_r8_t), intent(in) :: this
    integer :: entries
 
    entries = this%t%num_entries()
 
  end function uset_r8_size
 
  subroutine uset_r8_clear(this)
    class(uset_r8_t), intent(inout) :: this
 
    call this%t%clear()
  end subroutine uset_r8_clear
 
  function uset_r8_element(this, key) result(res)
    class(uset_r8_t), intent(inout) :: this
    class(*), intent(inout) :: key
    logical :: res
    real(kind=dp) :: data
 
    select type(key)
    type is (double precision)
       res = (this%t%get(key, data) .eq. 0)
    class default
       res = .false.
    end select
 
  end function uset_r8_element
 
  subroutine uset_r8_add(this, key)
    class(uset_r8_t), intent(inout) :: this
    class(*), intent(inout) :: key
    real(kind=dp) :: data
 
    select type(key)
    type is (double precision)
       data = key
       call this%t%set(key, data)
    class default
       call neko_error("Invalid key")
    end select
  end subroutine uset_r8_add
 
  subroutine uset_r8_remove(this, key)
    class(uset_r8_t), intent(inout) :: this
    class(*), intent(inout) :: key
 
    select type(key)
    type is (double precision)
       call this%t%remove(key)
    class default
       call neko_error("Invalid key")
    end select
  end subroutine uset_r8_remove
 
  subroutine uset_r8_iter_init(this)
    class(uset_r8_t), target, intent(inout) :: this
    call this%it%init(this%t)
  end subroutine uset_r8_iter_init
 
  function uset_r8_iter_next(this) result(valid)
    class(uset_r8_t), intent(inout) :: this
    logical :: valid
    valid = this%it%next()
  end function uset_r8_iter_next
 
  function uset_r8_iter_value(this) result(value)
    class(uset_r8_t), target, intent(inout) :: this
    real(kind=dp), pointer :: value
    value => this%it%value()
  end function uset_r8_iter_value
 
 
end module uset