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