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
|
