hydro/MPP/hashtable.F

   1 module hashtable
   2     use iso_fortran_env, only: int64
   3   implicit none
   4
   5   type kv_type
   6      integer(kind=int64) :: key
   7      integer(kind=int64) :: value
   8   end type kv_type
   9
  10   type node_type
  11      type(kv_type), allocatable :: kv
  12      type(node_type), pointer :: next => null()
  13
  14    contains
  15      ! If kv is not allocated, allocate and set to the key, value passed in.
  16      ! If key is present and the same as the key passed in, overwrite the value.
  17      ! Otherwise, defer to the next node (allocate if not allocated)
  18      procedure :: node_set
  19
  20      ! If kv is not allocated, fail and return 0.
  21      ! If key is present and the same as the key passed in, return the value in kv.
  22      ! If next pointer is associated, delegate to it.
  23      ! Otherwise, fail and return 0.
  24      procedure :: node_get
  25
  26      ! If kv is not allocated, fail and return
  27      ! If key is present and node is first in bucket, set first node in bucket to
  28      !   the next node of first. Return success
  29      ! If key is present and the node is another member of the linked list, link the
  30      !   previous node's next node to this node's next node, deallocate this node,
  31      !   return success
  32
  33      ! Deallocate kv is allocated.
  34      ! Call the clear method of the next node if the next pointer associated.
  35      ! Deallocate and nullify the next pointer.
  36      procedure :: node_clear
  37
  38      ! Return the length of the linked list start from the current node.
  39      procedure :: node_depth
  40   end type node_type
  41
  42   public
  43   type hash_t
  44      integer(kind=int64) :: n_buckets = 0
  45      integer(kind=int64) :: n_keys = 0
  46      type(node_type), allocatable :: buckets(:)
  47    contains
  48      procedure, public :: bucket_count
  49      procedure, public :: n_collisions
  50      ! Returns number of keys.
  51      procedure, public :: key_count
  52      ! Set the value at a given a key.
  53      procedure, public :: set
  54      procedure, public :: set_all
  55      procedure, public :: set_all_idx
  56      ! Get the value at the given key.
  57      procedure, public :: get
  58      ! Clear all the allocated memory (must be called to prevent memory leak).
  59      procedure, public :: clear
  60      ! Private hashing function
  61      procedure, private :: hash
  62   end type hash_t
  63
  64 contains
  65
  66   function hash(this,key_value) result(bucket)
  67
  68     class(hash_t), intent(inout) :: this
  69     integer(kind=int64), intent(in) :: key_value
  70     integer(kind=int64) bucket
  71
  72     bucket = key_value
  73
  74   end function hash
  75
  76   function bucket_count(this)
  77     class(hash_t), intent(inout) :: this
  78     integer(kind=int64) bucket_count
  79
  80     bucket_count = this%n_buckets
  81   end function bucket_count
  82
  83   function n_collisions(this)
  84     class(hash_t), intent(inout) :: this
  85     integer(kind=int64) n_collisions
  86     integer(kind=int64) i
  87
  88     n_collisions = 0
  89     do i = 1, this%n_buckets
  90        n_collisions = n_collisions + node_depth(this%buckets(i)) - 1
  91     enddo
  92   end function n_collisions
  93
  94   recursive function node_depth(this) result(depth)
  95     class(node_type), intent(inout) :: this
  96     integer(kind=int64) depth
  97
  98     if (.not. associated(this%next)) then
  99        depth = 1
 100     else
 101        depth = 1 + node_depth(this%next)
 102     endif
 103   end function node_depth
 104
 105   pure function key_count(this)
 106     class(hash_t), intent(in) :: this
 107     integer(kind=int64) key_count
 108
 109     key_count = this%n_keys
 110   end function key_count
 111
 112   subroutine set(this, key, value)
 113     class(hash_t), intent(inout) :: this
 114     integer(kind=int64), intent(in) :: key
 115     integer(kind=int64), intent(in) :: value
 116     integer(kind=int64) bucket_id
 117     logical :: is_new
 118
 119     bucket_id = modulo(this%hash(key), this%n_buckets) + 1
 120
 121     call this%buckets(bucket_id)%node_set(key, value)
 122
 123     if (is_new) this%n_keys = this%n_keys + 1
 124   end subroutine set
 125
 126   subroutine set_all_idx(this, keys, length)
 127     class(hash_t), intent(inout) :: this
 128     integer(kind=int64), intent(in) :: keys(:)
 129     integer, optional, intent(in) :: length
 130     integer(kind=int64) :: i
 131     integer(kind=int64) bucket_id, n
 132
 133     if(present(length)) then
 134        n = length
 135     else
 136        n = size(keys)
 137     end if
 138
 139     this%n_buckets = n
 140     allocate(this%buckets(n))
 141
 142     do i = 1, n
 143        bucket_id = modulo(this%hash(keys(i)),this%n_buckets) + 1
 144        call this%buckets(bucket_id)%node_set(keys(i), i)
 145        this%n_keys = this%n_keys + 1
 146     end do
 147   end subroutine set_all_idx
 148
 149   subroutine set_all(this, keys, values)
 150     class(hash_t), intent(inout) :: this
 151     integer(kind=int64), intent(in) :: keys(:)
 152     integer(kind=int64), intent(in) :: values(:)
 153     integer(kind=int64) bucket_id, i, n
 154
 155     n = size(keys)
 156
 157     this%n_buckets = n
 158     allocate(this%buckets(n))
 159
 160     do i = 1, n
 161        bucket_id = modulo(this%hash(keys(i)), this%n_buckets) + 1
 162        call this%buckets(bucket_id)%node_set(keys(i), values(i))
 163        this%n_keys = this%n_keys + 1
 164     end do
 165   end subroutine set_all
 166
 167   recursive subroutine node_set(this, key, value)
 168     class(node_type), intent(inout) :: this
 169     integer(kind=int64), intent(in) :: key
 170     integer(kind=int64), intent(in) :: value
 171
 172     if (.not. allocated(this%kv)) then
 173        allocate(this%kv)
 174        this%kv%key = key
 175        this%kv%value = value
 176     else if (this%kv%key == key) then
 177        this%kv%value = this%kv%value
 178     else
 179        if (.not. associated(this%next)) then
 180           allocate(this%next)
 181        end if
 182        call this%next%node_set(key, value)
 183     endif
 184   end subroutine node_set
 185
 186   subroutine get(this, key, value, success)
 187     class(hash_t), intent(inout) :: this
 188     integer(kind=int64), intent(in) :: key
 189     integer(kind=int64), intent(out) :: value
 190     logical, intent(out) :: success
 191     integer(kind=int64) bucket_id
 192
 193     success = .false.
 194     if(this%n_buckets == 0) return
 195     bucket_id = modulo(key,this%n_buckets) + 1
 196     call this%buckets(bucket_id)%node_get(key, value, success)
 197   end subroutine get
 198
 199   recursive subroutine node_get(this, key, value, success)
 200     class(node_type), intent(inout) :: this
 201     integer(kind=int64), intent(in) :: key
 202     integer(kind=int64), intent(out) :: value
 203     logical, intent(out) :: success
 204
 205     success = .false.
 206
 207     if (.not. allocated(this%kv)) then
 208        ! Not found. (Initial node in the bucket not set)
 209        success = .false.
 210     else if (this%kv%key == key) then
 211        value = this%kv%value
 212        success = .true.
 213     else if (associated(this%next)) then
 214        call this%next%node_get(key, value, success)
 215     else
 216        success = .false.
 217     endif
 218   end subroutine node_get
 219
 220   subroutine clear(this)
 221     class(hash_t), intent(inout) :: this
 222     integer(kind=int64) i
 223
 224     if (.not. allocated(this%buckets)) return
 225
 226     do i = 1, size(this%buckets)
 227        if (associated(this%buckets(i)%next)) then
 228           call this%buckets(i)%next%node_clear()
 229           deallocate(this%buckets(i)%next)
 230           if(allocated(this%buckets(i)%kv)) then
 231              deallocate(this%buckets(i)%kv)
 232           endif
 233        end if
 234     enddo
 235     deallocate(this%buckets)
 236     this%n_keys = 0
 237     this%n_buckets = 0
 238   end subroutine clear
 239
 240   recursive subroutine node_clear(this)
 241     class(node_type), intent(inout) :: this
 242
 243     if (associated(this%next)) then
 244        call this%next%node_clear()
 245        deallocate(this%next)
 246        deallocate(this%kv)
 247        nullify(this%next)
 248     endif
 249   end subroutine node_clear
 250
 251 end module hashtable