DISPATCH
hash_table_mod.f90
1 !===============================================================================
2 !> Hash table module for the use inside DISPATCH
3 !> - KEY: A tuple (ip,id) acts as hash key
4 !> - VALUE: pointer
5 !> - HASH FUNCTION: Simple hash function based on multiplication with constants
6 !> - COLLISIONS: A linked list is used to deal with collisions
7 !> Author: Troels Haugboelle
8 !===============================================================================
10  USE iso_c_binding, only: c_loc, c_ptr
11  USE mpi_mod
12  USE trace_mod
13  USE io_mod
14  implicit none
15  private
16  !-----------------------------------------------------------------------------
17  ! General module parameters
18  !-----------------------------------------------------------------------------
19  integer(kind=8), dimension(1:4), parameter :: constants = (/5, -1640531527, 97, 1003313/)
20  !-----------------------------------------------------------------------------
21  ! Define a bucket as a derived type (sequence statement!) for better
22  ! cache efficiency.
23  !-----------------------------------------------------------------------------
24  type, public:: bucket_t
25  integer, allocatable, dimension(:) :: key
26  integer :: next_ibucket
27  class(*), pointer :: value
28  end type
29  !-----------------------------------------------------------------------------
30  ! The actual hash table is an array of buckets
31  !-----------------------------------------------------------------------------
32  type, public:: hash_table_t
33  type(bucket_t), allocatable, dimension(:) :: data
34  integer :: ndim=2
35  integer :: key_length
36  integer :: total_size, head_free, nfree_chain, nfree
37  integer(kind=8) :: size
38  integer(kind=8) :: bitmask
39  integer, allocatable, dimension(:) :: next_free
40  contains
41  procedure:: init
42  procedure:: reset_entire_hash
43  procedure:: dealloc
44  procedure:: set
45  procedure:: get
46  procedure:: free
47  procedure:: stats
48  procedure:: same_keys
49  procedure:: reset_bucket
50  end type
51  type(hash_table_t), public:: hash_table
52 CONTAINS
53 
54 !===============================================================================
55 !> Allocate all hash table arrays and variables.
56 !> Chose size (excluding the chaining space) as the smallest
57 !> power of two >= the required_size.
58 !===============================================================================
59 SUBROUTINE init (self, req_size, ndim)
60  class(hash_table_t), intent(inout) :: self
61  integer , intent(in) :: req_size
62  integer, optional , intent(in) :: ndim
63  !-----------------------------------------------------------------------------
64  self%size = 2
65  if (present(ndim)) then
66  self%ndim = ndim
67  else
68  self%ndim = 2
69  end if
70  self%key_length = self%ndim*8
71  do while (self%size < req_size*2)
72  self%size = self%size * 2
73  end do
74  call reset_entire_hash (self, .false.)
75 END SUBROUTINE init
76 
77 !===============================================================================
78 !> Hash function
79 !===============================================================================
80 PURE FUNCTION hash_func(key)
81  integer, dimension(:), intent(in) :: key
82  integer(kind=8) :: hash_func
83  hash_func = dot_product(key(:), constants(1:size(key)))
84 END FUNCTION hash_func
85 
86 !===============================================================================
87 !> Subroutine to reset the entire hash table
88 !> IMPORTANT: The new size of the hash table is adapted based on the
89 !> load factor before resetting the hash table.
90 !===============================================================================
91 SUBROUTINE reset_entire_hash (htable, resize)
92  class(hash_table_t), intent(inout) :: htable
93  logical, intent(in) :: resize
94  integer :: i
95  real :: load_factor
96  !-----------------------------------------------------------------------------
97  if (resize) then
98  load_factor = real(htable%size - htable%nfree,kind=4) / real(htable%size,kind=4)
99  if (load_factor > 0.6) then
100  htable%size = htable%size * 2
101  call io%bits_mem (-storage_size(htable%data), product(shape(htable%data)))
102  call io%bits_mem (-storage_size(htable%next_free), &
103  product(shape(htable%next_free)), 'hash')
104  deallocate(htable%data, htable%next_free)
105  else if (load_factor < 0.2 .and. htable%size > 2)then
106  htable%size = htable%size / 2
107  call io%bits_mem (-storage_size(htable%next_free), &
108  product(shape(htable%next_free)), 'hash')
109  deallocate(htable%data, htable%next_free)
110  end if
111  end if
112  !-----------------------------------------------------------------------------
113  ! Compute sizes and allocate arrays
114  !-----------------------------------------------------------------------------
115  htable%total_size = int(htable%size/4,kind=4) + int(htable%size,kind=4)
116  htable%nfree = int(htable%size,kind=4)
117  htable%nfree_chain = htable%total_size - int(htable%size,kind=4)
118  htable%head_free = int(htable%size,kind=4) + 1
119  htable%bitmask = htable%size - 1
120  if (.not. allocated(htable%data))then
121  allocate(htable%data(1: htable%total_size))
122  allocate(htable%next_free (htable%size + 1: htable%total_size))
123  call io%bits_mem (storage_size(htable%data), &
124  product(shape(htable%data)), 'hash')
125  call io%bits_mem (storage_size(htable%next_free), &
126  product(shape(htable%next_free)), 'hash')
127  end if
128  !-----------------------------------------------------------------------------
129  ! Initialize data
130  !-----------------------------------------------------------------------------
131  do i = 1, int(htable%total_size,kind=4)
132  call htable%reset_bucket (htable%data(i))
133  end do
134  do i = int(htable%size,kind=4) + 1, htable%total_size - 1
135  htable%next_free(i) = i + 1
136  end do
137  htable%next_free(htable%total_size) = 0
138 END SUBROUTINE reset_entire_hash
139 
140 !===============================================================================
141 !> Subroutine to reset the entire hash table
142 !> IMPORTANT: The new size of the hash table is adapted based on the
143 !> load factor before resetting the hash table.
144 !===============================================================================
145 SUBROUTINE dealloc (htable, resize)
146  class(hash_table_t), intent(inout) :: htable
147  logical, intent(in) :: resize
148  integer :: i
149  real :: load_factor
150  !-----------------------------------------------------------------------------
151  call io%bits_mem (-storage_size(htable%data), product(shape(htable%data)))
152  call io%bits_mem (-storage_size(htable%next_free), &
153  product(shape(htable%next_free)), 'hash')
154  deallocate (htable%data, htable%next_free)
155 END SUBROUTINE dealloc
156 
157 !===============================================================================
158 !> Reset the content of a bucket
159 !===============================================================================
160 SUBROUTINE reset_bucket (self, buck)
161  class(hash_table_t):: self
162  type(bucket_t), intent(inout) :: buck
163  !-----------------------------------------------------------------------------
164  if (allocated(buck%key)) then
165  deallocate(buck%key)
166  end if
167  allocate (buck%key(self%ndim))
168  buck%next_ibucket = -1
169  buck%key = 0
170 END SUBROUTINE reset_bucket
171 
172 !===============================================================================
173 !> Add a key/value pair to the hash table. If there is already a key/value
174 !> pair stored for this key, return an error message.
175 !===============================================================================
176 SUBROUTINE set (htable, key, val)
177  class(hash_table_t), intent(inout) :: htable
178  integer, dimension(:) , intent(in) :: key
179  class(*), pointer, intent(in) :: val
180  integer(kind=8) :: full_hash
181  integer(kind=8) :: ibucket
182  integer, save:: itimer=0
183  !-----------------------------------------------------------------------------
184  ! Compute ibucket
185  !-----------------------------------------------------------------------------
186  !call trace%begin ('hash_table_t%set', itimer=itimer)
187  full_hash = hash_func(key)
188  ibucket = iand(full_hash, htable%bitmask) + 1
189  if (htable%data(ibucket)%next_ibucket < 0) then
190  ! Bucket is empty, simply insert value
191  htable%data(ibucket)%next_ibucket = 0
192  htable%data(ibucket)%value => val
193  htable%data(ibucket)%key = key
194  htable%nfree = htable%nfree - 1
195  !-----------------------------------------------------------------------------
196  ! Bucket is not empty, walk through linked list
197  !-----------------------------------------------------------------------------
198  else if (htable%nfree_chain>0)then
199  do while (htable%data(ibucket)%next_ibucket .ne. 0)
200  ! Check if key already exists - abort if so
201  if (htable%same_keys(htable%data(ibucket)%key,key)) then
202  write(*,*) "hash_taable: trying to insert already existing key: ", key
203  call mpi%abort ('hash_table: double insert')
204  end if
205  ibucket = htable%data(ibucket)%next_ibucket
206  end do
207  !--------------------------------------------------------------------------
208  ! Check again (at the end of linked list)
209  !--------------------------------------------------------------------------
210  if (htable%same_keys(htable%data(ibucket)%key,key))then
211  write(*,*) "trying to insert already existing key: ",key
212  stop
213  end if
214  !--------------------------------------------------------------------------
215  ! Have reached end of chain, val not present yet -> add
216  !--------------------------------------------------------------------------
217  htable%data(ibucket)%next_ibucket = htable%head_free
218  ibucket = htable%head_free
219  htable%data(ibucket)%next_ibucket = 0
220  htable%data(ibucket)%value => val
221  htable%data(ibucket)%key = key
222  !--------------------------------------------------------------------------
223  ! remove bucket from head of free linked list
224  !--------------------------------------------------------------------------
225  htable%head_free = htable%next_free(htable%head_free)
226  htable%nfree_chain = htable%nfree_chain - 1
227  else
228  write(*,*)"hash chaining space full "
229  stop
230  end if
231  !call trace%end (itimer)
232 END SUBROUTINE set
233 
234 !===============================================================================
235 !> Function (not subroutine, could also be changed...? ) which retrieves the
236 !> hash table value for a given key. If no entry exists, return 0
237 !===============================================================================
238 SUBROUTINE get (htable, key, value)
239  class(hash_table_t), intent(in) :: htable
240  integer , dimension(:) , intent(in) :: key
241  class(*), pointer :: value
242  integer(kind=8) :: ibucket, full_hash
243  integer, save:: itimer=0
244  !-----------------------------------------------------------------------------
245  !call trace%begin ('hash_table_t%get', itimer=itimer)
246  full_hash = hash_func(key)
247  ibucket = iand(full_hash, htable%bitmask) + 1
248  if (htable%same_keys(htable%data(ibucket)%key, key))then
249  value => htable%data(ibucket)%value
250  !call trace%end (itimer)
251  return
252  end if
253  !-----------------------------------------------------------------------------
254  ! Walk linked list until key is found or to the end is reached
255  !-----------------------------------------------------------------------------
256  do while( htable%data(ibucket)%next_ibucket > 0)
257  ibucket = htable%data(ibucket)%next_ibucket
258  if (htable%same_keys(htable%data(ibucket)%key, key))then
259  value => htable%data(ibucket)%value
260  !call trace%end (itimer)
261  return
262  end if
263  end do
264  !-----------------------------------------------------------------------------
265  ! Nothing found...
266  !-----------------------------------------------------------------------------
267  nullify(value)
268  !call trace%end (itimer)
269 END SUBROUTINE get
270 
271 !===============================================================================
272 !> Remove the hash table entry for a given key
273 !===============================================================================
274 SUBROUTINE free (htable, key)
275  class(hash_table_t), intent(inout) :: htable
276  integer , dimension(:) , intent(in) :: key
277  integer(kind=8) :: ibucket, previous_ibucket=0, full_hash
278  full_hash = hash_func(key)
279  ibucket = iand(full_hash, htable%bitmask) + 1
280  ! No collision case
281  if (htable%data(ibucket)%next_ibucket == 0) then
282  htable%data(ibucket)%next_ibucket = -1
283  htable%data(ibucket)%key = 0
284  htable%nfree = htable%nfree + 1
285  else
286  ! Collision case
287  do while (.not. htable%same_keys(htable%data(ibucket)%key, key))
288  previous_ibucket=ibucket
289  ibucket=htable%data(ibucket)%next_ibucket
290  end do
291  if (ibucket <= htable%size) then
292  ! It's the first element we need to erase: Move first element from chaning
293  ! space into bucket and do as if the value to remove had been in the chaning space
294  htable%data(ibucket)%value => htable%data(htable%data(ibucket)%next_ibucket)%value
295  htable%data(ibucket)%key = htable%data(htable%data(ibucket)%next_ibucket)%key
296  previous_ibucket = ibucket
297  ibucket = htable%data(ibucket)%next_ibucket
298  end if
299  ! fill the hole and reconnect linked list
300  htable%data(previous_ibucket)%next_ibucket = htable%data(ibucket)%next_ibucket
301  htable%next_free(ibucket) = htable%head_free
302  htable%head_free = int(ibucket,kind=4)
303  htable%nfree_chain = htable%nfree_chain + 1
304  end if
305 END SUBROUTINE free
306 
307 !===============================================================================
308 !> Check if keys are equivalent
309 !===============================================================================
310 PURE FUNCTION same_keys(self, key1, key2)
311  class(hash_table_t) , intent(in) :: self
312  logical :: same_keys
313  integer, dimension(:) , intent(in) :: key1, key2
314  logical, dimension(1:self%ndim) :: ok
315  integer :: i
316  !-----------------------------------------------------------------------------
317  do i = 1, self%ndim
318  ok(i) = (key1(i)==key2(i))
319  end do
320  same_keys = all(ok)
321 END FUNCTION same_keys
322 
323 !===============================================================================
324 !> Statistics
325 !===============================================================================
326 SUBROUTINE stats (htable)
327  class(hash_table_t)::htable
328  !-----------------------------------------------------------------------------
329  if (mpi%master) then
330  write(*,*)"Total values stored in hash table: "&
331  ,htable%total_size - htable%nfree - htable%nfree_chain
332  write(*,*)"Size of hash table (without chaning space): "&
333  ,htable%size
334  write(*,*)"Load factor: "&
335  ,(htable%size - htable%nfree) * 1.d0 / (htable%size + tiny(0.d0))
336  write(*,*)"Total collisions in hash table: "&
337  ,htable%total_size - htable%size - htable%nfree_chain
338  write(*,*)"Collision fraction: "&
339  ,real(htable%total_size - htable%size - htable%nfree_chain,kind=4)&
340  /(htable%total_size - htable%nfree - htable%nfree_chain + tiny(0.d0))
341  write(*,*)"Perfect collision fraction (assuming perfect randomness): "&
342  ,(htable%total_size - htable%nfree - htable%nfree_chain - &
343  htable%size * (1.d0 - ((htable%size - 1.d0)/(htable%size)) &
344  **(htable%total_size - htable%nfree - htable%nfree_chain))) &
345  *1./(htable%total_size - htable%nfree - htable%nfree_chain + tiny(0.d0))
346  write(*,*)"Fraction of collision space used: "&
347  ,(htable%total_size - htable%size - htable%nfree_chain)&
348  * 1.d0 / (htable%total_size - htable%size + tiny(0.d0))
349  endif
350 END SUBROUTINE stats
351 
352 END MODULE hash_table_mod
Hash table module for the use inside DISPATCH.
Definition: io_mod.f90:4