10 USE iso_c_binding
, only: c_loc, c_ptr
19 integer(kind=8),
dimension(1:4),
parameter ::
constants = (/5, -1640531527, 97, 1003313/)
25 integer,
allocatable,
dimension(:) :: key
26 integer :: next_ibucket
27 class(*),
pointer :: value
33 type(
bucket_t),
allocatable,
dimension(:) :: data
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
42 procedure:: reset_entire_hash
49 procedure:: reset_bucket
59 SUBROUTINE init (self, req_size, ndim)
61 integer ,
intent(in) :: req_size
62 integer,
optional ,
intent(in) :: ndim
65 if (
present(ndim))
then 70 self%key_length = self%ndim*8
71 do while (self%size < req_size*2)
72 self%size = self%size * 2
74 call reset_entire_hash (self, .false.)
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
91 SUBROUTINE reset_entire_hash (htable, resize)
93 logical,
intent(in) :: resize
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)
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')
131 do i = 1, int(htable%total_size,kind=4)
132 call htable%reset_bucket (htable%data(i))
134 do i = int(htable%size,kind=4) + 1, htable%total_size - 1
135 htable%next_free(i) = i + 1
137 htable%next_free(htable%total_size) = 0
138 END SUBROUTINE reset_entire_hash
145 SUBROUTINE dealloc (htable, resize)
147 logical,
intent(in) :: resize
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
160 SUBROUTINE reset_bucket (self, buck)
162 type(
bucket_t),
intent(inout) :: buck
164 if (
allocated(buck%key))
then 167 allocate (buck%key(self%ndim))
168 buck%next_ibucket = -1
170 END SUBROUTINE reset_bucket
176 SUBROUTINE set (htable, key, val)
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
187 full_hash = hash_func(key)
188 ibucket = iand(full_hash, htable%bitmask) + 1
189 if (htable%data(ibucket)%next_ibucket < 0)
then 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
198 else if (htable%nfree_chain>0)
then 199 do while (htable%data(ibucket)%next_ibucket .ne. 0)
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')
205 ibucket = htable%data(ibucket)%next_ibucket
210 if (htable%same_keys(htable%data(ibucket)%key,key))
then 211 write(*,*)
"trying to insert already existing key: ",key
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
225 htable%head_free = htable%next_free(htable%head_free)
226 htable%nfree_chain = htable%nfree_chain - 1
228 write(*,*)
"hash chaining space full " 238 SUBROUTINE get (htable, key, value)
240 integer ,
dimension(:) ,
intent(in) :: key
241 class(*),
pointer :: value
242 integer(kind=8) :: ibucket, full_hash
243 integer,
save:: itimer=0
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
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
274 SUBROUTINE free (htable, key)
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
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
287 do while (.not. htable%same_keys(htable%data(ibucket)%key, key))
288 previous_ibucket=ibucket
289 ibucket=htable%data(ibucket)%next_ibucket
291 if (ibucket <= htable%size)
then 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
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
310 PURE FUNCTION same_keys(self, key1, key2)
313 integer,
dimension(:) ,
intent(in) :: key1, key2
314 logical,
dimension(1:self%ndim) :: ok
318 ok(i) = (key1(i)==key2(i))
321 END FUNCTION same_keys
326 SUBROUTINE stats (htable)
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): "&
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))
Hash table module for the use inside DISPATCH.