Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2023 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 1013514830 : SUBROUTINE val_create(val, l_val, l_vals, l_vals_ptr, i_val, i_vals, i_vals_ptr, &
101 2026998698 : 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 1013499349 : CPASSERT(.NOT. ASSOCIATED(val))
129 1013499349 : ALLOCATE (val)
130 : NULLIFY (val%l_val, val%i_val, val%r_val, val%c_val, val%enum)
131 : val%type_of_var = no_t
132 1013499349 : val%ref_count = 1
133 :
134 1013499349 : narg = 0
135 : val%type_of_var = no_t
136 1013499349 : IF (PRESENT(l_val)) THEN
137 127064844 : narg = narg + 1
138 127064844 : ALLOCATE (val%l_val(1))
139 127064844 : val%l_val(1) = l_val
140 127064844 : val%type_of_var = logical_t
141 : END IF
142 1013499349 : IF (PRESENT(l_vals)) THEN
143 15481 : narg = narg + 1
144 46443 : ALLOCATE (val%l_val(SIZE(l_vals)))
145 30962 : val%l_val = l_vals
146 15481 : val%type_of_var = logical_t
147 : END IF
148 1013499349 : IF (PRESENT(l_vals_ptr)) THEN
149 16988 : narg = narg + 1
150 16988 : val%l_val => l_vals_ptr
151 16988 : val%type_of_var = logical_t
152 : END IF
153 :
154 1013499349 : IF (PRESENT(r_val)) THEN
155 281400444 : narg = narg + 1
156 281400444 : ALLOCATE (val%r_val(1))
157 281400444 : val%r_val(1) = r_val
158 281400444 : val%type_of_var = real_t
159 : END IF
160 1013499349 : IF (PRESENT(r_vals)) THEN
161 1147418 : narg = narg + 1
162 3442254 : ALLOCATE (val%r_val(SIZE(r_vals)))
163 4399260 : val%r_val = r_vals
164 1147418 : val%type_of_var = real_t
165 : END IF
166 1013499349 : IF (PRESENT(r_vals_ptr)) THEN
167 969673 : narg = narg + 1
168 969673 : val%r_val => r_vals_ptr
169 969673 : val%type_of_var = real_t
170 : END IF
171 :
172 1013499349 : IF (PRESENT(i_val)) THEN
173 141098494 : narg = narg + 1
174 141098494 : ALLOCATE (val%i_val(1))
175 141098494 : val%i_val(1) = i_val
176 141098494 : val%type_of_var = integer_t
177 : END IF
178 1013499349 : IF (PRESENT(i_vals)) THEN
179 1537661 : narg = narg + 1
180 4612983 : ALLOCATE (val%i_val(SIZE(i_vals)))
181 5487146 : val%i_val = i_vals
182 1537661 : val%type_of_var = integer_t
183 : END IF
184 1013499349 : IF (PRESENT(i_vals_ptr)) THEN
185 165446 : narg = narg + 1
186 165446 : val%i_val => i_vals_ptr
187 165446 : val%type_of_var = integer_t
188 : END IF
189 :
190 1013499349 : IF (PRESENT(c_val)) THEN
191 1648238 : CPASSERT(LEN_TRIM(c_val) <= default_string_length)
192 1648238 : narg = narg + 1
193 1648238 : ALLOCATE (val%c_val(1))
194 1648238 : val%c_val(1) = c_val
195 1648238 : val%type_of_var = char_t
196 : END IF
197 1013499349 : IF (PRESENT(c_vals)) THEN
198 339552 : CPASSERT(ALL(LEN_TRIM(c_vals) <= default_string_length))
199 116012 : narg = narg + 1
200 348036 : ALLOCATE (val%c_val(SIZE(c_vals)))
201 339552 : val%c_val = c_vals
202 116012 : val%type_of_var = char_t
203 : END IF
204 1013499349 : IF (PRESENT(c_vals_ptr)) THEN
205 72080 : narg = narg + 1
206 72080 : val%c_val => c_vals_ptr
207 72080 : val%type_of_var = char_t
208 : END IF
209 1013499349 : IF (PRESENT(lc_val)) THEN
210 7722768 : narg = narg + 1
211 7722768 : len_c = LEN_TRIM(lc_val)
212 7722768 : nVal = MAX(1, CEILING(REAL(len_c, dp)/80._dp))
213 23168304 : ALLOCATE (val%c_val(nVal))
214 :
215 7722768 : IF (len_c == 0) THEN
216 2301683 : val%c_val(1) = ""
217 : ELSE
218 12540200 : DO i = 1, nVal
219 : val%c_val(i) = lc_val((i - 1)*default_string_length + 1: &
220 12540200 : MIN(len_c, i*default_string_length))
221 : END DO
222 : END IF
223 7722768 : val%type_of_var = lchar_t
224 : END IF
225 1013499349 : 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 1013499349 : IF (PRESENT(lc_vals_ptr)) THEN
233 261121 : narg = narg + 1
234 261121 : val%c_val => lc_vals_ptr
235 261121 : val%type_of_var = lchar_t
236 : END IF
237 1013499349 : CPASSERT(narg <= 1)
238 1013499349 : IF (PRESENT(enum)) THEN
239 1010517185 : IF (ASSOCIATED(enum)) THEN
240 37843111 : 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("")
243 : END IF
244 37843111 : IF (ASSOCIATED(val%i_val)) THEN
245 24325324 : val%type_of_var = enum_t
246 24325324 : val%enum => enum
247 24325324 : CALL enum_retain(enum)
248 : END IF
249 : END IF
250 : END IF
251 :
252 1013499349 : CPASSERT(ASSOCIATED(val%enum) .EQV. val%type_of_var == enum_t)
253 :
254 1013499349 : END SUBROUTINE val_create
255 :
256 : ! **************************************************************************************************
257 : !> \brief releases the given val
258 : !> \param val the val to release
259 : !> \author fawzi
260 : ! **************************************************************************************************
261 1463843807 : SUBROUTINE val_release(val)
262 :
263 : TYPE(val_type), POINTER :: val
264 :
265 1463843807 : IF (ASSOCIATED(val)) THEN
266 1013581126 : CPASSERT(val%ref_count > 0)
267 1013581126 : val%ref_count = val%ref_count - 1
268 1013581126 : IF (val%ref_count == 0) THEN
269 1013581126 : IF (ASSOCIATED(val%l_val)) THEN
270 127102074 : DEALLOCATE (val%l_val)
271 : END IF
272 1013581126 : IF (ASSOCIATED(val%i_val)) THEN
273 142816247 : DEALLOCATE (val%i_val)
274 : END IF
275 1013581126 : IF (ASSOCIATED(val%r_val)) THEN
276 283538661 : DEALLOCATE (val%r_val)
277 : END IF
278 1013581126 : IF (ASSOCIATED(val%c_val)) THEN
279 9861463 : DEALLOCATE (val%c_val)
280 : END IF
281 1013581126 : CALL enum_release(val%enum)
282 1013581126 : val%type_of_var = no_t
283 1013581126 : DEALLOCATE (val)
284 : END IF
285 : END IF
286 :
287 1463843807 : NULLIFY (val)
288 :
289 1463843807 : 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 37653235 : 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 37653235 : IF (PRESENT(has_i)) has_i = ASSOCIATED(val%i_val)
352 37653235 : IF (PRESENT(has_r)) has_r = ASSOCIATED(val%r_val)
353 37653235 : IF (PRESENT(has_c)) has_c = ASSOCIATED(val%c_val) ! use type_of_var?
354 37653235 : IF (PRESENT(has_lc)) has_lc = (val%type_of_var == lchar_t)
355 37653235 : IF (PRESENT(l_vals)) l_vals => val%l_val
356 37653235 : IF (PRESENT(l_val)) THEN
357 3830388 : IF (ASSOCIATED(val%l_val)) THEN
358 3830388 : IF (SIZE(val%l_val) > 0) THEN
359 3830388 : l_val = val%l_val(1)
360 : ELSE
361 0 : CPABORT("")
362 : END IF
363 : ELSE
364 0 : CPABORT("")
365 : END IF
366 : END IF
367 :
368 37653235 : IF (PRESENT(i_vals)) i_vals => val%i_val
369 37653235 : IF (PRESENT(i_val)) THEN
370 24200365 : IF (ASSOCIATED(val%i_val)) THEN
371 24200365 : IF (SIZE(val%i_val) > 0) THEN
372 24200365 : i_val = val%i_val(1)
373 : ELSE
374 0 : CPABORT("")
375 : END IF
376 : ELSE
377 0 : CPABORT("")
378 : END IF
379 : END IF
380 :
381 37653235 : IF (PRESENT(r_vals)) r_vals => val%r_val
382 37653235 : IF (PRESENT(r_val)) THEN
383 4157247 : IF (ASSOCIATED(val%r_val)) THEN
384 4157247 : IF (SIZE(val%r_val) > 0) THEN
385 4157247 : r_val = val%r_val(1)
386 : ELSE
387 0 : CPABORT("")
388 : END IF
389 : ELSE
390 0 : CPABORT("")
391 : END IF
392 : END IF
393 :
394 37653235 : IF (PRESENT(c_vals)) c_vals => val%c_val
395 37653235 : IF (PRESENT(c_val)) THEN
396 2911575 : l_out = LEN(c_val)
397 2911575 : IF (ASSOCIATED(val%c_val)) THEN
398 2908563 : IF (SIZE(val%c_val) > 0) THEN
399 2908563 : IF (val%type_of_var == lchar_t) THEN
400 : l_in = default_string_length*(SIZE(val%c_val) - 1) + &
401 2318662 : LEN_TRIM(val%c_val(SIZE(val%c_val)))
402 2318662 : IF (l_out < l_in) &
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 3779055 : DO i = 1, SIZE(val%c_val)
407 : c_val((i - 1)*default_string_length + 1:MIN(l_out, i*default_string_length)) = &
408 2350151 : val%c_val(i) (1:MIN(80, l_out - (i - 1)*default_string_length))
409 3779055 : IF (l_out <= i*default_string_length) EXIT
410 : END DO
411 2318662 : IF (l_out > SIZE(val%c_val)*default_string_length) &
412 1428904 : c_val(SIZE(val%c_val)*default_string_length + 1:l_out) = ""
413 : ELSE
414 589901 : l_in = LEN_TRIM(val%c_val(1))
415 589901 : IF (l_out < l_in) &
416 : CALL cp_warn(__LOCATION__, &
417 : "val_get will truncate value, value '"// &
418 0 : TRIM(val%c_val(1))//"' is too long for variable")
419 589901 : c_val = val%c_val(1)
420 : END IF
421 : ELSE
422 0 : CPABORT("")
423 : END IF
424 3012 : ELSE IF (ASSOCIATED(val%i_val) .AND. ASSOCIATED(val%enum)) THEN
425 3012 : IF (SIZE(val%i_val) > 0) THEN
426 3012 : c_val = enum_i2c(val%enum, val%i_val(1))
427 : ELSE
428 0 : CPABORT("")
429 : END IF
430 : ELSE
431 0 : CPABORT("")
432 : END IF
433 : END IF
434 :
435 37653235 : IF (PRESENT(len_c)) THEN
436 0 : IF (ASSOCIATED(val%c_val)) THEN
437 0 : IF (SIZE(val%c_val) > 0) THEN
438 0 : IF (val%type_of_var == lchar_t) THEN
439 : len_c = default_string_length*(SIZE(val%c_val) - 1) + &
440 0 : LEN_TRIM(val%c_val(SIZE(val%c_val)))
441 : ELSE
442 0 : len_c = LEN_TRIM(val%c_val(1))
443 : END IF
444 : ELSE
445 0 : len_c = -HUGE(0)
446 : END IF
447 0 : ELSE IF (ASSOCIATED(val%i_val) .AND. ASSOCIATED(val%enum)) THEN
448 0 : IF (SIZE(val%i_val) > 0) THEN
449 0 : len_c = LEN_TRIM(enum_i2c(val%enum, val%i_val(1)))
450 : ELSE
451 0 : len_c = -HUGE(0)
452 : END IF
453 : ELSE
454 0 : len_c = -HUGE(0)
455 : END IF
456 : END IF
457 :
458 37653235 : IF (PRESENT(type_of_var)) type_of_var = val%type_of_var
459 :
460 37653235 : IF (PRESENT(enum)) enum => val%enum
461 :
462 37653235 : END SUBROUTINE val_get
463 :
464 : ! **************************************************************************************************
465 : !> \brief writes out the values stored in the val
466 : !> \param val the val to write
467 : !> \param unit_nr the number of the unit to write to
468 : !> \param unit the unit of mesure in which the output should be written
469 : !> (overrides unit_str)
470 : !> \param unit_str the unit of mesure in which the output should be written
471 : !> \param fmt ...
472 : !> \author fawzi
473 : !> \note
474 : !> unit of mesure used only for reals
475 : ! **************************************************************************************************
476 1850031 : SUBROUTINE val_write(val, unit_nr, unit, unit_str, fmt)
477 :
478 : TYPE(val_type), POINTER :: val
479 : INTEGER, INTENT(in) :: unit_nr
480 : TYPE(cp_unit_type), OPTIONAL, POINTER :: unit
481 : CHARACTER(len=*), INTENT(in), OPTIONAL :: unit_str, fmt
482 :
483 : CHARACTER(len=default_string_length) :: c_string, myfmt, rcval
484 : INTEGER :: i, iend, item, j, l
485 : LOGICAL :: owns_unit
486 : TYPE(cp_unit_type), POINTER :: my_unit
487 :
488 1850031 : NULLIFY (my_unit)
489 1850031 : myfmt = ""
490 1850031 : owns_unit = .FALSE.
491 :
492 1850011 : IF (PRESENT(fmt)) myfmt = fmt
493 1850031 : IF (PRESENT(unit)) my_unit => unit
494 1850031 : IF (.NOT. ASSOCIATED(my_unit) .AND. PRESENT(unit_str)) THEN
495 0 : ALLOCATE (my_unit)
496 0 : CALL cp_unit_create(my_unit, unit_str)
497 0 : owns_unit = .TRUE.
498 : END IF
499 :
500 1850031 : IF (ASSOCIATED(val)) THEN
501 1898941 : SELECT CASE (val%type_of_var)
502 : CASE (logical_t)
503 48910 : IF (ASSOCIATED(val%l_val)) THEN
504 97820 : DO i = 1, SIZE(val%l_val)
505 48910 : IF (MODULO(i, 20) == 0) THEN
506 0 : WRITE (UNIT=unit_nr, FMT="(1X,A1)") default_continuation_character
507 0 : WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//")", ADVANCE="NO")
508 : END IF
509 : WRITE (UNIT=unit_nr, FMT="(1X,L1)", ADVANCE="NO") &
510 97820 : val%l_val(i)
511 : END DO
512 : ELSE
513 0 : CPABORT("Input value of type <logical_t> not associated")
514 : END IF
515 : CASE (integer_t)
516 104437 : IF (ASSOCIATED(val%i_val)) THEN
517 : item = 0
518 : i = 1
519 249286 : loop_i: DO WHILE (i <= SIZE(val%i_val))
520 144849 : item = item + 1
521 144849 : IF (MODULO(item, 10) == 0) THEN
522 23 : WRITE (UNIT=unit_nr, FMT="(1X,A)") default_continuation_character
523 23 : WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//")", ADVANCE="NO")
524 : END IF
525 144849 : iend = i
526 198276 : loop_j: DO j = i + 1, SIZE(val%i_val)
527 198276 : IF (val%i_val(j - 1) + 1 == val%i_val(j)) THEN
528 53427 : iend = iend + 1
529 : ELSE
530 : EXIT loop_j
531 : END IF
532 : END DO loop_j
533 144849 : IF ((iend - i) > 1) THEN
534 : WRITE (UNIT=unit_nr, FMT="(1X,I0,A2,I0)", ADVANCE="NO") &
535 4593 : val%i_val(i), "..", val%i_val(iend)
536 4593 : i = iend
537 : ELSE
538 : WRITE (UNIT=unit_nr, FMT="(1X,I0)", ADVANCE="NO") &
539 140256 : val%i_val(i)
540 : END IF
541 249286 : i = i + 1
542 : END DO loop_i
543 : ELSE
544 0 : CPABORT("Input value of type <integer_t> not associated")
545 : END IF
546 : CASE (real_t)
547 661979 : IF (ASSOCIATED(val%r_val)) THEN
548 3974937 : DO i = 1, SIZE(val%r_val)
549 3312958 : IF (MODULO(i, 5) == 0) THEN
550 359434 : WRITE (UNIT=unit_nr, FMT="(1X,A)") default_continuation_character
551 359434 : WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//")", ADVANCE="NO")
552 : END IF
553 3312958 : IF (ASSOCIATED(my_unit)) THEN
554 : WRITE (UNIT=rcval, FMT="(ES25.16E3)") &
555 202611 : cp_unit_from_cp2k1(val%r_val(i), my_unit)
556 : ELSE
557 3110347 : WRITE (UNIT=rcval, FMT="(ES25.16E3)") val%r_val(i)
558 : END IF
559 3974937 : WRITE (UNIT=unit_nr, FMT="(A)", ADVANCE="NO") TRIM(rcval)
560 : END DO
561 : ELSE
562 0 : CPABORT("Input value of type <real_t> not associated")
563 : END IF
564 : CASE (char_t)
565 42096 : IF (ASSOCIATED(val%c_val)) THEN
566 42096 : l = 0
567 101100 : DO i = 1, SIZE(val%c_val)
568 59004 : l = l + 1
569 101100 : IF (l > 10 .AND. l + LEN_TRIM(val%c_val(i)) > 76) THEN
570 0 : WRITE (UNIT=unit_nr, FMT="(A1)") default_continuation_character
571 0 : WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//")", ADVANCE="NO")
572 0 : l = 0
573 0 : WRITE (UNIT=unit_nr, FMT="(1X,A)", ADVANCE="NO") """"//TRIM(val%c_val(i))//""""
574 0 : l = l + LEN_TRIM(val%c_val(i)) + 3
575 59004 : ELSE IF (LEN_TRIM(val%c_val(i)) > 0) THEN
576 58891 : l = l + LEN_TRIM(val%c_val(i))
577 58891 : WRITE (UNIT=unit_nr, FMT="(1X,A)", ADVANCE="NO") """"//TRIM(val%c_val(i))//""""
578 : ELSE
579 113 : l = l + 3
580 113 : WRITE (UNIT=unit_nr, FMT="(1X,A)", ADVANCE="NO") '""'
581 : END IF
582 : END DO
583 : ELSE
584 0 : CPABORT("Input value of type <char_t> not associated")
585 : END IF
586 : CASE (lchar_t)
587 868025 : IF (ASSOCIATED(val%c_val)) THEN
588 938122 : SELECT CASE (SIZE(val%c_val))
589 : CASE (1)
590 70097 : WRITE (UNIT=unit_nr, FMT='(1X,A)', ADVANCE="NO") TRIM(val%c_val(1))
591 : CASE (2)
592 785060 : WRITE (UNIT=unit_nr, FMT='(1X,A)', ADVANCE="NO") val%c_val(1)
593 785060 : WRITE (UNIT=unit_nr, FMT='(A)', ADVANCE="NO") TRIM(val%c_val(2))
594 : CASE (3:)
595 12868 : WRITE (UNIT=unit_nr, FMT='(1X,A)', ADVANCE="NO") val%c_val(1)
596 64301 : DO i = 2, SIZE(val%c_val) - 1
597 64301 : WRITE (UNIT=unit_nr, FMT="(A)", ADVANCE="NO") val%c_val(i)
598 : END DO
599 880893 : WRITE (UNIT=unit_nr, FMT='(A)', ADVANCE="NO") TRIM(val%c_val(SIZE(val%c_val)))
600 : END SELECT
601 : ELSE
602 0 : CPABORT("Input value of type <lchar_t> not associated")
603 : END IF
604 : CASE (enum_t)
605 124584 : IF (ASSOCIATED(val%i_val)) THEN
606 124584 : l = 0
607 249168 : DO i = 1, SIZE(val%i_val)
608 124584 : c_string = enum_i2c(val%enum, val%i_val(i))
609 124584 : IF (l > 10 .AND. l + LEN_TRIM(c_string) > 76) THEN
610 0 : WRITE (UNIT=unit_nr, FMT="(1X,A)") default_continuation_character
611 0 : WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//")", ADVANCE="NO")
612 0 : l = 0
613 : ELSE
614 124584 : l = l + LEN_TRIM(c_string) + 3
615 : END IF
616 249168 : WRITE (UNIT=unit_nr, FMT="(1X,A)", ADVANCE="NO") TRIM(c_string)
617 : END DO
618 : ELSE
619 0 : CPABORT("Input value of type <enum_t> not associated")
620 : END IF
621 : CASE (no_t)
622 0 : WRITE (UNIT=unit_nr, FMT="(' *empty*')", ADVANCE="NO")
623 : CASE default
624 1850031 : CPABORT("Unexpected type_of_var for val")
625 : END SELECT
626 : ELSE
627 0 : WRITE (UNIT=unit_nr, FMT="(1X,A)", ADVANCE="NO") "NULL()"
628 : END IF
629 :
630 1850031 : IF (owns_unit) THEN
631 0 : CALL cp_unit_release(my_unit)
632 0 : DEALLOCATE (my_unit)
633 : END IF
634 :
635 1850031 : WRITE (UNIT=unit_nr, FMT="()")
636 :
637 1850031 : END SUBROUTINE val_write
638 :
639 : ! **************************************************************************************************
640 : !> \brief Write values to an internal file, i.e. string variable.
641 : !> \param val ...
642 : !> \param string ...
643 : !> \param unit ...
644 : !> \date 10.03.2005
645 : !> \par History
646 : !> 17.01.2006, MK, Optional argument unit for the conversion to the external unit added
647 : !> \author MK
648 : !> \version 1.0
649 : ! **************************************************************************************************
650 0 : SUBROUTINE val_write_internal(val, string, unit)
651 :
652 : TYPE(val_type), POINTER :: val
653 : CHARACTER(LEN=*), INTENT(OUT) :: string
654 : TYPE(cp_unit_type), OPTIONAL, POINTER :: unit
655 :
656 : CHARACTER(LEN=default_string_length) :: enum_string
657 : INTEGER :: i, ipos
658 : REAL(KIND=dp) :: value
659 :
660 0 : string = ""
661 :
662 0 : IF (ASSOCIATED(val)) THEN
663 :
664 0 : SELECT CASE (val%type_of_var)
665 : CASE (logical_t)
666 0 : IF (ASSOCIATED(val%l_val)) THEN
667 0 : DO i = 1, SIZE(val%l_val)
668 0 : WRITE (UNIT=string(2*i - 1:), FMT="(1X,L1)") val%l_val(i)
669 : END DO
670 : ELSE
671 0 : CPABORT("")
672 : END IF
673 : CASE (integer_t)
674 0 : IF (ASSOCIATED(val%i_val)) THEN
675 0 : DO i = 1, SIZE(val%i_val)
676 0 : WRITE (UNIT=string(12*i - 11:), FMT="(I12)") val%i_val(i)
677 : END DO
678 : ELSE
679 0 : CPABORT("")
680 : END IF
681 : CASE (real_t)
682 0 : IF (ASSOCIATED(val%r_val)) THEN
683 0 : IF (PRESENT(unit)) THEN
684 0 : DO i = 1, SIZE(val%r_val)
685 : value = cp_unit_from_cp2k(value=val%r_val(i), &
686 0 : unit_str=cp_unit_desc(unit=unit))
687 0 : WRITE (UNIT=string(17*i - 16:), FMT="(ES17.8E3)") value
688 : END DO
689 : ELSE
690 0 : DO i = 1, SIZE(val%r_val)
691 0 : WRITE (UNIT=string(17*i - 16:), FMT="(ES17.8E3)") val%r_val(i)
692 : END DO
693 : END IF
694 : ELSE
695 0 : CPABORT("")
696 : END IF
697 : CASE (char_t)
698 0 : IF (ASSOCIATED(val%c_val)) THEN
699 0 : ipos = 1
700 0 : DO i = 1, SIZE(val%c_val)
701 0 : WRITE (UNIT=string(ipos:), FMT="(A)") TRIM(ADJUSTL(val%c_val(i)))
702 0 : ipos = ipos + LEN_TRIM(ADJUSTL(val%c_val(i))) + 1
703 : END DO
704 : ELSE
705 0 : CPABORT("")
706 : END IF
707 : CASE (lchar_t)
708 0 : IF (ASSOCIATED(val%c_val)) THEN
709 0 : CALL val_get(val, c_val=string)
710 : ELSE
711 0 : CPABORT("")
712 : END IF
713 : CASE (enum_t)
714 0 : IF (ASSOCIATED(val%i_val)) THEN
715 0 : DO i = 1, SIZE(val%i_val)
716 0 : enum_string = enum_i2c(val%enum, val%i_val(i))
717 0 : WRITE (UNIT=string, FMT="(A)") TRIM(ADJUSTL(enum_string))
718 : END DO
719 : ELSE
720 0 : CPABORT("")
721 : END IF
722 : CASE default
723 0 : CPABORT("unexpected type_of_var for val ")
724 : END SELECT
725 :
726 : END IF
727 :
728 0 : END SUBROUTINE val_write_internal
729 :
730 : ! **************************************************************************************************
731 : !> \brief creates a copy of the given value
732 : !> \param val_in the value to copy
733 : !> \param val_out the value tha will be created
734 : !> \author fawzi
735 : ! **************************************************************************************************
736 81777 : SUBROUTINE val_duplicate(val_in, val_out)
737 :
738 : TYPE(val_type), POINTER :: val_in, val_out
739 :
740 81777 : CPASSERT(ASSOCIATED(val_in))
741 81777 : CPASSERT(.NOT. ASSOCIATED(val_out))
742 81777 : ALLOCATE (val_out)
743 81777 : val_out%type_of_var = val_in%type_of_var
744 81777 : val_out%ref_count = 1
745 81777 : val_out%enum => val_in%enum
746 81777 : IF (ASSOCIATED(val_out%enum)) CALL enum_retain(val_out%enum)
747 :
748 81777 : NULLIFY (val_out%l_val, val_out%i_val, val_out%c_val, val_out%r_val)
749 81777 : IF (ASSOCIATED(val_in%l_val)) THEN
750 14283 : ALLOCATE (val_out%l_val(SIZE(val_in%l_val)))
751 19044 : val_out%l_val = val_in%l_val
752 : END IF
753 81777 : IF (ASSOCIATED(val_in%i_val)) THEN
754 43938 : ALLOCATE (val_out%i_val(SIZE(val_in%i_val)))
755 67752 : val_out%i_val = val_in%i_val
756 : END IF
757 81777 : IF (ASSOCIATED(val_in%r_val)) THEN
758 63378 : ALLOCATE (val_out%r_val(SIZE(val_in%r_val)))
759 114500 : val_out%r_val = val_in%r_val
760 : END IF
761 81777 : IF (ASSOCIATED(val_in%c_val)) THEN
762 123732 : ALLOCATE (val_out%c_val(SIZE(val_in%c_val)))
763 167124 : val_out%c_val = val_in%c_val
764 : END IF
765 :
766 81777 : END SUBROUTINE val_duplicate
767 :
768 0 : END MODULE input_val_types
|
