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 394473 : 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 394473 : type (hash_entry), pointer :: hash(:)
106 : integer :: i, hash_size, hashkey
107 394473 : if (.not. associated(dict)) then
108 0 : nullify(node); return
109 : end if
110 394473 : if (associated(dict% hash)) then
111 394473 : hash => dict% hash
112 394473 : hash_size = size(hash)
113 394473 : hashkey = dict_hashkey(key, hash_size)
114 470814 : do i=1, hash_size ! find an empty slot
115 470814 : if (.not. associated(hash(hashkey)% ptr)) exit ! failed to find key
116 336881 : if (hash(hashkey)% ptr % key == key) then
117 260540 : node => hash(hashkey)% ptr
118 260540 : return
119 : end if
120 76341 : hashkey = hashkey+1
121 210274 : if (hashkey > hash_size) hashkey = 1
122 : end do
123 133933 : nullify(node)
124 133933 : 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 394473 : end subroutine find_key_entry
142 :
143 :
144 4418546 : 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 4418546 : if (node% key == root% key) then
155 3969 : root% value = node% value
156 3969 : deallocate(node)
157 : nullify(node)
158 3969 : duplicate = .true.
159 3969 : return
160 : end if
161 :
162 4414577 : if (LGT(node% key, root% key)) then ! insert on left
163 2474366 : if (.not. associated(root% left)) then
164 214237 : root% left => node
165 : else
166 2260129 : call insert_node(node, root% left, duplicate)
167 : end if
168 2474366 : height_left = root% left% height
169 2474366 : height_right = height_of_right_branch(root)
170 2474366 : if (height_left - height_right == 2) then ! rebalance
171 117380 : if (LGT(node% key, root% left% key)) then
172 103992 : call single_rotate_with_left(root)
173 : else
174 13388 : call double_rotate_with_left(root)
175 : end if
176 : end if
177 : else ! insert on right
178 1940211 : if (.not. associated(root% right)) then
179 101690 : root% right => node
180 : else
181 1838521 : call insert_node(node, root% right, duplicate)
182 : end if
183 1940211 : height_right = root% right% height
184 1940211 : height_left = height_of_left_branch(root)
185 1940211 : if (height_right - height_left == 2) then ! rebalance
186 61616 : if (LGT(root% right% key, node% key)) then
187 13562 : call single_rotate_with_right(root)
188 : else
189 48054 : call double_rotate_with_right(root)
190 : end if
191 : end if
192 : end if
193 :
194 4414577 : height_right = height_of_right_branch(root)
195 4414577 : height_left = height_of_left_branch(root)
196 4414577 : 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 6760660 : integer function height_of_left_branch(n)
205 : type (integer_dict), pointer :: n
206 6354788 : if (.not. associated(n% left)) then
207 : height_of_left_branch = 0
208 : else
209 6394909 : height_of_left_branch = n% left% height
210 : end if
211 : end function height_of_left_branch
212 :
213 :
214 7204385 : integer function height_of_right_branch(n)
215 : type (integer_dict), pointer :: n
216 6888943 : if (.not. associated(n% right)) then
217 : height_of_right_branch = 0
218 : else
219 6634315 : height_of_right_branch = n% right% height
220 : end if
221 : end function height_of_right_branch
222 :
223 :
224 165434 : subroutine single_rotate_with_left(k2)
225 : type (integer_dict), pointer :: k2
226 : type (integer_dict), pointer :: k1
227 165434 : k1 => k2% left
228 165434 : if (.not. associated(k1% right)) then
229 97643 : nullify(k2% left)
230 : else
231 67791 : k2% left => k1% right
232 : end if
233 165434 : k1% right => k2
234 242710 : k2% height = max(height_of_left_branch(k2), height_of_right_branch(k2)) + 1
235 165434 : k1% height = max(height_of_left_branch(k1), k2% height) + 1
236 165434 : k2 => k1
237 165434 : end subroutine single_rotate_with_left
238 :
239 :
240 75004 : subroutine single_rotate_with_right(k1)
241 : type (integer_dict), pointer :: k1
242 : type (integer_dict), pointer :: k2
243 75004 : k2 => k1% right
244 75004 : if (.not. associated(k2% left)) then
245 42330 : nullify(k1% right)
246 : else
247 32674 : k1% right => k2% left
248 : end if
249 75004 : k2% left => k1
250 110953 : k1% height = max(height_of_right_branch(k1), height_of_left_branch(k1)) + 1
251 75004 : k2% height = max(height_of_right_branch(k2), k1% height) + 1
252 75004 : k1 => k2
253 75004 : end subroutine single_rotate_with_right
254 :
255 :
256 13388 : subroutine double_rotate_with_left(k)
257 : type (integer_dict), pointer :: k
258 13388 : call single_rotate_with_right(k% left)
259 13388 : call single_rotate_with_left(k)
260 13388 : end subroutine double_rotate_with_left
261 :
262 :
263 48054 : subroutine double_rotate_with_right(k)
264 : type (integer_dict), pointer :: k
265 48054 : call single_rotate_with_left(k% right)
266 48054 : call single_rotate_with_right(k)
267 48054 : end subroutine double_rotate_with_right
268 :
269 :
270 : end subroutine insert_node
271 :
272 :
273 319966 : 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 639932 : allocate(node, stat=ierr)
283 319966 : if (ierr /= 0) return
284 319966 : !$omp critical (dict_define)
285 319966 : duplicate = .false.
286 319966 : node% key = key
287 319966 : node% value = value
288 319966 : node% height = 1
289 319966 : nullify(node% left)
290 319966 : nullify(node% right)
291 319966 : nullify(node% hash)
292 : if (dbg) write(*,*) 'insert node ' // trim(key)
293 319966 : if (.not. associated(dict)) then ! this is the 1st entry
294 70 : dict => node
295 : else
296 319896 : if (associated(dict% hash)) then
297 39 : deallocate(dict% hash)
298 39 : nullify(dict% hash)
299 : end if
300 319896 : 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 319966 : end subroutine do_integer_dict_define
311 :
312 :
313 394660 : 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 394660 : type (hash_entry), pointer :: hash(:)
319 :
320 394660 : ierr = 0
321 394660 : if (.not. associated(dict)) then
322 394558 : ierr = -1; return
323 : end if
324 394543 : if (associated(dict% hash)) return
325 :
326 102 : !$omp critical (create_hash)
327 102 : if (.not. associated(dict% hash)) then
328 102 : cnt = size_integer_dict(dict) ! number of entries
329 102 : if (cnt > 0) then
330 102 : hash_size = 4*cnt
331 102 : allocate(dict% hash(hash_size), stat=ierr)
332 102 : if (ierr /= 0) then
333 0 : write(*,*) 'failed in allocate for create hash', hash_size
334 : else
335 102 : hash => dict% hash
336 1305018 : do i=1,hash_size
337 1305018 : nullify(hash(i)% ptr)
338 : end do
339 102 : collisions = 0
340 102 : 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 394660 : 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 394590 : 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 394590 : value = 0
402 394590 : call do_integer_dict_create_hash(dict, ierr)
403 655130 : if (ierr /= 0) return
404 394473 : call find_key_entry(dict, key, node)
405 394473 : if (associated(node)) then
406 260540 : value = node% value
407 260540 : return
408 : end if
409 133933 : ierr = -1
410 : end subroutine do_integer_dict_lookup
411 :
412 :
413 88175 : recursive subroutine do_integer_dict_free(dict)
414 : type (integer_dict), pointer :: dict
415 : type (integer_dict), pointer :: node, next
416 88175 : if (.not. associated(dict)) return
417 88175 : node => dict
418 88175 : dict => null()
419 88175 : if (associated(node% hash)) deallocate(node% hash)
420 85102 : do
421 173277 : if (associated(node% left)) call do_integer_dict_free(node% left)
422 173277 : if (.not. associated(node% right)) then
423 88175 : deallocate(node)
424 88175 : return
425 : end if
426 85102 : next => node% right
427 85102 : deallocate(node)
428 85102 : node => next
429 : end do
430 : end subroutine do_integer_dict_free
431 :
432 :
433 164136 : 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 164136 : cnt = 0
438 164136 : if (.not. associated(dict)) return
439 : node => dict
440 : do
441 326229 : cnt = cnt + 1
442 326229 : if (associated(node% left)) cnt = cnt + size_integer_dict(node% left)
443 326229 : 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 164136 : 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 164136 : if (.not. associated(dict)) return
459 : node => dict
460 : do
461 : ! enter node in hash
462 326229 : hashkey = dict_hashkey(node% key, hash_size)
463 326229 : okay = .false.
464 386411 : do i=1, hash_size ! find an empty slot
465 386411 : if (.not. associated(hash(hashkey)% ptr)) then
466 326229 : hash(hashkey)% ptr => node
467 : okay = .true.
468 : exit
469 : end if
470 60182 : hashkey = hashkey+1
471 60182 : collisions = collisions+1
472 60182 : 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 326229 : if (associated(node% left)) &
479 164034 : call do_enter_hash(node% left, hash, hash_size, collisions)
480 326229 : 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 720702 : 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 720702 : len = len_trim(key)
492 720702 : 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 10256714 : do i = 1, len
499 9539775 : c = ichar(key(i:i))
500 9539775 : if (iand(c,1)==1) then
501 : !new = (hash << 7) ^ (*str) * (hash >> 3)
502 5455408 : new = ieor(ishft(hash,7), c*ishft(hash,3))
503 : else
504 : !new = ~((hash << 11) + (*str) ^ (hash >> 5))
505 4084367 : new = not(ishft(hash,11) + ieor(c,ishft(hash,-5)))
506 : end if
507 10256714 : hash = ieor(hash, new)
508 : end do
509 716939 : dict_hashkey = hash
510 716939 : if (dict_hashkey < 0) then
511 329348 : dict_hashkey = -dict_hashkey
512 387591 : else if (dict_hashkey == 0) then
513 0 : dict_hashkey = 1
514 : end if
515 716939 : dict_hashkey = 1 + mod(dict_hashkey-1, hash_size)
516 716939 : 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
|
