Branch data Line data Source code
1 : : !!****m* ABINIT/m_hastable
2 : : !! NAME
3 : : !! m_hashtable
4 : : !!
5 : : !! FUNCTION
6 : : !! This module provide a string: value pair hash table
7 : : !! COPYRIGHT
8 : : !! Taken from http://fortranwiki.org/fortran/show/hash+table+example
9 : : !! The code is originally written by Izaak Beekman under the LGPL license.
10 : : !! Adapted for usage in Abinit by hexu
11 : : !!
12 : : !! Note: the behavior is different from the origial version
13 : : !! The value will be overwritten in this version, whereas it is ignored in the
14 : : !! original version if the key is already in the table (why??!!).
15 : : !!
16 : : !! Note2:!!!!!!!!!!!!!!!!! FIXME
17 : : !! It does not handle white space at the end of string correctly. It does not affect
18 : : !! the usage in Multibinit but BE CAREFUL.
19 : : !!
20 : : !! Below is the original Copyright.
21 : : !!=======================================
22 : : !! Copyright (C) Izaak Beekman 2010
23 : : !! This program is free software: you can redistribute it and/or modify
24 : : !! it under the terms of the GNU Lesser General Public License as published by
25 : : !! the Free Software Foundation, either version 3 of the License, or
26 : : !! (at your option) any later version.
27 : : !!
28 : : !! This program is distributed in the hope that it will be useful,
29 : : !! but WITHOUT ANY WARRANTY; without even the implied warranty of
30 : : !! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
31 : : !! GNU Lesser General Public License for more details.
32 : : !! You should have received a copy of the GNU Lesser General Public License
33 : : !! along with this program. If not, see <http://www.gnu.org/licenses/>.
34 : : !!
35 : : !! SOURCE
36 : :
37 : : #if defined HAVE_CONFIG_H
38 : : #include "config.h"
39 : : #endif
40 : :
41 : : #include "abi_common.h"
42 : :
43 : : MODULE m_hashtable_strval
44 : :
45 : : !!***
46 : : use defs_basis
47 : : use m_errors
48 : : use m_abicore
49 : : use, intrinsic :: iso_c_binding
50 : : !use, intrinsic :: iso_c_binding, only: c_double, c_int64_t
51 : : !USE, INTRINSIC :: IEEE_ARITHMETIC
52 : :
53 : : !use, intrinsic :: ieee_arithmetic, only: IEEE_Value, IEEE_QUIET_NAN
54 : : !use, intrinsic :: iso_fortran_env, only: real64
55 : :
56 : : IMPLICIT NONE ! Use strong typing
57 : : INTEGER, PARAMETER :: tbl_size = 50
58 : : !real(real64) :: nan
59 : : !nan = IEEE_VALUE(nan, IEEE_QUIET_NAN)
60 : : ! The above one is more standard, but how to make nan a parameter?
61 : : ! The following is used instead.
62 : : !real(c_double), parameter :: NAN=IEEE_VALUE(nan, IEEE_QUIET_NAN)
63 : :
64 : : !real(c_double), parameter :: NAN = TRANSFER(9218868437227405313_c_int64_t, 1._c_double)
65 : : ! NOTE: this is not NAN really. The correct one is the last line. But NAG compiler does not think it is a valid floating number.
66 : : ! real(c_double), parameter :: NAN = TRANSFER(921886843722740531_c_int64_t, 1._c_double)
67 : :
68 : : ! NB: We have to use SIZEOF_INT CPP macro giving the size of `int', as computed by sizeof.
69 : : ! to declare the length of char buffers as in:
70 : : !
71 : : ! character(len=SIZEOF_INT * n) :: tmp
72 : : !
73 : : ! as cray-intel ftn and NAG do not support declaratations like:
74 : : !
75 : : !character(len=c_sizeof(key)) :: tmp
76 : :
77 : :
78 : : TYPE sllist
79 : : TYPE(sllist), POINTER :: child => NULL()
80 : : CHARACTER(len=:), ALLOCATABLE :: key
81 : : real(dp) :: val
82 : : CONTAINS
83 : : PROCEDURE :: put => put_sll
84 : : PROCEDURE :: get => get_sll
85 : : PROCEDURE :: free => free_sll
86 : : PROCEDURE :: sum_val => sum_val_sll
87 : : procedure :: sum_entry => sum_entry_sll
88 : : procedure :: print_all => print_all_sll
89 : : procedure :: print_entry => print_entry_sll
90 : : END TYPE sllist
91 : :
92 : : TYPE hash_table_t
93 : : TYPE(sllist), DIMENSION(:), ALLOCATABLE :: vec
94 : : INTEGER :: vec_len = 0
95 : : LOGICAL :: is_init = .FALSE.
96 : : CONTAINS
97 : : PROCEDURE :: init => init_hash_table_t
98 : : PROCEDURE :: put => put_hash_table_t
99 : : PROCEDURE :: get => get_hash_table_t
100 : : PROCEDURE :: free => free_hash_table_t
101 : : PROCEDURE :: sum_val => sum_val_hash_table_t
102 : : PROCEDURE :: print_all => print_all_hash_table_t
103 : : procedure :: print_entry => print_entry_hash_table_t
104 : : procedure :: has_key
105 : : procedure :: put_intn
106 : : procedure :: get_intn
107 : : procedure :: has_key_intn
108 : : procedure :: put_int3
109 : : procedure :: get_int3
110 : : procedure :: has_key_int3
111 : :
112 : : END TYPE hash_table_t
113 : :
114 : : PUBLIC :: hash_table_t
115 : :
116 : :
117 : : CONTAINS
118 : :
119 : 150737 : RECURSIVE SUBROUTINE put_sll(list,key,val)
120 : : CLASS(sllist), INTENT(inout) :: list
121 : : CHARACTER(len=*), INTENT(in) :: key
122 : : real(dp), intent(in) :: val
123 : : INTEGER :: keylen
124 : :
125 : 150737 : keylen = LEN(key)
126 : 150737 : IF (ALLOCATED(list%key)) THEN
127 [ + + ]: 140578 : IF (list%key /= key) THEN
128 [ + + ]: 45539 : IF ( .NOT. ASSOCIATED(list%child)) then
129 [ - + ]: 7639 : ABI_MALLOC_SCALAR(list%child)
130 : : end IF
131 : :
132 : 45539 : CALL put_sll(list%child,key,val)
133 : : else
134 : 95039 : list%val=val
135 : : END IF
136 : : ELSE
137 : : IF (.NOT. ALLOCATED(list%key)) &
138 [ - + - + ]: 10159 : ABI_MALLOC_TYPE_SCALAR(CHARACTER(len=keylen), list%key)
139 [ - + - + : 10159 : list%key = key
+ - ]
140 : 10159 : list%val = val
141 : : END IF
142 [ + + ]: 150737 : END SUBROUTINE put_sll
143 : :
144 : :
145 : 2853775457 : RECURSIVE SUBROUTINE get_sll(list,key,val)
146 : : CLASS(sllist), INTENT(in) :: list
147 : : CHARACTER(len=*), INTENT(in) :: key
148 : : real(dp), INTENT(out) :: val
149 : : INTEGER :: vallen
150 : :
151 : 2853775457 : vallen = 0
152 : 2853775457 : val=MAGIC_UNDEF
153 [ + + + + ]: 2853775457 : IF (ALLOCATED(list%key) .AND. (list%key == key)) THEN
154 : 29630178 : val = list%val
155 [ + + ]: 2824145279 : ELSE IF(ASSOCIATED(list%child)) THEN ! keep going
156 : 2215477367 : CALL get_sll(list%child,key,val)
157 : : ELSE ! At the end of the list, no key found
158 : : return
159 : : END IF
160 : : END SUBROUTINE get_sll
161 : :
162 : :
163 : 129319 : RECURSIVE SUBROUTINE free_sll(list)
164 : : CLASS(sllist), INTENT(inout) :: list
165 [ + + ]: 129319 : IF (ASSOCIATED(list%child)) THEN
166 : 7639 : CALL free_sll(list%child)
167 [ - + - + ]: 7639 : ABI_FREE_SCALAR(list%child)
168 : : END IF
169 : 129319 : list%child => NULL()
170 [ + + ]: 129319 : ABI_SFREE(list%key)
171 : 129319 : END SUBROUTINE free_sll
172 : :
173 : 10504 : recursive function sum_val_sll(self) result(s)
174 : : class(sllist), intent(in) :: self
175 : : real(dp) :: s
176 : 10504 : s=0.0_dp
177 [ + + ]: 10504 : if (allocated(self%key)) then
178 : 909 : s=s+self%val
179 [ + + ]: 909 : if(associated(self%child)) then
180 : 404 : s=s+self%child%sum_val()
181 : : endif
182 : : end if
183 : 10504 : end function sum_val_sll
184 : :
185 : 41600 : recursive function sum_entry_sll(self, label, prefix) result(s)
186 : : class(sllist), intent(in) :: self
187 : : character(*), optional, intent(in) :: label
188 : : character(*), optional, intent(in) :: prefix
189 : : real(dp) :: s
190 : :
191 : : integer :: length
192 : :
193 [ - + ]: 41600 : if((.not. present(prefix)) .and. (.not. present(label))) then
194 : 0 : ABI_ERROR('Label and prefix not present.')
195 : : endif
196 [ - + ]: 41600 : if(present(label) .and. present(prefix)) then
197 : 0 : ABI_ERROR('Label and prefix present, only specify one of the two.')
198 : : endif
199 : :
200 [ + + ]: 41600 : if(present(prefix)) length=len(prefix)
201 : :
202 : 41600 : s=0.0_dp
203 [ + + ]: 41600 : if (allocated(self%key)) then
204 [ + + ]: 3600 : if(present(prefix)) then
205 [ + + ]: 900 : if(self%key(1:length) .eq. prefix) then
206 : 300 : s=s+self%val
207 : : endif
208 : : else
209 [ + + ]: 2700 : if(self%key .eq. label) then
210 : 600 : s=s+self%val
211 : : endif
212 : : endif
213 [ + + ]: 3600 : if(associated(self%child)) then
214 [ + + + + ]: 3200 : s=s+self%child%sum_entry(label=label, prefix=prefix)
215 : : endif
216 : : end if
217 : 41600 : end function sum_entry_sll
218 : :
219 : 0 : recursive subroutine print_all_sll(self)
220 : : class(sllist), intent(in) :: self
221 : : character(len=80) :: msg
222 : :
223 [ # # ]: 0 : if (allocated(self%key)) then
224 : 0 : write(msg, "(A40, 1X, ES13.5)") self%key, self%val
225 : 0 : call wrtout(std_out,msg,'COLL')
226 : 0 : call wrtout(ab_out, msg, 'COLL')
227 [ # # ]: 0 : if(associated(self%child)) then
228 : 0 : call self%child%print_all()
229 : : endif
230 : : end if
231 : 0 : end subroutine print_all_sll
232 : :
233 : 416 : recursive subroutine print_entry_sll(self, label, prefix)
234 : : class(sllist), intent(in) :: self
235 : : character(*), optional, intent(in) :: label
236 : : character(*), optional, intent(in) :: prefix
237 : :
238 : : integer :: length
239 : : character(len=80) :: msg
240 : :
241 [ - + ]: 416 : if((.not. present(prefix)) .and. (.not. present(label))) then
242 : 0 : ABI_ERROR('Label and prefix not present.')
243 : : endif
244 [ - + ]: 416 : if(present(label) .and. present(prefix)) then
245 : 0 : ABI_ERROR('Label and prefix present, only specify one of the two.')
246 : : endif
247 : :
248 [ + + ]: 416 : if(present(prefix)) then
249 : 104 : length=len(prefix)
250 : : endif
251 : :
252 [ + + ]: 416 : if (allocated(self%key)) then
253 [ + + ]: 36 : if(present(prefix)) then
254 [ + + ]: 9 : if(self%key(1:length) .eq. prefix) then
255 : 3 : write(msg, "(A40, 1X, ES13.5)") self%key, self%val
256 : 3 : call wrtout(std_out,msg,'COLL')
257 : 3 : call wrtout(ab_out, msg, 'COLL')
258 : : endif
259 : : else !not prefix but label present
260 [ + + ]: 27 : if(self%key .eq. label) then
261 : 6 : write(msg, "(A40, 1X, ES13.5)") self%key, self%val
262 : 6 : call wrtout(std_out,msg,'COLL')
263 : 6 : call wrtout(ab_out, msg, 'COLL')
264 : : endif
265 : : endif
266 [ + + ]: 36 : if(associated(self%child)) then
267 [ + + + + ]: 32 : call self%child%print_entry(label=label, prefix=prefix)
268 : : endif
269 : : endif
270 : :
271 : 416 : end subroutine print_entry_sll
272 : :
273 : 66 : SUBROUTINE init_hash_table_t(tbl,tbl_len)
274 : : CLASS(hash_table_t), INTENT(inout) :: tbl
275 : : INTEGER, OPTIONAL, INTENT(in) :: tbl_len
276 : :
277 [ - + - - : 66 : ABI_SFREE(tbl%vec)
- - - - ]
278 [ + + ]: 66 : IF (PRESENT(tbl_len)) THEN
279 [ - + + - : 121560 : ABI_MALLOC(tbl%vec, (tbl_len))
+ - + - -
+ - + - +
+ + ]
280 : 60 : tbl%vec_len = tbl_len
281 : : ELSE
282 [ - + - + : 306 : ABI_MALLOC(tbl%vec, (tbl_size))
+ + ]
283 : 6 : tbl%vec_len = tbl_size
284 : : END IF
285 : 66 : tbl%is_init = .TRUE.
286 : 66 : END SUBROUTINE init_hash_table_t
287 : :
288 : : ! The first part of the hashing procedure using the string
289 : : ! collating sequence
290 : 638403288 : ELEMENTAL FUNCTION sum_string(str) RESULT(sig)
291 : : CHARACTER(len=*), INTENT(in) :: str
292 : : INTEGER :: sig
293 : 638403288 : CHARACTER, DIMENSION(LEN(str)) :: tmp
294 : : INTEGER :: i
295 : :
296 [ + + ]: 10347013160 : FORALL (i=1:LEN(str))
297 : : tmp(i) = str(i:i)
298 : : END FORALL
299 [ + + ]: 10347013160 : sig = SUM(ICHAR(tmp))
300 : 638403288 : END FUNCTION sum_string
301 : :
302 : :
303 : 105198 : SUBROUTINE put_hash_table_t(tbl,key,val)
304 : : CLASS(hash_table_t), INTENT(inout) :: tbl
305 : : CHARACTER(len=*), INTENT(in) :: key
306 : : real(dp), INTENT(in) :: val
307 : : INTEGER :: hash
308 : :
309 : 105198 : hash = MOD(sum_string(key),tbl%vec_len) +1
310 : 105198 : CALL tbl%vec(hash)%put(key=key,val=val)
311 : 105198 : END SUBROUTINE put_hash_table_t
312 : :
313 : :
314 : 638298090 : function get_hash_table_t(tbl,key) result(val)
315 : : CLASS(hash_table_t), INTENT(in) :: tbl
316 : : CHARACTER(len=*), INTENT(in) :: key
317 : : real(dp) :: val
318 : : INTEGER :: hash
319 : :
320 : 638298090 : hash = MOD(sum_string(key),tbl%vec_len) + 1
321 : 638298090 : CALL tbl%vec(hash)%get(key=key,val=val)
322 : 638298090 : END function get_hash_table_t
323 : :
324 : :
325 : 66 : SUBROUTINE free_hash_table_t(tbl)
326 : : CLASS(hash_table_t), INTENT(inout) :: tbl
327 : : INTEGER :: i, low, high
328 : :
329 [ + - ]: 66 : low = LBOUND(tbl%vec,dim=1)
330 [ + - ]: 66 : high = UBOUND(tbl%vec,dim=1)
331 [ + - ]: 66 : IF (ALLOCATED(tbl%vec)) THEN
332 [ + + ]: 121746 : DO i=low,high
333 : 121746 : CALL tbl%vec(i)%free()
334 : : END DO
335 [ + - + + : 121746 : ABI_FREE(tbl%vec)
- + - + ]
336 : : END IF
337 : 66 : tbl%is_init = .FALSE.
338 : 66 : END SUBROUTINE free_hash_table_t
339 : :
340 : 638298090 : function has_key(self, key)
341 : : class(hash_table_t), intent(in) :: self
342 : : character(*), intent(in) :: key
343 : : logical :: has_key
344 : 638298090 : has_key=(self%get(key)/=MAGIC_UNDEF)
345 : 638298090 : end function has_key
346 : :
347 : 1002 : function sum_val_hash_table_t(self, label, prefix) result(s)
348 : : class(hash_table_t), intent(in) :: self
349 : : character(len=*), optional, intent(in) :: label, prefix
350 : :
351 : : real(dp) :: s
352 : : integer :: i
353 : 1002 : s=0.0_dp
354 [ + - ]: 1002 : if (.not.(self%is_init)) then
355 : : return
356 : : end if
357 [ + + ]: 51102 : do i =1, self%vec_len
358 [ + + ]: 51102 : if(present(label) .or. present(prefix)) then
359 [ + + + + ]: 80000 : s=s+self%vec(i)%sum_entry(label=label, prefix=prefix)
360 : : else
361 : 10100 : s=s+ self%vec(i)%sum_val()
362 : : endif
363 : : end do
364 : : end function sum_val_hash_table_t
365 : :
366 : 0 : subroutine print_all_hash_table_t(self)
367 : : class(hash_table_t), intent(in) :: self
368 : : integer :: i, low, high
369 [ # # ]: 0 : low = LBOUND(self%vec,dim=1)
370 [ # # ]: 0 : high = UBOUND(self%vec,dim=1)
371 : :
372 [ # # ]: 0 : if (allocated(self%vec)) then
373 [ # # ]: 0 : do i =low, high
374 : 0 : call self%vec(i)%print_all()
375 : : end do
376 : : end if
377 : 0 : end subroutine print_all_hash_table_t
378 : :
379 : 8 : subroutine print_entry_hash_table_t(self, label, prefix)
380 : : class(hash_table_t), intent(in) :: self
381 : : character(len=*), optional, intent(in) :: label, prefix
382 : : integer :: i, low, high
383 [ + - ]: 8 : low = LBOUND(self%vec,dim=1)
384 [ + - ]: 8 : high = UBOUND(self%vec,dim=1)
385 : :
386 [ + - ]: 8 : if (allocated(self%vec)) then
387 [ + + ]: 408 : do i =low, high
388 [ + + + + ]: 808 : call self%vec(i)%print_entry(label=label, prefix=prefix)
389 : : end do
390 : : end if
391 : 8 : end subroutine print_entry_hash_table_t
392 : :
393 : 10142 : subroutine put_intn(self, key, val, n)
394 : : class(hash_table_t), intent(inout) :: self
395 : : integer :: n
396 : : integer, intent(in) :: key(n)
397 : : real(dp) :: val
398 : : !character(len=c_sizeof(key)) :: tmp
399 : 10142 : character(len=SIZEOF_INT * n) :: tmp
400 [ - + - + ]: 10142 : call self%put(transfer(key, tmp), val)
401 : 10142 : end subroutine put_intn
402 : :
403 : 0 : function get_intn(self, key,n) result(val)
404 : : class(hash_table_t), intent(inout) :: self
405 : : integer, intent(in) :: n
406 : : integer, intent(in) :: key(n)
407 : : real(dp) :: val
408 : : !character(len=c_sizeof(key)) :: tmp
409 : 0 : character(len=SIZEOF_INT * n) :: tmp
410 [ # # # # ]: 0 : val = self%get(transfer(key, tmp))
411 : 0 : end function get_intn
412 : :
413 : 638298090 : function has_key_intn(self, key, n) result(val)
414 : : class(hash_table_t), intent(inout) :: self
415 : : integer, intent(in) :: n
416 : : integer, intent(in) :: key(n)
417 : : logical :: val
418 : : !character(len=c_sizeof(key)) :: tmp
419 : 638298090 : character(len=SIZEOF_INT * n) :: tmp
420 [ - + - + ]: 638298090 : val = self%has_key(transfer(key, tmp))
421 : 638298090 : end function has_key_intn
422 : :
423 : :
424 : :
425 : 0 : subroutine put_int3(self, key, val)
426 : : class(hash_table_t), intent(inout) :: self
427 : : integer, intent(in) :: key(3)
428 : : real(dp) :: val
429 : : character(len=SIZEOF_INT * 3) :: tmp
430 : : !character(len=c_sizeof(key)) :: tmp
431 : 0 : call self%put(transfer(key, tmp), val)
432 : 0 : end subroutine put_int3
433 : :
434 : :
435 : 0 : function get_int3(self, key) result(val)
436 : : class(hash_table_t), intent(inout) :: self
437 : : integer, intent(in) :: key(3)
438 : : real(dp) :: val
439 : : character(len=12) :: tmp
440 : 0 : val = self%get(transfer(key, tmp))
441 : 0 : end function get_int3
442 : :
443 : :
444 : 0 : function has_key_int3(self, key) result(val)
445 : : class(hash_table_t), intent(inout) :: self
446 : : integer, intent(in) :: key(3)
447 : : logical :: val
448 : : character(len=12) :: tmp
449 : 0 : val = self%has_key(transfer(key, tmp))
450 : 0 : end function has_key_int3
451 : :
452 : :
453 : :
454 [ # # # # : 0 : end module m_hashtable_strval
# # # # #
# # # # #
# # # # ]
|
