Line data Source code
1 : ! ***********************************************************************
2 : !
3 : ! Copyright (C) 2014 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_idict
21 :
22 : use utils_def, only: integer_idict, ihash_entry
23 :
24 : implicit none
25 :
26 : contains
27 :
28 0 : recursive subroutine do_integer_idict_map(idict, fcn, ierr)
29 : type (integer_idict), pointer :: idict
30 : interface
31 : subroutine fcn(key1, key2, value, ierr)
32 : implicit none
33 : integer, intent(in) :: key1, key2, value
34 : integer, intent(out) :: ierr ! /= 0 means terminate map calls
35 : end subroutine fcn
36 : end interface
37 : type (integer_idict), pointer :: node
38 : integer, intent(out) :: ierr
39 0 : ierr = 0
40 0 : if (.not. associated(idict)) return
41 : node => idict
42 0 : do
43 0 : if (associated(node% left)) then
44 0 : call do_integer_idict_map(node% left, fcn, ierr)
45 0 : if (ierr /= 0) return
46 : end if
47 0 : call fcn(node% key1, node% key2, node% value, ierr)
48 0 : if (ierr /= 0) return
49 0 : if (.not. associated(node% right)) return
50 : node => node% right
51 : end do
52 : end subroutine do_integer_idict_map
53 :
54 :
55 0 : subroutine do_get_idict_entries(idict, key1s, key2s, values)
56 : type (integer_idict), pointer :: idict
57 : integer, pointer, dimension(:) :: key1s, key2s, values
58 :
59 : integer :: cnt, ierr, sz
60 0 : sz = size_integer_idict(idict)
61 0 : sz = min(sz, size(key1s,dim=1), size(key2s,dim=1), size(values,dim=1))
62 0 : cnt = 0
63 0 : call do_integer_idict_map(idict, fcn, ierr)
64 :
65 : contains
66 :
67 0 : subroutine fcn(key1, key2, value, ierr)
68 : integer, intent(in) :: key1, key2, value
69 : integer, intent(out) :: ierr ! /= 0 means terminate map calls
70 0 : if (cnt >= sz) then
71 0 : ierr = -1
72 0 : return
73 : end if
74 0 : cnt = cnt+1
75 0 : key1s(cnt) = key1
76 0 : key2s(cnt) = key2
77 0 : values(cnt) = value
78 : end subroutine fcn
79 :
80 : end subroutine do_get_idict_entries
81 :
82 :
83 0 : recursive subroutine show_key1_key2_entries(idict)
84 : type (integer_idict), pointer :: idict
85 : type (integer_idict), pointer :: node
86 0 : if (.not. associated(idict)) return
87 : node => idict
88 : do
89 0 : if (associated(node% left)) then
90 0 : call show_key1_key2_entries(node% left)
91 : end if
92 0 : write(*,fmt='(3i10)') node% key1, node% key2, node% value
93 0 : if (.not. associated(node% right)) return
94 : node => node% right
95 : end do
96 : end subroutine show_key1_key2_entries
97 :
98 :
99 4 : subroutine find_key1_key2_entry(idict, key1, key2, node)
100 : type (integer_idict), pointer :: idict
101 : integer, intent(in) :: key1, key2
102 : type (integer_idict), pointer :: node ! set null if cannot find key1, key2 in idict
103 4 : type (ihash_entry), pointer :: hash(:)
104 : integer :: i, hash_size, hashkey
105 4 : if (.not. associated(idict)) then
106 0 : nullify(node); return
107 : end if
108 4 : if (associated(idict% hash)) then
109 4 : hash => idict% hash
110 4 : hash_size = size(hash)
111 4 : hashkey = idict_hashkey(key1, key2, hash_size)
112 4 : do i=1, hash_size ! find an empty slot
113 4 : if (.not. associated(hash(hashkey)% ptr)) exit
114 3 : if (hash(hashkey)% ptr% key1 == key1 .and. &
115 : hash(hashkey)% ptr% key2 == key2) then
116 3 : node => hash(hashkey)% ptr
117 3 : return
118 : end if
119 0 : hashkey = hashkey+1
120 1 : if (hashkey > hash_size) hashkey = 1
121 : end do
122 1 : nullify(node)
123 1 : return ! failed to find key1, key2
124 : end if
125 0 : node => idict
126 : do
127 0 : if (node% key1 == key1 .and. node% key2 == key2) return
128 0 : if (node% key1 < key1 .or. &
129 : (node% key1 == key1 .and. node% key2 < key2)) 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 4 : end subroutine find_key1_key2_entry
142 :
143 :
144 11 : recursive subroutine insert_node(node, root, duplicate)
145 : type (integer_idict), pointer :: node ! will be deallocated if a duplicate
146 : type (integer_idict), 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 11 : if (node% key1 == root% key1 .and. node% key2 == root% key2) then
153 3 : root% value = node% value
154 3 : deallocate(node)
155 : nullify(node)
156 3 : duplicate = .true.
157 3 : return
158 : end if
159 :
160 8 : if (node% key1 > root% key1 .or. &
161 : (node% key1 == root% key1 .and. &
162 : node% key2 > root% key2)) then ! insert on left
163 2 : if (.not. associated(root% left)) then
164 1 : root% left => node
165 : else
166 1 : call insert_node(node, root% left, duplicate)
167 : end if
168 2 : height_left = root% left% height
169 2 : height_right = height_of_right_branch(root)
170 2 : if (height_left - height_right == 2) then ! rebalance
171 1 : if (node% key1 > root% left% key1 .or. &
172 : (node% key1 == root% left% key1 .and. &
173 : node% key2 > root% left% key2)) then ! insert on left
174 0 : call single_rotate_with_left(root)
175 : else
176 1 : call double_rotate_with_left(root)
177 : end if
178 : end if
179 : else ! insert on right
180 6 : if (.not. associated(root% right)) then
181 2 : root% right => node
182 : else
183 4 : call insert_node(node, root% right, duplicate)
184 : end if
185 6 : height_right = root% right% height
186 6 : height_left = height_of_left_branch(root)
187 6 : if (height_right - height_left == 2) then ! rebalance
188 0 : if (root% right% key1 > node% key1 .or. &
189 : (root% right% key1 == node% key1 .and. &
190 : root% right% key2 > node% key2)) then
191 0 : call single_rotate_with_right(root)
192 : else
193 0 : call double_rotate_with_right(root)
194 : end if
195 : end if
196 : end if
197 :
198 8 : height_right = height_of_right_branch(root)
199 8 : height_left = height_of_left_branch(root)
200 8 : root% height = max(height_right, height_left) + 1
201 :
202 :
203 : contains
204 :
205 :
206 17 : integer function height_of_left_branch(n)
207 : type (integer_idict), pointer :: n
208 14 : if (.not. associated(n% left)) then
209 : height_of_left_branch = 0
210 : else
211 9 : height_of_left_branch = n% left% height
212 : end if
213 : end function height_of_left_branch
214 :
215 :
216 13 : integer function height_of_right_branch(n)
217 : type (integer_idict), pointer :: n
218 10 : if (.not. associated(n% right)) then
219 : height_of_right_branch = 0
220 : else
221 7 : height_of_right_branch = n% right% height
222 : end if
223 : end function height_of_right_branch
224 :
225 :
226 1 : subroutine single_rotate_with_left(k2)
227 : type (integer_idict), pointer :: k2
228 : type (integer_idict), pointer :: k1
229 1 : k1 => k2% left
230 1 : if (.not. associated(k1% right)) then
231 1 : nullify(k2% left)
232 : else
233 0 : k2% left => k1% right
234 : end if
235 1 : k1% right => k2
236 1 : k2% height = max(height_of_left_branch(k2), height_of_right_branch(k2)) + 1
237 1 : k1% height = max(height_of_left_branch(k1), k2% height) + 1
238 1 : k2 => k1
239 1 : end subroutine single_rotate_with_left
240 :
241 :
242 1 : subroutine single_rotate_with_right(k1)
243 : type (integer_idict), pointer :: k1
244 : type (integer_idict), pointer :: k2
245 1 : k2 => k1% right
246 1 : if (.not. associated(k2% left)) then
247 1 : nullify(k1% right)
248 : else
249 0 : k1% right => k2% left
250 : end if
251 1 : k2% left => k1
252 1 : k1% height = max(height_of_right_branch(k1), height_of_left_branch(k1)) + 1
253 1 : k2% height = max(height_of_right_branch(k2), k1% height) + 1
254 1 : k1 => k2
255 1 : end subroutine single_rotate_with_right
256 :
257 :
258 1 : subroutine double_rotate_with_left(k)
259 : type (integer_idict), pointer :: k
260 1 : call single_rotate_with_right(k% left)
261 1 : call single_rotate_with_left(k)
262 1 : end subroutine double_rotate_with_left
263 :
264 :
265 0 : subroutine double_rotate_with_right(k)
266 : type (integer_idict), pointer :: k
267 0 : call single_rotate_with_left(k% right)
268 0 : call single_rotate_with_right(k)
269 0 : end subroutine double_rotate_with_right
270 :
271 :
272 : end subroutine insert_node
273 :
274 :
275 7 : subroutine do_integer_idict_define(idict, key1, key2, value, duplicate, ierr)
276 : type (integer_idict), pointer :: idict ! pass null for empty idict
277 : integer, intent(in) :: key1, key2, value
278 : logical, intent(out) :: duplicate ! true if key was already defined
279 : integer, intent(out) :: ierr
280 : type (integer_idict), pointer :: node
281 : logical, parameter :: dbg = .false.
282 : ierr = 0
283 7 : allocate(node, stat=ierr)
284 7 : if (ierr /= 0) return
285 7 : !$omp critical (idict_define)
286 7 : duplicate = .false.
287 7 : node% key1 = key1
288 7 : node% key2 = key2
289 7 : node% value = value
290 7 : node% height = 1
291 7 : nullify(node% left)
292 7 : nullify(node% right)
293 7 : nullify(node% hash)
294 7 : if (.not. associated(idict)) then ! this is the 1st entry
295 1 : idict => node
296 : else
297 6 : if (associated(idict% hash)) then
298 0 : deallocate(idict% hash)
299 0 : nullify(idict% hash)
300 : end if
301 6 : call insert_node(node, idict, duplicate)
302 : end if
303 : !$omp end critical (idict_define)
304 : if (dbg) then ! check tree
305 : write(*,'(A)')
306 : call check_idict(idict, ierr)
307 : call show_key1_key2_entries(idict)
308 : write(*,*) 'done insert', key1, key2
309 : end if
310 : end subroutine do_integer_idict_define
311 :
312 :
313 5 : subroutine do_integer_idict_create_hash(idict, ierr)
314 : type (integer_idict), pointer :: idict
315 : integer, intent(out) :: ierr
316 :
317 : integer :: cnt, hash_size, i, collisions
318 5 : type (ihash_entry), pointer :: hash(:)
319 :
320 5 : ierr = 0
321 5 : if (.not. associated(idict)) then
322 4 : ierr = -1; return
323 : end if
324 5 : if (associated(idict% hash)) return
325 :
326 1 : !$omp critical (create_hash)
327 1 : if (.not. associated(idict% hash)) then
328 1 : cnt = size_integer_idict(idict) ! number of entries
329 1 : if (cnt > 0) then
330 1 : hash_size = 4*cnt
331 1 : allocate(idict% hash(hash_size), stat=ierr)
332 1 : if (ierr /= 0) then
333 0 : write(*,*) 'failed in allocate for create hash', hash_size
334 : else
335 1 : hash => idict% hash
336 17 : do i=1,hash_size
337 17 : nullify(hash(i)% ptr)
338 : end do
339 1 : collisions = 0
340 1 : call do_enter_hash(idict, hash, hash_size, collisions)
341 : end if
342 : end if
343 : end if
344 : !$omp end critical (create_hash)
345 :
346 5 : end subroutine do_integer_idict_create_hash
347 :
348 :
349 0 : recursive subroutine check_idict(idict, ierr)
350 : type (integer_idict), pointer :: idict
351 : integer, intent(out) :: ierr
352 : integer :: height_left, height_right, height
353 0 : if (associated(idict% left)) then
354 0 : if (idict% key1 > idict% left% key1 .or. &
355 : (idict% key1 == idict% left% key1 .and. &
356 : idict% key2 > idict% left% key2)) then
357 0 : write(*,*) 'wrong order idict% key1, key2, idict% left% key1, key2', &
358 0 : idict% key1, idict% key2, idict% left% key1, idict% left% key2
359 0 : ierr = -1
360 0 : return
361 : end if
362 0 : call check_idict(idict% left, ierr)
363 0 : if (ierr /= 0) return
364 0 : height_left = idict% left% height
365 : else
366 : height_left = 0
367 : end if
368 0 : if (associated(idict% right)) then
369 0 : if (idict% right% key1 > idict% key1 .or. &
370 : (idict% right% key1 == idict% key1 .and. &
371 : idict% right% key2 > idict% key2)) then
372 0 : write(*,*) 'wrong order idict% right% key1, key2, idict% key1, key2', &
373 0 : idict% right% key1, idict% right% key2, idict% key1, idict% key2
374 0 : ierr = -1
375 0 : return
376 : end if
377 0 : call check_idict(idict% right, ierr)
378 0 : if (ierr /= 0) return
379 0 : height_right = idict% right% height
380 : else
381 : height_right = 0
382 : end if
383 0 : height = max(height_left, height_right) + 1
384 0 : if (idict% height /= height) then
385 0 : write(*,*) 'bad height for', idict% key1, idict% key2
386 0 : ierr = -1
387 : end if
388 : end subroutine check_idict
389 :
390 :
391 4 : subroutine do_integer_idict_lookup(idict, key1, key2, value, ierr)
392 : type (integer_idict), pointer :: idict
393 : integer, intent(in) :: key1, key2
394 : integer, intent(out) :: value
395 : integer, intent(out) :: ierr ! 0 if found key1, key2 in idict, -1 if didn't
396 : type (integer_idict), pointer :: node
397 : logical, parameter :: dbg = .false.
398 : if (dbg) then
399 : call show_key1_key2_entries(idict)
400 : write(*,'(A)')
401 : write(*,*) 'lookup key1, key2', key1, key2
402 : write(*,'(A)')
403 : end if
404 : ierr = 0
405 4 : value = 0
406 4 : call do_integer_idict_create_hash(idict, ierr)
407 7 : if (ierr /= 0) return
408 4 : call find_key1_key2_entry(idict, key1, key2, node)
409 4 : if (associated(node)) then
410 3 : value = node% value
411 3 : return
412 : end if
413 1 : ierr = -1
414 : end subroutine do_integer_idict_lookup
415 :
416 :
417 2 : recursive subroutine do_integer_idict_free(idict)
418 : type (integer_idict), pointer :: idict
419 : type (integer_idict), pointer :: node, next
420 2 : if (.not. associated(idict)) return
421 2 : node => idict
422 2 : if (associated(node% hash)) deallocate(node% hash)
423 2 : do
424 4 : if (associated(node% left)) call do_integer_idict_free(node% left)
425 4 : if (.not. associated(node% right)) then
426 2 : deallocate(node)
427 2 : return
428 : end if
429 2 : next => node% right
430 2 : deallocate(node)
431 2 : node => next
432 : end do
433 : end subroutine do_integer_idict_free
434 :
435 :
436 2 : recursive function size_integer_idict(idict) result(cnt)
437 : type (integer_idict), pointer :: idict
438 : type (integer_idict), pointer :: node, next
439 : integer :: cnt
440 2 : cnt = 0
441 2 : if (.not. associated(idict)) return
442 : node => idict
443 : do
444 4 : cnt = cnt + 1
445 4 : if (associated(node% left)) cnt = cnt + size_integer_idict(node% left)
446 4 : if (.not. associated(node% right)) return
447 : next => node% right
448 : node => next
449 : end do
450 : end function size_integer_idict
451 :
452 :
453 2 : recursive subroutine do_enter_hash(idict, hash, hash_size, collisions)
454 : type (integer_idict), pointer :: idict
455 : type (ihash_entry), pointer :: hash(:)
456 : integer, intent(in) :: hash_size
457 : integer, intent(inout) :: collisions
458 : type (integer_idict), pointer :: node, next
459 : integer :: hashkey, i
460 : logical :: okay
461 2 : if (.not. associated(idict)) return
462 : node => idict
463 : do
464 : ! enter node in hash
465 4 : hashkey = idict_hashkey(node% key1, node% key2, hash_size)
466 4 : okay = .false.
467 4 : do i=1, hash_size ! find an empty slot
468 4 : if (.not. associated(hash(hashkey)% ptr)) then
469 4 : hash(hashkey)% ptr => node
470 : okay = .true.
471 : exit
472 : end if
473 0 : hashkey = hashkey+1
474 0 : collisions = collisions+1
475 0 : if (hashkey > hash_size) hashkey = 1
476 : end do
477 : if (.not. okay) then
478 0 : write(*,*) 'failed in do_enter_hash'
479 0 : error stop 1
480 : end if
481 4 : if (associated(node% left)) &
482 1 : call do_enter_hash(node% left, hash, hash_size, collisions)
483 4 : if (.not. associated(node% right)) return
484 : next => node% right
485 : node => next
486 : end do
487 : end subroutine do_enter_hash
488 :
489 :
490 8 : integer function idict_hashkey(key1, key2, hash_size) ! value between 1 and hash_size
491 : integer, intent(in) :: key1, key2, hash_size
492 : integer:: new, hash, c
493 : ! source: http://www.partow.net/programming/hashfunctions/#APHashFunction
494 8 : hash = -1431655766 ! Z'AAAAAAAA'
495 8 : c = key1
496 8 : if (iand(c,1)==1) then
497 : !new = (hash << 7) ^ (*str) * (hash >> 3)
498 4 : new = ieor(ishft(hash,7), c*ishft(hash,3))
499 : else
500 : !new = ~((hash << 11) + (*str) ^ (hash >> 5))
501 4 : new = not(ishft(hash,11) + ieor(c,ishft(hash,-5)))
502 : end if
503 8 : hash = ieor(hash, new)
504 8 : c = key2
505 8 : if (iand(c,1)==1) then
506 : !new = (hash << 7) ^ (*str) * (hash >> 3)
507 2 : new = ieor(ishft(hash,7), c*ishft(hash,3))
508 : else
509 : !new = ~((hash << 11) + (*str) ^ (hash >> 5))
510 6 : new = not(ishft(hash,11) + ieor(c,ishft(hash,-5)))
511 : end if
512 8 : idict_hashkey = ieor(hash, new)
513 8 : if (idict_hashkey < 0) then
514 6 : idict_hashkey = -idict_hashkey
515 2 : else if (idict_hashkey == 0) then
516 0 : idict_hashkey = 1
517 : end if
518 8 : idict_hashkey = 1 + mod(idict_hashkey-1, hash_size)
519 8 : if (idict_hashkey <= 0) then
520 0 : write(*,*) 'bad idict_hashkey for', key1, key2, idict_hashkey
521 0 : stop 'idict_hashkey'
522 : end if
523 8 : end function idict_hashkey
524 :
525 : end module utils_idict
|
