Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2026 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief a wrapper for basic fortran types.
10 : !> \par History
11 : !> 06.2004 created
12 : !> \author fawzi
13 : ! **************************************************************************************************
14 : MODULE input_val_types
15 :
16 : USE cp_parser_types, ONLY: default_continuation_character
17 : USE cp_units, ONLY: cp_unit_create,&
18 : cp_unit_desc,&
19 : cp_unit_from_cp2k,&
20 : cp_unit_from_cp2k1,&
21 : cp_unit_release,&
22 : cp_unit_type
23 : USE input_enumeration_types, ONLY: enum_i2c,&
24 : enum_release,&
25 : enum_retain,&
26 : enumeration_type
27 : USE kinds, ONLY: default_string_length,&
28 : dp
29 : #include "../base/base_uses.f90"
30 :
31 : IMPLICIT NONE
32 : PRIVATE
33 :
34 : LOGICAL, PRIVATE, PARAMETER :: debug_this_module = .TRUE.
35 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'input_val_types'
36 :
37 : PUBLIC :: val_p_type, val_type
38 : PUBLIC :: val_create, val_retain, val_release, val_get, val_write, &
39 : val_write_internal, val_duplicate
40 :
41 : INTEGER, PARAMETER, PUBLIC :: no_t = 0, logical_t = 1, &
42 : integer_t = 2, real_t = 3, char_t = 4, enum_t = 5, lchar_t = 6
43 :
44 : ! **************************************************************************************************
45 : !> \brief pointer to a val, to create arrays of pointers
46 : !> \param val to pointer to the val
47 : !> \author fawzi
48 : ! **************************************************************************************************
49 : TYPE val_p_type
50 : TYPE(val_type), POINTER :: val => NULL()
51 : END TYPE val_p_type
52 :
53 : ! **************************************************************************************************
54 : !> \brief a type to have a wrapper that stores any basic fortran type
55 : !> \param type_of_var type stored in the val (should be one of no_t,
56 : !> integer_t, logical_t, real_t, char_t)
57 : !> \param l_val , i_val, c_val, r_val: arrays with logical,integer,character
58 : !> or real values. Only one should be associated (and namely the one
59 : !> specified in type_of_var).
60 : !> \param enum an enumaration to map char to integers
61 : !> \author fawzi
62 : ! **************************************************************************************************
63 : TYPE val_type
64 : INTEGER :: ref_count = 0, type_of_var = no_t
65 : LOGICAL, DIMENSION(:), POINTER :: l_val => NULL()
66 : INTEGER, DIMENSION(:), POINTER :: i_val => NULL()
67 : CHARACTER(len=default_string_length), DIMENSION(:), POINTER :: &
68 : c_val => NULL()
69 : REAL(kind=dp), DIMENSION(:), POINTER :: r_val => NULL()
70 : TYPE(enumeration_type), POINTER :: enum => NULL()
71 : END TYPE val_type
72 : CONTAINS
73 :
74 : ! **************************************************************************************************
75 : !> \brief creates a keyword value
76 : !> \param val the object to be created
77 : !> \param l_val ,i_val,r_val,c_val,lc_val: a logical,integer,real,string, long
78 : !> string to be stored in the val
79 : !> \param l_vals , i_vals, r_vals, c_vals: an array of logicals,
80 : !> integers, reals, characters, long strings to be stored in val
81 : !> \param l_vals_ptr , i_vals_ptr, r_vals_ptr, c_vals_ptr: an array of logicals,
82 : !> ... to be stored in val, val will get the ownership of the pointer
83 : !> \param i_val ...
84 : !> \param i_vals ...
85 : !> \param i_vals_ptr ...
86 : !> \param r_val ...
87 : !> \param r_vals ...
88 : !> \param r_vals_ptr ...
89 : !> \param c_val ...
90 : !> \param c_vals ...
91 : !> \param c_vals_ptr ...
92 : !> \param lc_val ...
93 : !> \param lc_vals ...
94 : !> \param lc_vals_ptr ...
95 : !> \param enum the enumaration type this value is using
96 : !> \author fawzi
97 : !> \note
98 : !> using an enumeration only i_val/i_vals/i_vals_ptr are accepted
99 : ! **************************************************************************************************
100 1675800462 : SUBROUTINE val_create(val, l_val, l_vals, l_vals_ptr, i_val, i_vals, i_vals_ptr, &
101 3351559044 : r_val, r_vals, r_vals_ptr, c_val, c_vals, c_vals_ptr, lc_val, lc_vals, &
102 : lc_vals_ptr, enum)
103 :
104 : TYPE(val_type), POINTER :: val
105 : LOGICAL, INTENT(in), OPTIONAL :: l_val
106 : LOGICAL, DIMENSION(:), INTENT(in), OPTIONAL :: l_vals
107 : LOGICAL, DIMENSION(:), OPTIONAL, POINTER :: l_vals_ptr
108 : INTEGER, INTENT(in), OPTIONAL :: i_val
109 : INTEGER, DIMENSION(:), INTENT(in), OPTIONAL :: i_vals
110 : INTEGER, DIMENSION(:), OPTIONAL, POINTER :: i_vals_ptr
111 : REAL(KIND=DP), INTENT(in), OPTIONAL :: r_val
112 : REAL(KIND=DP), DIMENSION(:), INTENT(in), OPTIONAL :: r_vals
113 : REAL(KIND=DP), DIMENSION(:), OPTIONAL, POINTER :: r_vals_ptr
114 : CHARACTER(LEN=*), INTENT(in), OPTIONAL :: c_val
115 : CHARACTER(LEN=*), DIMENSION(:), INTENT(in), &
116 : OPTIONAL :: c_vals
117 : CHARACTER(LEN=default_string_length), &
118 : DIMENSION(:), OPTIONAL, POINTER :: c_vals_ptr
119 : CHARACTER(LEN=*), INTENT(in), OPTIONAL :: lc_val
120 : CHARACTER(LEN=*), DIMENSION(:), INTENT(in), &
121 : OPTIONAL :: lc_vals
122 : CHARACTER(LEN=default_string_length), &
123 : DIMENSION(:), OPTIONAL, POINTER :: lc_vals_ptr
124 : TYPE(enumeration_type), OPTIONAL, POINTER :: enum
125 :
126 : INTEGER :: i, len_c, narg, nVal
127 :
128 1675779522 : CPASSERT(.NOT. ASSOCIATED(val))
129 1675779522 : ALLOCATE (val)
130 1675779522 : NULLIFY (val%l_val, val%i_val, val%r_val, val%c_val, val%enum)
131 1675779522 : val%type_of_var = no_t
132 1675779522 : val%ref_count = 1
133 :
134 1675779522 : narg = 0
135 1675779522 : val%type_of_var = no_t
136 1675779522 : IF (PRESENT(l_val)) THEN
137 215527822 : narg = narg + 1
138 215527822 : ALLOCATE (val%l_val(1))
139 215527822 : val%l_val(1) = l_val
140 215527822 : val%type_of_var = logical_t
141 : END IF
142 1675779522 : IF (PRESENT(l_vals)) THEN
143 20940 : narg = narg + 1
144 62820 : ALLOCATE (val%l_val(SIZE(l_vals)))
145 41880 : val%l_val = l_vals
146 20940 : val%type_of_var = logical_t
147 : END IF
148 1675779522 : IF (PRESENT(l_vals_ptr)) THEN
149 23734 : narg = narg + 1
150 23734 : val%l_val => l_vals_ptr
151 23734 : val%type_of_var = logical_t
152 : END IF
153 :
154 1675779522 : IF (PRESENT(r_val)) THEN
155 484453107 : narg = narg + 1
156 484453107 : ALLOCATE (val%r_val(1))
157 484453107 : val%r_val(1) = r_val
158 484453107 : val%type_of_var = real_t
159 : END IF
160 1675779522 : IF (PRESENT(r_vals)) THEN
161 1899490 : narg = narg + 1
162 5698470 : ALLOCATE (val%r_val(SIZE(r_vals)))
163 7179120 : val%r_val = r_vals
164 1899490 : val%type_of_var = real_t
165 : END IF
166 1675779522 : IF (PRESENT(r_vals_ptr)) THEN
167 1079626 : narg = narg + 1
168 1079626 : val%r_val => r_vals_ptr
169 1079626 : val%type_of_var = real_t
170 : END IF
171 :
172 1675779522 : IF (PRESENT(i_val)) THEN
173 216701995 : narg = narg + 1
174 216701995 : ALLOCATE (val%i_val(1))
175 216701995 : val%i_val(1) = i_val
176 216701995 : val%type_of_var = integer_t
177 : END IF
178 1675779522 : IF (PRESENT(i_vals)) THEN
179 2202021 : narg = narg + 1
180 6606063 : ALLOCATE (val%i_val(SIZE(i_vals)))
181 7867574 : val%i_val = i_vals
182 2202021 : val%type_of_var = integer_t
183 : END IF
184 1675779522 : IF (PRESENT(i_vals_ptr)) THEN
185 191863 : narg = narg + 1
186 191863 : val%i_val => i_vals_ptr
187 191863 : val%type_of_var = integer_t
188 : END IF
189 :
190 1675779522 : IF (PRESENT(c_val)) THEN
191 3577047 : CPASSERT(LEN_TRIM(c_val) <= default_string_length)
192 3577047 : narg = narg + 1
193 3577047 : ALLOCATE (val%c_val(1))
194 3577047 : val%c_val(1) = c_val
195 3577047 : val%type_of_var = char_t
196 : END IF
197 1675779522 : IF (PRESENT(c_vals)) THEN
198 493570 : CPASSERT(ALL(LEN_TRIM(c_vals) <= default_string_length))
199 168092 : narg = narg + 1
200 504276 : ALLOCATE (val%c_val(SIZE(c_vals)))
201 493570 : val%c_val = c_vals
202 168092 : val%type_of_var = char_t
203 : END IF
204 1675779522 : IF (PRESENT(c_vals_ptr)) THEN
205 82908 : narg = narg + 1
206 82908 : val%c_val => c_vals_ptr
207 82908 : val%type_of_var = char_t
208 : END IF
209 1675779522 : IF (PRESENT(lc_val)) THEN
210 10439364 : narg = narg + 1
211 10439364 : len_c = LEN_TRIM(lc_val)
212 10439364 : nVal = MAX(1, CEILING(REAL(len_c, dp)/80._dp))
213 31318092 : ALLOCATE (val%c_val(nVal))
214 :
215 10439364 : IF (len_c == 0) THEN
216 3069565 : val%c_val(1) = ""
217 : ELSE
218 16420670 : DO i = 1, nVal
219 : val%c_val(i) = lc_val((i - 1)*default_string_length + 1: &
220 16420670 : MIN(len_c, i*default_string_length))
221 : END DO
222 : END IF
223 10439364 : val%type_of_var = lchar_t
224 : END IF
225 1675779522 : IF (PRESENT(lc_vals)) THEN
226 0 : CPASSERT(ALL(LEN_TRIM(lc_vals) <= default_string_length))
227 0 : narg = narg + 1
228 0 : ALLOCATE (val%c_val(SIZE(lc_vals)))
229 0 : val%c_val = lc_vals
230 0 : val%type_of_var = lchar_t
231 : END IF
232 1675779522 : IF (PRESENT(lc_vals_ptr)) THEN
233 270967 : narg = narg + 1
234 270967 : val%c_val => lc_vals_ptr
235 270967 : val%type_of_var = lchar_t
236 : END IF
237 1675779522 : CPASSERT(narg <= 1)
238 1675779522 : IF (PRESENT(enum)) THEN
239 1672723193 : IF (ASSOCIATED(enum)) THEN
240 58713519 : IF (val%type_of_var /= no_t .AND. val%type_of_var /= integer_t .AND. &
241 : val%type_of_var /= enum_t) THEN
242 0 : CPABORT("Type of variable is incompatible with enum")
243 : END IF
244 58713519 : IF (ASSOCIATED(val%i_val)) THEN
245 37320375 : val%type_of_var = enum_t
246 37320375 : val%enum => enum
247 37320375 : CALL enum_retain(enum)
248 : END IF
249 : END IF
250 : END IF
251 :
252 1675779522 : CPASSERT(ASSOCIATED(val%enum) .EQV. val%type_of_var == enum_t)
253 :
254 1675779522 : END SUBROUTINE val_create
255 :
256 : ! **************************************************************************************************
257 : !> \brief releases the given val
258 : !> \param val the val to release
259 : !> \author fawzi
260 : ! **************************************************************************************************
261 2415003614 : SUBROUTINE val_release(val)
262 :
263 : TYPE(val_type), POINTER :: val
264 :
265 2415003614 : IF (ASSOCIATED(val)) THEN
266 1675863068 : CPASSERT(val%ref_count > 0)
267 1675863068 : val%ref_count = val%ref_count - 1
268 1675863068 : IF (val%ref_count == 0) THEN
269 1675863068 : IF (ASSOCIATED(val%l_val)) THEN
270 215577242 : DEALLOCATE (val%l_val)
271 : END IF
272 1675863068 : IF (ASSOCIATED(val%i_val)) THEN
273 219110735 : DEALLOCATE (val%i_val)
274 : END IF
275 1675863068 : IF (ASSOCIATED(val%r_val)) THEN
276 487454769 : DEALLOCATE (val%r_val)
277 : END IF
278 1675863068 : IF (ASSOCIATED(val%c_val)) THEN
279 14579776 : DEALLOCATE (val%c_val)
280 : END IF
281 1675863068 : CALL enum_release(val%enum)
282 1675863068 : val%type_of_var = no_t
283 1675863068 : DEALLOCATE (val)
284 : END IF
285 : END IF
286 :
287 2415003614 : NULLIFY (val)
288 :
289 2415003614 : END SUBROUTINE val_release
290 :
291 : ! **************************************************************************************************
292 : !> \brief retains the given val
293 : !> \param val the val to retain
294 : !> \author fawzi
295 : ! **************************************************************************************************
296 0 : SUBROUTINE val_retain(val)
297 :
298 : TYPE(val_type), POINTER :: val
299 :
300 0 : CPASSERT(ASSOCIATED(val))
301 0 : CPASSERT(val%ref_count > 0)
302 0 : val%ref_count = val%ref_count + 1
303 :
304 0 : END SUBROUTINE val_retain
305 :
306 : ! **************************************************************************************************
307 : !> \brief returns the stored values
308 : !> \param val the object from which you want to extract the values
309 : !> \param has_l ...
310 : !> \param has_i ...
311 : !> \param has_r ...
312 : !> \param has_lc ...
313 : !> \param has_c ...
314 : !> \param l_val gets a logical from the val
315 : !> \param l_vals gets an array of logicals from the val
316 : !> \param i_val gets an integer from the val
317 : !> \param i_vals gets an array of integers from the val
318 : !> \param r_val gets a real from the val
319 : !> \param r_vals gets an array of reals from the val
320 : !> \param c_val gets a char from the val
321 : !> \param c_vals gets an array of chars from the val
322 : !> \param len_c len_trim of c_val (if it was a lc_val, of type lchar_t
323 : !> it might be longet than default_string_length)
324 : !> \param type_of_var ...
325 : !> \param enum ...
326 : !> \author fawzi
327 : !> \note
328 : !> using an enumeration only i_val/i_vals/i_vals_ptr are accepted
329 : !> add something like ignore_string_cut that if true does not warn if
330 : !> the c_val is too short to contain the string
331 : ! **************************************************************************************************
332 41035410 : SUBROUTINE val_get(val, has_l, has_i, has_r, has_lc, has_c, l_val, l_vals, i_val, &
333 : i_vals, r_val, r_vals, c_val, c_vals, len_c, type_of_var, enum)
334 :
335 : TYPE(val_type), POINTER :: val
336 : LOGICAL, INTENT(out), OPTIONAL :: has_l, has_i, has_r, has_lc, has_c, l_val
337 : LOGICAL, DIMENSION(:), OPTIONAL, POINTER :: l_vals
338 : INTEGER, INTENT(out), OPTIONAL :: i_val
339 : INTEGER, DIMENSION(:), OPTIONAL, POINTER :: i_vals
340 : REAL(KIND=DP), INTENT(out), OPTIONAL :: r_val
341 : REAL(KIND=DP), DIMENSION(:), OPTIONAL, POINTER :: r_vals
342 : CHARACTER(LEN=*), INTENT(out), OPTIONAL :: c_val
343 : CHARACTER(LEN=default_string_length), &
344 : DIMENSION(:), OPTIONAL, POINTER :: c_vals
345 : INTEGER, INTENT(out), OPTIONAL :: len_c, type_of_var
346 : TYPE(enumeration_type), OPTIONAL, POINTER :: enum
347 :
348 : INTEGER :: i, l_in, l_out
349 :
350 0 : IF (PRESENT(has_l)) has_l = ASSOCIATED(val%l_val)
351 41035410 : IF (PRESENT(has_i)) has_i = ASSOCIATED(val%i_val)
352 41035410 : IF (PRESENT(has_r)) has_r = ASSOCIATED(val%r_val)
353 41035410 : IF (PRESENT(has_c)) has_c = ASSOCIATED(val%c_val) ! use type_of_var?
354 41035410 : IF (PRESENT(has_lc)) has_lc = (val%type_of_var == lchar_t)
355 41035410 : IF (PRESENT(l_vals)) l_vals => val%l_val
356 41035410 : IF (PRESENT(l_val)) THEN
357 5919899 : IF (ASSOCIATED(val%l_val)) THEN
358 5919899 : IF (SIZE(val%l_val) > 0) THEN
359 5919899 : l_val = val%l_val(1)
360 : ELSE
361 0 : CPABORT("Invalid size of logical value(s)")
362 : END IF
363 : ELSE
364 0 : CPABORT("Logical value is unavailable")
365 : END IF
366 : END IF
367 :
368 41035410 : IF (PRESENT(i_vals)) i_vals => val%i_val
369 41035410 : IF (PRESENT(i_val)) THEN
370 28941800 : IF (ASSOCIATED(val%i_val)) THEN
371 28941800 : IF (SIZE(val%i_val) > 0) THEN
372 28941800 : i_val = val%i_val(1)
373 : ELSE
374 0 : CPABORT("Invalid size of integer value(s)")
375 : END IF
376 : ELSE
377 0 : CPABORT("Integer value is unavailable")
378 : END IF
379 : END IF
380 :
381 41035410 : IF (PRESENT(r_vals)) r_vals => val%r_val
382 41035410 : IF (PRESENT(r_val)) THEN
383 3399809 : IF (ASSOCIATED(val%r_val)) THEN
384 3399809 : IF (SIZE(val%r_val) > 0) THEN
385 3399809 : r_val = val%r_val(1)
386 : ELSE
387 0 : CPABORT("Invalid size of real value(s)")
388 : END IF
389 : ELSE
390 0 : CPABORT("Real value is unavailable")
391 : END IF
392 : END IF
393 :
394 41035410 : IF (PRESENT(c_vals)) c_vals => val%c_val
395 41035410 : IF (PRESENT(c_val)) THEN
396 2117262 : l_out = LEN(c_val)
397 2117262 : IF (ASSOCIATED(val%c_val)) THEN
398 2111228 : IF (SIZE(val%c_val) > 0) THEN
399 2111228 : IF (val%type_of_var == lchar_t) THEN
400 : l_in = default_string_length*(SIZE(val%c_val) - 1) + &
401 1389399 : LEN_TRIM(val%c_val(SIZE(val%c_val)))
402 1389399 : IF (l_out < l_in) THEN
403 : CALL cp_warn(__LOCATION__, &
404 : "val_get will truncate value, value beginning with '"// &
405 0 : TRIM(val%c_val(1))//"' is too long for variable")
406 : END IF
407 1879021 : DO i = 1, SIZE(val%c_val)
408 : c_val((i - 1)*default_string_length + 1:MIN(l_out, i*default_string_length)) = &
409 1421001 : val%c_val(i) (1:MIN(80, l_out - (i - 1)*default_string_length))
410 1879021 : IF (l_out <= i*default_string_length) EXIT
411 : END DO
412 1389399 : IF (l_out > SIZE(val%c_val)*default_string_length) THEN
413 458020 : c_val(SIZE(val%c_val)*default_string_length + 1:l_out) = ""
414 : END IF
415 : ELSE
416 721829 : l_in = LEN_TRIM(val%c_val(1))
417 721829 : IF (l_out < l_in) THEN
418 : CALL cp_warn(__LOCATION__, &
419 : "val_get will truncate value, value '"// &
420 0 : TRIM(val%c_val(1))//"' is too long for variable")
421 : END IF
422 721829 : c_val = val%c_val(1)
423 : END IF
424 : ELSE
425 0 : CPABORT("Invalid size of character value(s)")
426 : END IF
427 6034 : ELSE IF (ASSOCIATED(val%i_val) .AND. ASSOCIATED(val%enum)) THEN
428 6034 : IF (SIZE(val%i_val) > 0) THEN
429 6034 : c_val = enum_i2c(val%enum, val%i_val(1))
430 : ELSE
431 0 : CPABORT("Invalid size of character value(s)")
432 : END IF
433 : ELSE
434 0 : CPABORT("Character value is unavailable")
435 : END IF
436 : END IF
437 :
438 41035410 : IF (PRESENT(len_c)) THEN
439 0 : IF (ASSOCIATED(val%c_val)) THEN
440 0 : IF (SIZE(val%c_val) > 0) THEN
441 0 : IF (val%type_of_var == lchar_t) THEN
442 : len_c = default_string_length*(SIZE(val%c_val) - 1) + &
443 0 : LEN_TRIM(val%c_val(SIZE(val%c_val)))
444 : ELSE
445 0 : len_c = LEN_TRIM(val%c_val(1))
446 : END IF
447 : ELSE
448 0 : len_c = -HUGE(0)
449 : END IF
450 0 : ELSE IF (ASSOCIATED(val%i_val) .AND. ASSOCIATED(val%enum)) THEN
451 0 : IF (SIZE(val%i_val) > 0) THEN
452 0 : len_c = LEN_TRIM(enum_i2c(val%enum, val%i_val(1)))
453 : ELSE
454 0 : len_c = -HUGE(0)
455 : END IF
456 : ELSE
457 0 : len_c = -HUGE(0)
458 : END IF
459 : END IF
460 :
461 41035410 : IF (PRESENT(type_of_var)) type_of_var = val%type_of_var
462 :
463 41035410 : IF (PRESENT(enum)) enum => val%enum
464 :
465 41035410 : END SUBROUTINE val_get
466 :
467 : ! **************************************************************************************************
468 : !> \brief writes out the values stored in the val
469 : !> \param val the val to write
470 : !> \param unit_nr the number of the unit to write to
471 : !> \param unit the unit of mesure in which the output should be written
472 : !> (overrides unit_str)
473 : !> \param unit_str the unit of mesure in which the output should be written
474 : !> \param fmt ...
475 : !> \author fawzi
476 : !> \note
477 : !> unit of mesure used only for reals
478 : ! **************************************************************************************************
479 1839727 : SUBROUTINE val_write(val, unit_nr, unit, unit_str, fmt)
480 :
481 : TYPE(val_type), POINTER :: val
482 : INTEGER, INTENT(in) :: unit_nr
483 : TYPE(cp_unit_type), OPTIONAL, POINTER :: unit
484 : CHARACTER(len=*), INTENT(in), OPTIONAL :: unit_str, fmt
485 :
486 : CHARACTER(len=default_string_length) :: c_string, myfmt, rcval
487 : INTEGER :: i, iend, item, j, l
488 : LOGICAL :: owns_unit
489 : TYPE(cp_unit_type), POINTER :: my_unit
490 :
491 1839727 : NULLIFY (my_unit)
492 1839727 : myfmt = ""
493 1839727 : owns_unit = .FALSE.
494 :
495 1839707 : IF (PRESENT(fmt)) myfmt = fmt
496 1839727 : IF (PRESENT(unit)) my_unit => unit
497 1839727 : IF (.NOT. ASSOCIATED(my_unit) .AND. PRESENT(unit_str)) THEN
498 0 : ALLOCATE (my_unit)
499 0 : CALL cp_unit_create(my_unit, unit_str)
500 0 : owns_unit = .TRUE.
501 : END IF
502 :
503 1839727 : IF (ASSOCIATED(val)) THEN
504 1888372 : SELECT CASE (val%type_of_var)
505 : CASE (logical_t)
506 48645 : IF (ASSOCIATED(val%l_val)) THEN
507 97290 : DO i = 1, SIZE(val%l_val)
508 48645 : IF (MODULO(i, 20) == 0) THEN
509 0 : WRITE (UNIT=unit_nr, FMT="(1X,A1)") default_continuation_character
510 0 : WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//")", ADVANCE="NO")
511 : END IF
512 : WRITE (UNIT=unit_nr, FMT="(1X,L1)", ADVANCE="NO") &
513 97290 : val%l_val(i)
514 : END DO
515 : ELSE
516 0 : CPABORT("Input value of type <logical_t> not associated")
517 : END IF
518 : CASE (integer_t)
519 102615 : IF (ASSOCIATED(val%i_val)) THEN
520 : item = 0
521 : i = 1
522 244421 : loop_i: DO WHILE (i <= SIZE(val%i_val))
523 141806 : item = item + 1
524 141806 : IF (MODULO(item, 10) == 0) THEN
525 23 : WRITE (UNIT=unit_nr, FMT="(1X,A)") default_continuation_character
526 23 : WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//")", ADVANCE="NO")
527 : END IF
528 141806 : iend = i
529 195349 : loop_j: DO j = i + 1, SIZE(val%i_val)
530 195349 : IF (val%i_val(j - 1) + 1 == val%i_val(j)) THEN
531 53543 : iend = iend + 1
532 : ELSE
533 : EXIT loop_j
534 : END IF
535 : END DO loop_j
536 141806 : IF ((iend - i) > 1) THEN
537 : WRITE (UNIT=unit_nr, FMT="(1X,I0,A2,I0)", ADVANCE="NO") &
538 4602 : val%i_val(i), "..", val%i_val(iend)
539 4602 : i = iend
540 : ELSE
541 : WRITE (UNIT=unit_nr, FMT="(1X,I0)", ADVANCE="NO") &
542 137204 : val%i_val(i)
543 : END IF
544 244421 : i = i + 1
545 : END DO loop_i
546 : ELSE
547 0 : CPABORT("Input value of type <integer_t> not associated")
548 : END IF
549 : CASE (real_t)
550 673665 : IF (ASSOCIATED(val%r_val)) THEN
551 4059017 : DO i = 1, SIZE(val%r_val)
552 3385352 : IF (MODULO(i, 5) == 0) THEN
553 365007 : WRITE (UNIT=unit_nr, FMT="(1X,A)") default_continuation_character
554 365007 : WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//")", ADVANCE="NO")
555 : END IF
556 3385352 : IF (ASSOCIATED(my_unit)) THEN
557 : WRITE (UNIT=rcval, FMT="(ES25.16E3)") &
558 198922 : cp_unit_from_cp2k1(val%r_val(i), my_unit)
559 : ELSE
560 3186430 : WRITE (UNIT=rcval, FMT="(ES25.16E3)") val%r_val(i)
561 : END IF
562 4059017 : WRITE (UNIT=unit_nr, FMT="(A)", ADVANCE="NO") TRIM(rcval)
563 : END DO
564 : ELSE
565 0 : CPABORT("Input value of type <real_t> not associated")
566 : END IF
567 : CASE (char_t)
568 42465 : IF (ASSOCIATED(val%c_val)) THEN
569 42465 : l = 0
570 101897 : DO i = 1, SIZE(val%c_val)
571 59432 : l = l + 1
572 101897 : IF (l > 10 .AND. l + LEN_TRIM(val%c_val(i)) > 76) THEN
573 0 : WRITE (UNIT=unit_nr, FMT="(A1)") default_continuation_character
574 0 : WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//")", ADVANCE="NO")
575 0 : l = 0
576 0 : WRITE (UNIT=unit_nr, FMT="(1X,A)", ADVANCE="NO") """"//TRIM(val%c_val(i))//""""
577 0 : l = l + LEN_TRIM(val%c_val(i)) + 3
578 59432 : ELSE IF (LEN_TRIM(val%c_val(i)) > 0) THEN
579 59374 : l = l + LEN_TRIM(val%c_val(i))
580 59374 : WRITE (UNIT=unit_nr, FMT="(1X,A)", ADVANCE="NO") """"//TRIM(val%c_val(i))//""""
581 : ELSE
582 58 : l = l + 3
583 58 : WRITE (UNIT=unit_nr, FMT="(1X,A)", ADVANCE="NO") '""'
584 : END IF
585 : END DO
586 : ELSE
587 0 : CPABORT("Input value of type <char_t> not associated")
588 : END IF
589 : CASE (lchar_t)
590 855299 : IF (ASSOCIATED(val%c_val)) THEN
591 922600 : SELECT CASE (SIZE(val%c_val))
592 : CASE (1)
593 67301 : WRITE (UNIT=unit_nr, FMT='(1X,A)', ADVANCE="NO") TRIM(val%c_val(1))
594 : CASE (2)
595 774878 : WRITE (UNIT=unit_nr, FMT='(1X,A)', ADVANCE="NO") val%c_val(1)
596 774878 : WRITE (UNIT=unit_nr, FMT='(A)', ADVANCE="NO") TRIM(val%c_val(2))
597 : CASE (3:)
598 13120 : WRITE (UNIT=unit_nr, FMT='(1X,A)', ADVANCE="NO") val%c_val(1)
599 65561 : DO i = 2, SIZE(val%c_val) - 1
600 65561 : WRITE (UNIT=unit_nr, FMT="(A)", ADVANCE="NO") val%c_val(i)
601 : END DO
602 868419 : WRITE (UNIT=unit_nr, FMT='(A)', ADVANCE="NO") TRIM(val%c_val(SIZE(val%c_val)))
603 : END SELECT
604 : ELSE
605 0 : CPABORT("Input value of type <lchar_t> not associated")
606 : END IF
607 : CASE (enum_t)
608 117038 : IF (ASSOCIATED(val%i_val)) THEN
609 117038 : l = 0
610 234076 : DO i = 1, SIZE(val%i_val)
611 117038 : c_string = enum_i2c(val%enum, val%i_val(i))
612 117038 : IF (l > 10 .AND. l + LEN_TRIM(c_string) > 76) THEN
613 0 : WRITE (UNIT=unit_nr, FMT="(1X,A)") default_continuation_character
614 0 : WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//")", ADVANCE="NO")
615 0 : l = 0
616 : ELSE
617 117038 : l = l + LEN_TRIM(c_string) + 3
618 : END IF
619 234076 : WRITE (UNIT=unit_nr, FMT="(1X,A)", ADVANCE="NO") TRIM(c_string)
620 : END DO
621 : ELSE
622 0 : CPABORT("Input value of type <enum_t> not associated")
623 : END IF
624 : CASE (no_t)
625 0 : WRITE (UNIT=unit_nr, FMT="(' *empty*')", ADVANCE="NO")
626 : CASE default
627 1839727 : CPABORT("Unexpected type_of_var for val")
628 : END SELECT
629 : ELSE
630 0 : WRITE (UNIT=unit_nr, FMT="(1X,A)", ADVANCE="NO") "NULL()"
631 : END IF
632 :
633 1839727 : IF (owns_unit) THEN
634 0 : CALL cp_unit_release(my_unit)
635 0 : DEALLOCATE (my_unit)
636 : END IF
637 :
638 1839727 : WRITE (UNIT=unit_nr, FMT="()")
639 :
640 1839727 : END SUBROUTINE val_write
641 :
642 : ! **************************************************************************************************
643 : !> \brief Write values to an internal file, i.e. string variable.
644 : !> \param val ...
645 : !> \param string ...
646 : !> \param unit ...
647 : !> \date 10.03.2005
648 : !> \par History
649 : !> 17.01.2006, MK, Optional argument unit for the conversion to the external unit added
650 : !> \author MK
651 : !> \version 1.0
652 : ! **************************************************************************************************
653 0 : SUBROUTINE val_write_internal(val, string, unit)
654 :
655 : TYPE(val_type), POINTER :: val
656 : CHARACTER(LEN=*), INTENT(OUT) :: string
657 : TYPE(cp_unit_type), OPTIONAL, POINTER :: unit
658 :
659 : CHARACTER(LEN=default_string_length) :: enum_string
660 : INTEGER :: i, ipos
661 : REAL(KIND=dp) :: value
662 :
663 0 : string = ""
664 :
665 0 : IF (ASSOCIATED(val)) THEN
666 :
667 0 : SELECT CASE (val%type_of_var)
668 : CASE (logical_t)
669 0 : IF (ASSOCIATED(val%l_val)) THEN
670 0 : DO i = 1, SIZE(val%l_val)
671 0 : WRITE (UNIT=string(2*i - 1:), FMT="(1X,L1)") val%l_val(i)
672 : END DO
673 : ELSE
674 0 : CPABORT("Logical value is unavailable")
675 : END IF
676 : CASE (integer_t)
677 0 : IF (ASSOCIATED(val%i_val)) THEN
678 0 : DO i = 1, SIZE(val%i_val)
679 0 : WRITE (UNIT=string(12*i - 11:), FMT="(I12)") val%i_val(i)
680 : END DO
681 : ELSE
682 0 : CPABORT("Integer value is unavailable")
683 : END IF
684 : CASE (real_t)
685 0 : IF (ASSOCIATED(val%r_val)) THEN
686 0 : IF (PRESENT(unit)) THEN
687 0 : DO i = 1, SIZE(val%r_val)
688 : value = cp_unit_from_cp2k(value=val%r_val(i), &
689 0 : unit_str=cp_unit_desc(unit=unit))
690 0 : WRITE (UNIT=string(17*i - 16:), FMT="(ES17.8E3)") value
691 : END DO
692 : ELSE
693 0 : DO i = 1, SIZE(val%r_val)
694 0 : WRITE (UNIT=string(17*i - 16:), FMT="(ES17.8E3)") val%r_val(i)
695 : END DO
696 : END IF
697 : ELSE
698 0 : CPABORT("Real value is unavailable")
699 : END IF
700 : CASE (char_t)
701 0 : IF (ASSOCIATED(val%c_val)) THEN
702 0 : ipos = 1
703 0 : DO i = 1, SIZE(val%c_val)
704 0 : WRITE (UNIT=string(ipos:), FMT="(A)") TRIM(ADJUSTL(val%c_val(i)))
705 0 : ipos = ipos + LEN_TRIM(ADJUSTL(val%c_val(i))) + 1
706 : END DO
707 : ELSE
708 0 : CPABORT("Character value is unavailable")
709 : END IF
710 : CASE (lchar_t)
711 0 : IF (ASSOCIATED(val%c_val)) THEN
712 0 : CALL val_get(val, c_val=string)
713 : ELSE
714 0 : CPABORT("Character value is unavailable")
715 : END IF
716 : CASE (enum_t)
717 0 : IF (ASSOCIATED(val%i_val)) THEN
718 0 : DO i = 1, SIZE(val%i_val)
719 0 : enum_string = enum_i2c(val%enum, val%i_val(i))
720 0 : WRITE (UNIT=string, FMT="(A)") TRIM(ADJUSTL(enum_string))
721 : END DO
722 : ELSE
723 0 : CPABORT("Enumeration value is unavailable")
724 : END IF
725 : CASE default
726 0 : CPABORT("unexpected type_of_var for val ")
727 : END SELECT
728 :
729 : END IF
730 :
731 0 : END SUBROUTINE val_write_internal
732 :
733 : ! **************************************************************************************************
734 : !> \brief creates a copy of the given value
735 : !> \param val_in the value to copy
736 : !> \param val_out the value tha will be created
737 : !> \author fawzi
738 : ! **************************************************************************************************
739 83546 : SUBROUTINE val_duplicate(val_in, val_out)
740 :
741 : TYPE(val_type), POINTER :: val_in, val_out
742 :
743 83546 : CPASSERT(ASSOCIATED(val_in))
744 83546 : CPASSERT(.NOT. ASSOCIATED(val_out))
745 83546 : ALLOCATE (val_out)
746 83546 : val_out%type_of_var = val_in%type_of_var
747 83546 : val_out%ref_count = 1
748 83546 : val_out%enum => val_in%enum
749 83546 : IF (ASSOCIATED(val_out%enum)) CALL enum_retain(val_out%enum)
750 :
751 83546 : NULLIFY (val_out%l_val, val_out%i_val, val_out%c_val, val_out%r_val)
752 83546 : IF (ASSOCIATED(val_in%l_val)) THEN
753 14238 : ALLOCATE (val_out%l_val(SIZE(val_in%l_val)))
754 18984 : val_out%l_val = val_in%l_val
755 : END IF
756 83546 : IF (ASSOCIATED(val_in%i_val)) THEN
757 44568 : ALLOCATE (val_out%i_val(SIZE(val_in%i_val)))
758 68612 : val_out%i_val = val_in%i_val
759 : END IF
760 83546 : IF (ASSOCIATED(val_in%r_val)) THEN
761 67638 : ALLOCATE (val_out%r_val(SIZE(val_in%r_val)))
762 120800 : val_out%r_val = val_in%r_val
763 : END IF
764 83546 : IF (ASSOCIATED(val_in%c_val)) THEN
765 124194 : ALLOCATE (val_out%c_val(SIZE(val_in%c_val)))
766 167756 : val_out%c_val = val_in%c_val
767 : END IF
768 :
769 83546 : END SUBROUTINE val_duplicate
770 :
771 0 : END MODULE input_val_types
|
