Line data Source code
1 : ! ***********************************************************************
2 : !
3 : ! Copyright (C) 2010 The MESA Team
4 : !
5 : ! This program is free software: you can redistribute it and/or modify
6 : ! it under the terms of the GNU Lesser General Public License
7 : ! as published by the Free Software Foundation,
8 : ! either version 3 of the License, or (at your option) any later version.
9 : !
10 : ! This program is distributed in the hope that it will be useful,
11 : ! but WITHOUT ANY WARRANTY; without even the implied warranty of
12 : ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13 : ! See the GNU Lesser General Public License for more details.
14 : !
15 : ! You should have received a copy of the GNU Lesser General Public License
16 : ! along with this program. If not, see <https://www.gnu.org/licenses/>.
17 : !
18 : ! ***********************************************************************
19 :
20 : module utils_dict
21 :
22 : use utils_def, only: maxlen_key_string, integer_dict, hash_entry
23 :
24 : implicit none
25 :
26 : contains
27 :
28 0 : recursive subroutine do_integer_dict_map(dict, fcn, ierr)
29 : type (integer_dict), pointer :: dict
30 : interface
31 : subroutine fcn(key, value, ierr)
32 : implicit none
33 : character (len=*), intent(in) :: key
34 : integer, intent(in) :: value
35 : integer, intent(out) :: ierr ! /= 0 means terminate map calls
36 : end subroutine fcn
37 : end interface
38 : type (integer_dict), pointer :: node
39 : integer :: ierr
40 0 : ierr = 0
41 0 : if (.not. associated(dict)) return
42 : node => dict
43 0 : do
44 0 : if (associated(node% left)) then
45 0 : call do_integer_dict_map(node% left, fcn, ierr)
46 0 : if (ierr /= 0) return
47 : end if
48 0 : call fcn(node% key, node% value, ierr)
49 0 : if (ierr /= 0) return
50 0 : if (.not. associated(node% right)) return
51 : node => node% right
52 : end do
53 : end subroutine do_integer_dict_map
54 :
55 :
56 0 : subroutine do_get_dict_entries(dict, keys, values)
57 : type (integer_dict), pointer :: dict
58 : character (len=maxlen_key_string), pointer :: keys(:)
59 : integer, pointer :: values(:)
60 :
61 : integer :: cnt, ierr, sz
62 0 : sz = size_integer_dict(dict)
63 0 : sz = min(sz, size(keys,dim=1), size(values,dim=1))
64 0 : cnt = 0
65 0 : call do_integer_dict_map(dict, fcn, ierr)
66 :
67 : contains
68 :
69 0 : subroutine fcn(key, value, ierr)
70 : character (len=*), intent(in) :: key
71 : integer, intent(in) :: value
72 : integer, intent(out) :: ierr ! /= 0 means terminate map calls
73 0 : if (cnt >= sz) then
74 0 : ierr = -1
75 0 : return
76 : end if
77 0 : cnt = cnt+1
78 0 : keys(cnt) = key
79 0 : values(cnt) = value
80 0 : end subroutine fcn
81 :
82 : end subroutine do_get_dict_entries
83 :
84 :
85 0 : recursive subroutine show_key_entries(dict)
86 : type (integer_dict), pointer :: dict
87 : type (integer_dict), pointer :: node
88 0 : if (.not. associated(dict)) return
89 : node => dict
90 : do
91 0 : if (associated(node% left)) then
92 0 : call show_key_entries(node% left)
93 : end if
94 0 : write(*,fmt=*) trim(node% key), node% value
95 0 : if (.not. associated(node% right)) return
96 : node => node% right
97 : end do
98 : end subroutine show_key_entries
99 :
100 :
101 510150 : subroutine find_key_entry(dict, key, node)
102 : type (integer_dict), pointer :: dict
103 : character (len=*), intent(in) :: key
104 : type (integer_dict), pointer :: node ! set null if cannot find key in dict
105 510150 : type (hash_entry), pointer :: hash(:)
106 : integer :: i, hash_size, hashkey
107 510150 : if (.not. associated(dict)) then
108 0 : nullify(node); return
109 : end if
110 510150 : if (associated(dict% hash)) then
111 510150 : hash => dict% hash
112 510150 : hash_size = size(hash)
113 510150 : hashkey = dict_hashkey(key, hash_size)
114 624856 : do i=1, hash_size ! find an empty slot
115 624856 : if (.not. associated(hash(hashkey)% ptr)) exit ! failed to find key
116 401409 : if (hash(hashkey)% ptr % key == key) then
117 286703 : node => hash(hashkey)% ptr
118 286703 : return
119 : end if
120 114706 : hashkey = hashkey+1
121 338153 : if (hashkey > hash_size) hashkey = 1
122 : end do
123 223447 : nullify(node)
124 223447 : return ! failed to find key
125 : end if
126 0 : node => dict
127 : do
128 0 : if (node% key == key) return
129 0 : if (LLT(node% key,key)) then
130 0 : if (.not. associated(node% left)) then
131 0 : nullify(node); return
132 : end if
133 0 : node => node% left
134 : else
135 0 : if (.not. associated(node% right)) then
136 0 : nullify(node); return
137 : end if
138 0 : node => node% right
139 : end if
140 : end do
141 510150 : end subroutine find_key_entry
142 :
143 :
144 7638094 : recursive subroutine insert_node(node, root, duplicate)
145 : type (integer_dict), pointer :: node ! will be deallocated if a duplicate
146 : type (integer_dict), pointer :: root
147 : logical :: duplicate ! true if key was already defined
148 :
149 : integer :: height_left, height_right
150 : logical, parameter :: dbg = .false.
151 :
152 : if (dbg) write(*,*) 'insert ' // trim(node% key) // ' in ' // trim(root% key)
153 :
154 7638094 : if (node% key == root% key) then
155 6613 : root% value = node% value
156 6613 : deallocate(node)
157 : nullify(node)
158 6613 : duplicate = .true.
159 6613 : return
160 : end if
161 :
162 7631481 : if (LGT(node% key, root% key)) then ! insert on left
163 4294255 : if (.not. associated(root% left)) then
164 375678 : root% left => node
165 : else
166 3918577 : call insert_node(node, root% left, duplicate)
167 : end if
168 4294255 : height_left = root% left% height
169 4294255 : height_right = height_of_right_branch(root)
170 4294255 : if (height_left - height_right == 2) then ! rebalance
171 210221 : if (LGT(node% key, root% left% key)) then
172 187778 : call single_rotate_with_left(root)
173 : else
174 22443 : call double_rotate_with_left(root)
175 : end if
176 : end if
177 : else ! insert on right
178 3337226 : if (.not. associated(root% right)) then
179 172778 : root% right => node
180 : else
181 3164448 : call insert_node(node, root% right, duplicate)
182 : end if
183 3337226 : height_right = root% right% height
184 3337226 : height_left = height_of_left_branch(root)
185 3337226 : if (height_right - height_left == 2) then ! rebalance
186 109494 : if (LGT(root% right% key, node% key)) then
187 22875 : call single_rotate_with_right(root)
188 : else
189 86619 : call double_rotate_with_right(root)
190 : end if
191 : end if
192 : end if
193 :
194 7631481 : height_right = height_of_right_branch(root)
195 7631481 : height_left = height_of_left_branch(root)
196 7631481 : root% height = max(height_right, height_left) + 1
197 :
198 : if (dbg) write(*,*) 'new root is ' // trim(root% key)
199 :
200 :
201 : contains
202 :
203 :
204 11694324 : integer function height_of_left_branch(n)
205 : type (integer_dict), pointer :: n
206 10968707 : if (.not. associated(n% left)) then
207 : height_of_left_branch = 0
208 : else
209 11056949 : height_of_left_branch = n% left% height
210 : end if
211 : end function height_of_left_branch
212 :
213 :
214 12486450 : integer function height_of_right_branch(n)
215 : type (integer_dict), pointer :: n
216 11925736 : if (.not. associated(n% right)) then
217 : height_of_right_branch = 0
218 : else
219 11478588 : height_of_right_branch = n% right% height
220 : end if
221 : end function height_of_right_branch
222 :
223 :
224 296840 : subroutine single_rotate_with_left(k2)
225 : type (integer_dict), pointer :: k2
226 : type (integer_dict), pointer :: k1
227 296840 : k1 => k2% left
228 296840 : if (.not. associated(k1% right)) then
229 174213 : nullify(k2% left)
230 : else
231 122627 : k2% left => k1% right
232 : end if
233 296840 : k1% right => k2
234 436489 : k2% height = max(height_of_left_branch(k2), height_of_right_branch(k2)) + 1
235 296840 : k1% height = max(height_of_left_branch(k1), k2% height) + 1
236 296840 : k2 => k1
237 296840 : end subroutine single_rotate_with_left
238 :
239 :
240 131937 : subroutine single_rotate_with_right(k1)
241 : type (integer_dict), pointer :: k1
242 : type (integer_dict), pointer :: k2
243 131937 : k2 => k1% right
244 131937 : if (.not. associated(k2% left)) then
245 73814 : nullify(k1% right)
246 : else
247 58123 : k1% right => k2% left
248 : end if
249 131937 : k2% left => k1
250 195584 : k1% height = max(height_of_right_branch(k1), height_of_left_branch(k1)) + 1
251 131937 : k2% height = max(height_of_right_branch(k2), k1% height) + 1
252 131937 : k1 => k2
253 131937 : end subroutine single_rotate_with_right
254 :
255 :
256 22443 : subroutine double_rotate_with_left(k)
257 : type (integer_dict), pointer :: k
258 22443 : call single_rotate_with_right(k% left)
259 22443 : call single_rotate_with_left(k)
260 22443 : end subroutine double_rotate_with_left
261 :
262 :
263 86619 : subroutine double_rotate_with_right(k)
264 : type (integer_dict), pointer :: k
265 86619 : call single_rotate_with_left(k% right)
266 86619 : call single_rotate_with_right(k)
267 86619 : end subroutine double_rotate_with_right
268 :
269 :
270 : end subroutine insert_node
271 :
272 :
273 555198 : subroutine do_integer_dict_define(dict, key, value, duplicate, ierr)
274 : type (integer_dict), pointer :: dict ! pass null for empty dict
275 : character (len=*), intent(in) :: key
276 : integer, intent(in) :: value
277 : logical, intent(out) :: duplicate ! true if key was already defined
278 : integer, intent(out) :: ierr
279 : type (integer_dict), pointer :: node
280 : logical, parameter :: dbg = .false.
281 : ierr = 0
282 1110396 : allocate(node, stat=ierr)
283 555198 : if (ierr /= 0) return
284 555198 : !$omp critical (dict_define)
285 555198 : duplicate = .false.
286 555198 : node% key = key
287 555198 : node% value = value
288 555198 : node% height = 1
289 555198 : nullify(node% left)
290 555198 : nullify(node% right)
291 555198 : nullify(node% hash)
292 : if (dbg) write(*,*) 'insert node ' // trim(key)
293 555198 : if (.not. associated(dict)) then ! this is the 1st entry
294 129 : dict => node
295 : else
296 555069 : if (associated(dict% hash)) then
297 68 : deallocate(dict% hash)
298 68 : nullify(dict% hash)
299 : end if
300 555069 : call insert_node(node, dict, duplicate)
301 : end if
302 : !$omp end critical (dict_define)
303 : if (dbg) then ! check tree
304 : write(*,*) 'done insert node ' // trim(key) // ' new root ' // trim(dict% key)
305 : write(*,'(A)')
306 : call check_dict(dict, ierr)
307 : call show_key_entries(dict)
308 : write(*,*) 'done insert ' // trim(key)
309 : end if
310 555198 : end subroutine do_integer_dict_define
311 :
312 :
313 510475 : subroutine do_integer_dict_create_hash(dict, ierr)
314 : type (integer_dict), pointer :: dict
315 : integer, intent(out) :: ierr
316 :
317 : integer :: cnt, hash_size, i, collisions
318 510475 : type (hash_entry), pointer :: hash(:)
319 :
320 510475 : ierr = 0
321 510475 : if (.not. associated(dict)) then
322 510293 : ierr = -1; return
323 : end if
324 510280 : if (associated(dict% hash)) return
325 :
326 182 : !$omp critical (create_hash)
327 182 : if (.not. associated(dict% hash)) then
328 182 : cnt = size_integer_dict(dict) ! number of entries
329 182 : if (cnt > 0) then
330 182 : hash_size = 4*cnt
331 182 : allocate(dict% hash(hash_size), stat=ierr)
332 182 : if (ierr /= 0) then
333 0 : write(*,*) 'failed in allocate for create hash', hash_size
334 : else
335 182 : hash => dict% hash
336 2262774 : do i=1,hash_size
337 2262774 : nullify(hash(i)% ptr)
338 : end do
339 182 : collisions = 0
340 182 : call do_enter_hash(dict, hash, hash_size, collisions)
341 : end if
342 : end if
343 : end if
344 : !$omp end critical (create_hash)
345 :
346 510475 : end subroutine do_integer_dict_create_hash
347 :
348 :
349 0 : recursive subroutine check_dict(dict, ierr)
350 : type (integer_dict), pointer :: dict
351 : integer, intent(out) :: ierr
352 : integer :: height_left, height_right, height
353 0 : if (associated(dict% left)) then
354 0 : if (LGT(dict% key, dict% left% key)) then
355 : write(*,*) 'wrong order dict% key, dict% left% key ' // &
356 0 : trim(dict% key) // ' ' // trim(dict% left% key)
357 0 : ierr = -1
358 0 : return
359 : end if
360 0 : call check_dict(dict% left, ierr)
361 0 : if (ierr /= 0) return
362 0 : height_left = dict% left% height
363 : else
364 : height_left = 0
365 : end if
366 0 : if (associated(dict% right)) then
367 0 : if (LGT(dict% right% key, dict% key)) then
368 : write(*,*) 'wrong order dict% right% key, dict% key ' // &
369 0 : trim(dict% right% key) // ' ' // trim(dict% key)
370 0 : ierr = -1
371 0 : return
372 : end if
373 0 : call check_dict(dict% right, ierr)
374 0 : if (ierr /= 0) return
375 0 : height_right = dict% right% height
376 : else
377 : height_right = 0
378 : end if
379 0 : height = max(height_left, height_right) + 1
380 0 : if (dict% height /= height) then
381 0 : write(*,*) 'bad height for ' // trim(dict% key)
382 0 : ierr = -1
383 : end if
384 : end subroutine check_dict
385 :
386 :
387 510345 : subroutine do_integer_dict_lookup(dict, key, value, ierr)
388 : type (integer_dict), pointer :: dict
389 : character (len=*), intent(in) :: key
390 : integer, intent(out) :: value
391 : integer, intent(out) :: ierr ! 0 if found key in dict, -1 if didn't
392 : type (integer_dict), pointer :: node
393 : logical, parameter :: dbg = .false.
394 : if (dbg) then
395 : call show_key_entries(dict)
396 : write(*,'(A)')
397 : write(*,*) 'lookup key ' // trim(key)
398 : write(*,'(A)')
399 : end if
400 : ierr = 0
401 510345 : value = 0
402 510345 : call do_integer_dict_create_hash(dict, ierr)
403 797048 : if (ierr /= 0) return
404 510150 : call find_key_entry(dict, key, node)
405 510150 : if (associated(node)) then
406 286703 : value = node% value
407 286703 : return
408 : end if
409 223447 : ierr = -1
410 : end subroutine do_integer_dict_lookup
411 :
412 :
413 129925 : recursive subroutine do_integer_dict_free(dict)
414 : type (integer_dict), pointer :: dict
415 : type (integer_dict), pointer :: node, next
416 129925 : if (.not. associated(dict)) return
417 129925 : node => dict
418 129925 : dict => null()
419 129925 : if (associated(node% hash)) deallocate(node% hash)
420 125116 : do
421 255041 : if (associated(node% left)) call do_integer_dict_free(node% left)
422 255041 : if (.not. associated(node% right)) then
423 129925 : deallocate(node)
424 129925 : return
425 : end if
426 125116 : next => node% right
427 125116 : deallocate(node)
428 125116 : node => next
429 : end do
430 : end subroutine do_integer_dict_free
431 :
432 :
433 283986 : recursive function size_integer_dict(dict) result(cnt)
434 : type (integer_dict), pointer :: dict
435 : type (integer_dict), pointer :: node, next
436 : integer :: cnt
437 283986 : cnt = 0
438 283986 : if (.not. associated(dict)) return
439 : node => dict
440 : do
441 565648 : cnt = cnt + 1
442 565648 : if (associated(node% left)) cnt = cnt + size_integer_dict(node% left)
443 565648 : if (.not. associated(node% right)) return
444 : next => node% right
445 : node => next
446 : end do
447 : end function size_integer_dict
448 :
449 :
450 283986 : recursive subroutine do_enter_hash(dict, hash, hash_size, collisions)
451 : type (integer_dict), pointer :: dict
452 : type (hash_entry), pointer :: hash(:)
453 : integer, intent(in) :: hash_size
454 : integer, intent(inout) :: collisions
455 : type (integer_dict), pointer :: node, next
456 : integer :: hashkey, i
457 : logical :: okay
458 283986 : if (.not. associated(dict)) return
459 : node => dict
460 : do
461 : ! enter node in hash
462 565648 : hashkey = dict_hashkey(node% key, hash_size)
463 565648 : okay = .false.
464 671694 : do i=1, hash_size ! find an empty slot
465 671694 : if (.not. associated(hash(hashkey)% ptr)) then
466 565648 : hash(hashkey)% ptr => node
467 : okay = .true.
468 : exit
469 : end if
470 106046 : hashkey = hashkey+1
471 106046 : collisions = collisions+1
472 106046 : if (hashkey > hash_size) hashkey = 1
473 : end do
474 : if (.not. okay) then
475 0 : write(*,*) 'failed in do_enter_hash'
476 0 : error stop 1
477 : end if
478 565648 : if (associated(node% left)) &
479 283804 : call do_enter_hash(node% left, hash, hash_size, collisions)
480 565648 : if (.not. associated(node% right)) return
481 : next => node% right
482 : node => next
483 : end do
484 : end subroutine do_enter_hash
485 :
486 :
487 1075798 : integer function dict_hashkey(key, hash_size) ! value between 1 and hash_size
488 : character (len=*) :: key
489 : integer, intent(in) :: hash_size
490 : integer:: i, len, new, hash, c
491 1075798 : len = len_trim(key)
492 1075798 : if (len == 0) then
493 : dict_hashkey = 1
494 : return
495 : end if
496 : ! source: http://www.partow.net/programming/hashfunctions/#APHashFunction
497 : hash = -1431655766 ! Z'AAAAAAAA'
498 14751901 : do i = 1, len
499 13682360 : c = ichar(key(i:i))
500 13682360 : if (iand(c,1)==1) then
501 : !new = (hash << 7) ^ (*str) * (hash >> 3)
502 7781682 : new = ieor(ishft(hash,7), c*ishft(hash,3))
503 : else
504 : !new = ~((hash << 11) + (*str) ^ (hash >> 5))
505 5900678 : new = not(ishft(hash,11) + ieor(c,ishft(hash,-5)))
506 : end if
507 14751901 : hash = ieor(hash, new)
508 : end do
509 1069541 : dict_hashkey = hash
510 1069541 : if (dict_hashkey < 0) then
511 501733 : dict_hashkey = -dict_hashkey
512 567808 : else if (dict_hashkey == 0) then
513 0 : dict_hashkey = 1
514 : end if
515 1069541 : dict_hashkey = 1 + mod(dict_hashkey-1, hash_size)
516 1069541 : if (dict_hashkey <= 0) then
517 0 : write(*,*) 'bad dict_hashkey for ' // trim(key), dict_hashkey
518 0 : stop 'dict_hashkey'
519 : end if
520 : end function dict_hashkey
521 :
522 : end module utils_dict
|
