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 : 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_type
22 : USE input_enumeration_types, ONLY: enum_i2c,&
23 : enum_release,&
24 : enum_retain,&
25 : enumeration_type
26 : USE kinds, ONLY: default_string_length,&
27 : dp
28 : #include "../base/base_uses.f90"
29 :
30 : IMPLICIT NONE
31 : PRIVATE
32 :
33 : LOGICAL, PRIVATE, PARAMETER :: debug_this_module = .TRUE.
34 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'input_val_types'
35 :
36 : PUBLIC :: val_p_type, val_type
37 : PUBLIC :: val_create, val_retain, val_release, val_get, val_write, &
38 : val_write_internal, val_duplicate
39 : !***
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
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, type_of_var
65 : LOGICAL, DIMENSION(:), POINTER :: l_val
66 : INTEGER, DIMENSION(:), POINTER :: i_val
67 : CHARACTER(len=default_string_length), DIMENSION(:), POINTER :: &
68 : c_val
69 : REAL(kind=dp), DIMENSION(:), POINTER :: r_val
70 : TYPE(enumeration_type), POINTER :: enum
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 1008578901 : SUBROUTINE val_create(val, l_val, l_vals, l_vals_ptr, i_val, i_vals, i_vals_ptr, &
101 2017127904 : r_val, r_vals, r_vals_ptr, c_val, c_vals, c_vals_ptr, lc_val, lc_vals, &
102 : lc_vals_ptr, enum)
103 : TYPE(val_type), POINTER :: val
104 : LOGICAL, INTENT(in), OPTIONAL :: l_val
105 : LOGICAL, DIMENSION(:), INTENT(in), OPTIONAL :: l_vals
106 : LOGICAL, DIMENSION(:), OPTIONAL, POINTER :: l_vals_ptr
107 : INTEGER, INTENT(in), OPTIONAL :: i_val
108 : INTEGER, DIMENSION(:), INTENT(in), OPTIONAL :: i_vals
109 : INTEGER, DIMENSION(:), OPTIONAL, POINTER :: i_vals_ptr
110 : REAL(KIND=DP), INTENT(in), OPTIONAL :: r_val
111 : REAL(KIND=DP), DIMENSION(:), INTENT(in), OPTIONAL :: r_vals
112 : REAL(KIND=DP), DIMENSION(:), OPTIONAL, POINTER :: r_vals_ptr
113 : CHARACTER(LEN=*), INTENT(in), OPTIONAL :: c_val
114 : CHARACTER(LEN=*), DIMENSION(:), INTENT(in), &
115 : OPTIONAL :: c_vals
116 : CHARACTER(LEN=default_string_length), &
117 : DIMENSION(:), OPTIONAL, POINTER :: c_vals_ptr
118 : CHARACTER(LEN=*), INTENT(in), OPTIONAL :: lc_val
119 : CHARACTER(LEN=*), DIMENSION(:), INTENT(in), &
120 : OPTIONAL :: lc_vals
121 : CHARACTER(LEN=default_string_length), &
122 : DIMENSION(:), OPTIONAL, POINTER :: lc_vals_ptr
123 : TYPE(enumeration_type), OPTIONAL, POINTER :: enum
124 :
125 : INTEGER :: i, len_c, narg, nVal
126 :
127 1008563952 : CPASSERT(.NOT. ASSOCIATED(val))
128 1008563952 : ALLOCATE (val)
129 1008563952 : NULLIFY (val%l_val, val%i_val, val%r_val, val%c_val, val%enum)
130 1008563952 : val%type_of_var = no_t
131 1008563952 : val%ref_count = 1
132 :
133 1008563952 : narg = 0
134 : val%type_of_var = no_t
135 1008563952 : IF (PRESENT(l_val)) THEN
136 : !FM CPPrecondition(.NOT.PRESENT(l_vals),cp_failure_level,routineP,failure)
137 : !FM CPPrecondition(.NOT.PRESENT(l_vals_ptr),cp_failure_level,routineP,failure)
138 126272740 : narg = narg + 1
139 126272740 : ALLOCATE (val%l_val(1))
140 126272740 : val%l_val(1) = l_val
141 126272740 : val%type_of_var = logical_t
142 : END IF
143 1008563952 : IF (PRESENT(l_vals)) THEN
144 : !FM CPPrecondition(.NOT.PRESENT(l_vals_ptr),cp_failure_level,routineP,failure)
145 14949 : narg = narg + 1
146 44847 : ALLOCATE (val%l_val(SIZE(l_vals)))
147 29898 : val%l_val = l_vals
148 14949 : val%type_of_var = logical_t
149 : END IF
150 1008563952 : IF (PRESENT(l_vals_ptr)) THEN
151 16638 : narg = narg + 1
152 16638 : val%l_val => l_vals_ptr
153 16638 : val%type_of_var = logical_t
154 : END IF
155 :
156 1008563952 : IF (PRESENT(r_val)) THEN
157 : !FM CPPrecondition(.NOT.PRESENT(r_vals),cp_failure_level,routineP,failure)
158 : !FM CPPrecondition(.NOT.PRESENT(r_vals_ptr),cp_failure_level,routineP,failure)
159 251926737 : narg = narg + 1
160 251926737 : ALLOCATE (val%r_val(1))
161 251926737 : val%r_val(1) = r_val
162 251926737 : val%type_of_var = real_t
163 : END IF
164 1008563952 : IF (PRESENT(r_vals)) THEN
165 : !FM CPPrecondition(.NOT.PRESENT(r_vals_ptr),cp_failure_level,routineP,failure)
166 1445124 : narg = narg + 1
167 4335372 : ALLOCATE (val%r_val(SIZE(r_vals)))
168 5482642 : val%r_val = r_vals
169 1445124 : val%type_of_var = real_t
170 : END IF
171 1008563952 : IF (PRESENT(r_vals_ptr)) THEN
172 1000305 : narg = narg + 1
173 1000305 : val%r_val => r_vals_ptr
174 1000305 : val%type_of_var = real_t
175 : END IF
176 :
177 1008563952 : IF (PRESENT(i_val)) THEN
178 : !FM CPPrecondition(.NOT.PRESENT(i_vals),cp_failure_level,routineP,failure)
179 : !FM CPPrecondition(.NOT.PRESENT(i_vals_ptr),cp_failure_level,routineP,failure)
180 167221196 : narg = narg + 1
181 167221196 : ALLOCATE (val%i_val(1))
182 167221196 : val%i_val(1) = i_val
183 167221196 : val%type_of_var = integer_t
184 : END IF
185 1008563952 : IF (PRESENT(i_vals)) THEN
186 : !FM CPPrecondition(.NOT.PRESENT(i_vals_ptr),cp_failure_level,routineP,failure)
187 2138465 : narg = narg + 1
188 6415395 : ALLOCATE (val%i_val(SIZE(i_vals)))
189 7586808 : val%i_val = i_vals
190 2138465 : val%type_of_var = integer_t
191 : END IF
192 1008563952 : IF (PRESENT(i_vals_ptr)) THEN
193 161488 : narg = narg + 1
194 161488 : val%i_val => i_vals_ptr
195 161488 : val%type_of_var = integer_t
196 : END IF
197 :
198 1008563952 : IF (PRESENT(c_val)) THEN
199 1667188 : CPASSERT(LEN_TRIM(c_val) <= default_string_length)
200 : !FM CPPrecondition(.NOT.PRESENT(c_vals),cp_failure_level,routineP,failure)
201 : !FM CPPrecondition(.NOT.PRESENT(c_vals_ptr),cp_failure_level,routineP,failure)
202 1667188 : narg = narg + 1
203 1667188 : ALLOCATE (val%c_val(1))
204 1667188 : val%c_val(1) = c_val
205 1667188 : val%type_of_var = char_t
206 : END IF
207 1008563952 : IF (PRESENT(c_vals)) THEN
208 : !FM CPPrecondition(.NOT.PRESENT(c_vals_ptr),cp_failure_level,routineP,failure)
209 330204 : CPASSERT(ALL(LEN_TRIM(c_vals) <= default_string_length))
210 112820 : narg = narg + 1
211 338460 : ALLOCATE (val%c_val(SIZE(c_vals)))
212 330204 : val%c_val = c_vals
213 112820 : val%type_of_var = char_t
214 : END IF
215 1008563952 : IF (PRESENT(c_vals_ptr)) THEN
216 70414 : narg = narg + 1
217 70414 : val%c_val => c_vals_ptr
218 70414 : val%type_of_var = char_t
219 : END IF
220 1008563952 : IF (PRESENT(lc_val)) THEN
221 : !FM CPPrecondition(.NOT.PRESENT(lc_vals),cp_failure_level,routineP,failure)
222 : !FM CPPrecondition(.NOT.PRESENT(lc_vals_ptr),cp_failure_level,routineP,failure)
223 8779406 : narg = narg + 1
224 8779406 : len_c = LEN_TRIM(lc_val)
225 8779406 : nVal = MAX(1, CEILING(REAL(len_c, dp)/80._dp))
226 26338218 : ALLOCATE (val%c_val(nVal))
227 :
228 8779406 : IF (len_c == 0) THEN
229 3091875 : val%c_val(1) = ""
230 : ELSE
231 12891415 : DO i = 1, nVal
232 : val%c_val(i) = lc_val((i - 1)*default_string_length + 1: &
233 12891415 : MIN(len_c, i*default_string_length))
234 : END DO
235 : END IF
236 8779406 : val%type_of_var = lchar_t
237 : END IF
238 1008563952 : IF (PRESENT(lc_vals)) THEN
239 0 : CPASSERT(ALL(LEN_TRIM(lc_vals) <= default_string_length))
240 0 : narg = narg + 1
241 0 : ALLOCATE (val%c_val(SIZE(lc_vals)))
242 0 : val%c_val = lc_vals
243 0 : val%type_of_var = lchar_t
244 : END IF
245 1008563952 : IF (PRESENT(lc_vals_ptr)) THEN
246 259671 : narg = narg + 1
247 259671 : val%c_val => lc_vals_ptr
248 259671 : val%type_of_var = lchar_t
249 : END IF
250 1008563952 : CPASSERT(narg <= 1)
251 1008563952 : IF (PRESENT(enum)) THEN
252 1005339004 : IF (ASSOCIATED(enum)) THEN
253 43627247 : IF (val%type_of_var /= no_t .AND. val%type_of_var /= integer_t .AND. &
254 : val%type_of_var /= enum_t) THEN
255 0 : CPABORT("")
256 : END IF
257 43627247 : IF (ASSOCIATED(val%i_val)) THEN
258 28334218 : val%type_of_var = enum_t
259 28334218 : val%enum => enum
260 28334218 : CALL enum_retain(enum)
261 : END IF
262 : END IF
263 : END IF
264 1008563952 : CPASSERT(ASSOCIATED(val%enum) .EQV. val%type_of_var == enum_t)
265 1008563952 : END SUBROUTINE val_create
266 :
267 : ! **************************************************************************************************
268 : !> \brief releases the given val
269 : !> \param val the val to release
270 : !> \author fawzi
271 : ! **************************************************************************************************
272 1456121426 : SUBROUTINE val_release(val)
273 : TYPE(val_type), POINTER :: val
274 :
275 1456121426 : IF (ASSOCIATED(val)) THEN
276 1008644615 : CPASSERT(val%ref_count > 0)
277 1008644615 : val%ref_count = val%ref_count - 1
278 1008644615 : IF (val%ref_count == 0) THEN
279 1008644615 : IF (ASSOCIATED(val%l_val)) THEN
280 126309012 : DEALLOCATE (val%l_val)
281 : END IF
282 1008644615 : IF (ASSOCIATED(val%i_val)) THEN
283 169535433 : DEALLOCATE (val%i_val)
284 : END IF
285 1008644615 : IF (ASSOCIATED(val%r_val)) THEN
286 254392608 : DEALLOCATE (val%r_val)
287 : END IF
288 1008644615 : IF (ASSOCIATED(val%c_val)) THEN
289 10930751 : DEALLOCATE (val%c_val)
290 : END IF
291 1008644615 : CALL enum_release(val%enum)
292 1008644615 : val%type_of_var = no_t
293 1008644615 : DEALLOCATE (val)
294 : END IF
295 : END IF
296 1456121426 : NULLIFY (val)
297 1456121426 : END SUBROUTINE val_release
298 :
299 : ! **************************************************************************************************
300 : !> \brief retains the given val
301 : !> \param val the val to retain
302 : !> \author fawzi
303 : ! **************************************************************************************************
304 0 : SUBROUTINE val_retain(val)
305 : TYPE(val_type), POINTER :: val
306 :
307 0 : CPASSERT(ASSOCIATED(val))
308 0 : CPASSERT(val%ref_count > 0)
309 0 : val%ref_count = val%ref_count + 1
310 0 : END SUBROUTINE val_retain
311 :
312 : ! **************************************************************************************************
313 : !> \brief returns the stored values
314 : !> \param val the object from which you want to extract the values
315 : !> \param has_l ...
316 : !> \param has_i ...
317 : !> \param has_r ...
318 : !> \param has_lc ...
319 : !> \param has_c ...
320 : !> \param l_val gets a logical from the val
321 : !> \param l_vals gets an array of logicals from the val
322 : !> \param i_val gets an integer from the val
323 : !> \param i_vals gets an array of integers from the val
324 : !> \param r_val gets a real from the val
325 : !> \param r_vals gets an array of reals from the val
326 : !> \param c_val gets a char from the val
327 : !> \param c_vals gets an array of chars from the val
328 : !> \param len_c len_trim of c_val (if it was a lc_val, of type lchar_t
329 : !> it might be longet than default_string_length)
330 : !> \param type_of_var ...
331 : !> \param enum ...
332 : !> \author fawzi
333 : !> \note
334 : !> using an enumeration only i_val/i_vals/i_vals_ptr are accepted
335 : !> add something like ignore_string_cut that if true does not warn if
336 : !> the c_val is too short to contain the string
337 : ! **************************************************************************************************
338 36588479 : SUBROUTINE val_get(val, has_l, has_i, has_r, has_lc, has_c, l_val, l_vals, i_val, &
339 : i_vals, r_val, r_vals, c_val, c_vals, len_c, type_of_var, enum)
340 : TYPE(val_type), POINTER :: val
341 : LOGICAL, INTENT(out), OPTIONAL :: has_l, has_i, has_r, has_lc, has_c, l_val
342 : LOGICAL, DIMENSION(:), OPTIONAL, POINTER :: l_vals
343 : INTEGER, INTENT(out), OPTIONAL :: i_val
344 : INTEGER, DIMENSION(:), OPTIONAL, POINTER :: i_vals
345 : REAL(KIND=DP), INTENT(out), OPTIONAL :: r_val
346 : REAL(KIND=DP), DIMENSION(:), OPTIONAL, POINTER :: r_vals
347 : CHARACTER(LEN=*), INTENT(out), OPTIONAL :: c_val
348 : CHARACTER(LEN=default_string_length), &
349 : DIMENSION(:), OPTIONAL, POINTER :: c_vals
350 : INTEGER, INTENT(out), OPTIONAL :: len_c, type_of_var
351 : TYPE(enumeration_type), OPTIONAL, POINTER :: enum
352 :
353 : INTEGER :: i, l_in, l_out
354 :
355 0 : IF (PRESENT(has_l)) has_l = ASSOCIATED(val%l_val)
356 36588479 : IF (PRESENT(has_i)) has_i = ASSOCIATED(val%i_val)
357 36588479 : IF (PRESENT(has_r)) has_r = ASSOCIATED(val%r_val)
358 36588479 : IF (PRESENT(has_c)) has_c = ASSOCIATED(val%c_val) ! use type_of_var?
359 36588479 : IF (PRESENT(has_lc)) has_lc = (val%type_of_var == lchar_t)
360 36588479 : IF (PRESENT(l_vals)) l_vals => val%l_val
361 36588479 : IF (PRESENT(l_val)) THEN
362 3731739 : IF (ASSOCIATED(val%l_val)) THEN
363 3731739 : IF (SIZE(val%l_val) > 0) THEN
364 3731739 : l_val = val%l_val(1)
365 : ELSE
366 0 : CPABORT("")
367 : END IF
368 : ELSE
369 0 : CPABORT("")
370 : END IF
371 : END IF
372 :
373 36588479 : IF (PRESENT(i_vals)) i_vals => val%i_val
374 36588479 : IF (PRESENT(i_val)) THEN
375 23372403 : IF (ASSOCIATED(val%i_val)) THEN
376 23372403 : IF (SIZE(val%i_val) > 0) THEN
377 23372403 : i_val = val%i_val(1)
378 : ELSE
379 0 : CPABORT("")
380 : END IF
381 : ELSE
382 0 : CPABORT("")
383 : END IF
384 : END IF
385 :
386 36588479 : IF (PRESENT(r_vals)) r_vals => val%r_val
387 36588479 : IF (PRESENT(r_val)) THEN
388 4062174 : IF (ASSOCIATED(val%r_val)) THEN
389 4062174 : IF (SIZE(val%r_val) > 0) THEN
390 4062174 : r_val = val%r_val(1)
391 : ELSE
392 0 : CPABORT("")
393 : END IF
394 : ELSE
395 0 : CPABORT("")
396 : END IF
397 : END IF
398 :
399 36588479 : IF (PRESENT(c_vals)) c_vals => val%c_val
400 36588479 : IF (PRESENT(c_val)) THEN
401 2875499 : l_out = LEN(c_val)
402 2875499 : IF (ASSOCIATED(val%c_val)) THEN
403 2872563 : IF (SIZE(val%c_val) > 0) THEN
404 2872563 : IF (val%type_of_var == lchar_t) THEN
405 : l_in = default_string_length*(SIZE(val%c_val) - 1) + &
406 2310016 : LEN_TRIM(val%c_val(SIZE(val%c_val)))
407 2310016 : IF (l_out < l_in) &
408 : CALL cp_warn(__LOCATION__, &
409 : "val_get will truncate value, value beginning with '"// &
410 0 : TRIM(val%c_val(1))//"' is too long for variable")
411 3766396 : DO i = 1, SIZE(val%c_val)
412 : c_val((i - 1)*default_string_length + 1:MIN(l_out, i*default_string_length)) = &
413 2348810 : val%c_val(i) (1:MIN(80, l_out - (i - 1)*default_string_length))
414 3766396 : IF (l_out <= i*default_string_length) EXIT
415 : END DO
416 2310016 : IF (l_out > SIZE(val%c_val)*default_string_length) &
417 1417586 : c_val(SIZE(val%c_val)*default_string_length + 1:l_out) = ""
418 : ELSE
419 562547 : l_in = LEN_TRIM(val%c_val(1))
420 562547 : IF (l_out < l_in) &
421 : CALL cp_warn(__LOCATION__, &
422 : "val_get will truncate value, value '"// &
423 0 : TRIM(val%c_val(1))//"' is too long for variable")
424 562547 : c_val = val%c_val(1)
425 : END IF
426 : ELSE
427 0 : CPABORT("")
428 : END IF
429 2936 : ELSE IF (ASSOCIATED(val%i_val) .AND. ASSOCIATED(val%enum)) THEN
430 2936 : IF (SIZE(val%i_val) > 0) THEN
431 2936 : c_val = enum_i2c(val%enum, val%i_val(1))
432 : ELSE
433 0 : CPABORT("")
434 : END IF
435 : ELSE
436 0 : CPABORT("")
437 : END IF
438 : END IF
439 :
440 36588479 : IF (PRESENT(len_c)) THEN
441 0 : IF (ASSOCIATED(val%c_val)) THEN
442 0 : IF (SIZE(val%c_val) > 0) THEN
443 0 : IF (val%type_of_var == lchar_t) THEN
444 : len_c = default_string_length*(SIZE(val%c_val) - 1) + &
445 0 : LEN_TRIM(val%c_val(SIZE(val%c_val)))
446 : ELSE
447 0 : len_c = LEN_TRIM(val%c_val(1))
448 : END IF
449 : ELSE
450 0 : len_c = -HUGE(0)
451 : END IF
452 0 : ELSE IF (ASSOCIATED(val%i_val) .AND. ASSOCIATED(val%enum)) THEN
453 0 : IF (SIZE(val%i_val) > 0) THEN
454 0 : len_c = LEN_TRIM(enum_i2c(val%enum, val%i_val(1)))
455 : ELSE
456 0 : len_c = -HUGE(0)
457 : END IF
458 : ELSE
459 0 : len_c = -HUGE(0)
460 : END IF
461 : END IF
462 :
463 36588479 : IF (PRESENT(type_of_var)) type_of_var = val%type_of_var
464 :
465 36588479 : IF (PRESENT(enum)) enum => val%enum
466 :
467 36588479 : END SUBROUTINE val_get
468 :
469 : ! **************************************************************************************************
470 : !> \brief writes out the valuse stored in the val
471 : !> \param val the val to write
472 : !> \param unit_nr the number of the unit to write to
473 : !> \param unit the unit of mesure in which the output should be written
474 : !> (overrides unit_str)
475 : !> \param unit_str the unit of mesure in which the output should be written
476 : !> \param fmt ...
477 : !> \author fawzi
478 : !> \note
479 : !> unit of mesure used only for reals
480 : ! **************************************************************************************************
481 2074703 : SUBROUTINE val_write(val, unit_nr, unit, unit_str, fmt)
482 : TYPE(val_type), POINTER :: val
483 : INTEGER, INTENT(in) :: unit_nr
484 : TYPE(cp_unit_type), OPTIONAL, POINTER :: unit
485 : CHARACTER(len=*), INTENT(in), OPTIONAL :: unit_str, fmt
486 :
487 : CHARACTER(len=default_string_length) :: c_string, myfmt, rcval
488 : INTEGER :: i, iend, item, j, l
489 : LOGICAL :: owns_unit
490 : TYPE(cp_unit_type), POINTER :: my_unit
491 :
492 2074703 : NULLIFY (my_unit)
493 2074703 : myfmt = ""
494 2074703 : owns_unit = .FALSE.
495 2074683 : IF (PRESENT(fmt)) myfmt = fmt
496 2074703 : IF (PRESENT(unit)) my_unit => unit
497 2074703 : 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 2074703 : IF (ASSOCIATED(val)) THEN
503 2121674 : SELECT CASE (val%type_of_var)
504 : CASE (logical_t)
505 46971 : IF (ASSOCIATED(val%l_val)) THEN
506 93942 : DO i = 1, SIZE(val%l_val)
507 46971 : IF (MODULO(i, 20) == 0) THEN
508 0 : WRITE (unit=unit_nr, fmt="(' ',A)") default_continuation_character
509 0 : WRITE (unit=unit_nr, fmt="("//TRIM(myfmt)//")", advance="NO")
510 : END IF
511 : WRITE (unit=unit_nr, fmt="(' ',l1)", advance="NO") &
512 93942 : val%l_val(i)
513 : END DO
514 : ELSE
515 0 : CPABORT("")
516 : END IF
517 : CASE (integer_t)
518 103174 : IF (ASSOCIATED(val%i_val)) THEN
519 : item = 0
520 : i = 1
521 246527 : loop_i: DO WHILE (i <= SIZE(val%i_val))
522 143353 : item = item + 1
523 143353 : IF (MODULO(item, 10) == 0) THEN
524 63 : WRITE (UNIT=unit_nr, FMT="(1X,A)") default_continuation_character
525 63 : WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//")", ADVANCE="NO")
526 : END IF
527 143353 : iend = i
528 191871 : loop_j: DO j = i + 1, SIZE(val%i_val)
529 191871 : IF (val%i_val(j - 1) + 1 == val%i_val(j)) THEN
530 48518 : iend = iend + 1
531 : ELSE
532 : EXIT loop_j
533 : END IF
534 : END DO loop_j
535 143353 : IF ((iend - i) > 1) THEN
536 : WRITE (UNIT=unit_nr, FMT="(1X,I0,A2,I0)", ADVANCE="NO") &
537 4183 : val%i_val(i), "..", val%i_val(iend)
538 4183 : i = iend
539 : ELSE
540 : WRITE (UNIT=unit_nr, FMT="(1X,I0)", ADVANCE="NO") &
541 139170 : val%i_val(i)
542 : END IF
543 246527 : i = i + 1
544 : END DO loop_i
545 : ELSE
546 0 : CPABORT("")
547 : END IF
548 : CASE (real_t)
549 808730 : IF (ASSOCIATED(val%r_val)) THEN
550 101535771 : DO i = 1, SIZE(val%r_val)
551 100727041 : IF (MODULO(i, 5) == 0) THEN
552 19806408 : WRITE (unit=unit_nr, fmt="(' ',A)") default_continuation_character
553 19806408 : WRITE (unit=unit_nr, fmt="("//TRIM(myfmt)//")", advance="NO")
554 : END IF
555 100727041 : IF (ASSOCIATED(my_unit)) THEN
556 333616 : WRITE (rcval, "(ES25.16)") cp_unit_from_cp2k1(val%r_val(i), my_unit)
557 : ELSE
558 100393425 : WRITE (rcval, "(ES25.16)") val%r_val(i)
559 : END IF
560 101535771 : WRITE (unit=unit_nr, fmt="(' ',A)", advance="NO") TRIM(rcval)
561 : END DO
562 : ELSE
563 0 : CPABORT("")
564 : END IF
565 : CASE (char_t)
566 41377 : IF (ASSOCIATED(val%c_val)) THEN
567 41377 : l = 0
568 99128 : DO i = 1, SIZE(val%c_val)
569 57751 : IF (i > 1) WRITE (unit=unit_nr, fmt="(' ')", advance="NO")
570 57751 : l = l + 1
571 99128 : IF (l > 10 .AND. l + LEN_TRIM(val%c_val(i)) > 76) THEN
572 0 : WRITE (unit=unit_nr, fmt="('\')")
573 0 : WRITE (unit=unit_nr, fmt="("//TRIM(myfmt)//")", advance="NO")
574 0 : l = 0
575 0 : WRITE (unit=unit_nr, fmt='(a)', advance="NO") TRIM(val%c_val(i))
576 0 : l = l + LEN_TRIM(val%c_val(i)) + 3
577 57751 : ELSE IF (LEN_TRIM(val%c_val(i)) > 0) THEN
578 57638 : l = l + LEN_TRIM(val%c_val(i))
579 57638 : WRITE (unit=unit_nr, fmt='(a)', advance="NO") TRIM(val%c_val(i))
580 : ELSE
581 113 : l = l + 3
582 113 : WRITE (unit=unit_nr, fmt="(a)", advance="NO") '" "'
583 : END IF
584 : END DO
585 : ELSE
586 0 : CPABORT("")
587 : END IF
588 : CASE (lchar_t)
589 953924 : IF (ASSOCIATED(val%c_val)) THEN
590 953924 : l = 0
591 1799446 : DO i = 1, SIZE(val%c_val) - 1
592 1799446 : WRITE (unit=unit_nr, fmt='(a)', advance="NO") val%c_val(i)
593 : END DO
594 953924 : IF (SIZE(val%c_val) > 0) THEN
595 953924 : WRITE (unit=unit_nr, fmt='(a)', advance="NO") TRIM(val%c_val(SIZE(val%c_val)))
596 : END IF
597 : ELSE
598 0 : CPABORT("")
599 : END IF
600 : CASE (enum_t)
601 120527 : IF (ASSOCIATED(val%i_val)) THEN
602 120527 : l = 0
603 241054 : DO i = 1, SIZE(val%i_val)
604 120527 : c_string = enum_i2c(val%enum, val%i_val(i))
605 120527 : IF (l > 10 .AND. l + LEN_TRIM(c_string) > 76) THEN
606 0 : WRITE (unit=unit_nr, fmt="(' ',A)") default_continuation_character
607 0 : WRITE (unit=unit_nr, fmt="("//TRIM(myfmt)//")", advance="NO")
608 0 : l = 0
609 : ELSE
610 120527 : l = l + LEN_TRIM(c_string) + 3
611 : END IF
612 241054 : WRITE (unit=unit_nr, fmt="(' ',a)", advance="NO") TRIM(c_string)
613 : END DO
614 : ELSE
615 0 : CPABORT("")
616 : END IF
617 :
618 : CASE (no_t)
619 0 : WRITE (unit=unit_nr, fmt="(' *empty*')", advance="NO")
620 : CASE default
621 2074703 : CPABORT("unexpected type_of_var for val ")
622 : END SELECT
623 : ELSE
624 0 : WRITE (unit=unit_nr, fmt="(' *null*')", advance="NO")
625 : END IF
626 2074703 : IF (owns_unit) THEN
627 0 : CALL cp_unit_release(my_unit)
628 0 : DEALLOCATE (my_unit)
629 : END IF
630 2074703 : WRITE (unit=unit_nr, fmt="()")
631 2074703 : 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 80663 : SUBROUTINE val_duplicate(val_in, val_out)
733 : TYPE(val_type), POINTER :: val_in, val_out
734 :
735 80663 : CPASSERT(ASSOCIATED(val_in))
736 80663 : CPASSERT(.NOT. ASSOCIATED(val_out))
737 80663 : ALLOCATE (val_out)
738 80663 : val_out%type_of_var = val_in%type_of_var
739 80663 : val_out%ref_count = 1
740 80663 : val_out%enum => val_in%enum
741 80663 : IF (ASSOCIATED(val_out%enum)) CALL enum_retain(val_out%enum)
742 :
743 80663 : NULLIFY (val_out%l_val, val_out%i_val, val_out%c_val, val_out%r_val)
744 80663 : IF (ASSOCIATED(val_in%l_val)) THEN
745 14055 : ALLOCATE (val_out%l_val(SIZE(val_in%l_val)))
746 18740 : val_out%l_val = val_in%l_val
747 : END IF
748 80663 : IF (ASSOCIATED(val_in%i_val)) THEN
749 42852 : ALLOCATE (val_out%i_val(SIZE(val_in%i_val)))
750 66304 : val_out%i_val = val_in%i_val
751 : END IF
752 80663 : IF (ASSOCIATED(val_in%r_val)) THEN
753 61326 : ALLOCATE (val_out%r_val(SIZE(val_in%r_val)))
754 111764 : val_out%r_val = val_in%r_val
755 : END IF
756 80663 : IF (ASSOCIATED(val_in%c_val)) THEN
757 123756 : ALLOCATE (val_out%c_val(SIZE(val_in%c_val)))
758 167208 : val_out%c_val = val_in%c_val
759 : END IF
760 80663 : END SUBROUTINE val_duplicate
761 :
762 0 : END MODULE input_val_types
|
