Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2024 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief set of type/routines to handle the storage of results in force_envs
10 : !> \author fschiff (12.2007)
11 : !> \par History
12 : !> - 10.2008 Teodoro Laino [tlaino] - University of Zurich
13 : !> major rewriting:
14 : !> - information stored in a proper type (not in a character!)
15 : !> - module more lean
16 : ! **************************************************************************************************
17 : MODULE cp_result_methods
18 : USE cp_result_types, ONLY: &
19 : cp_result_clean, cp_result_copy, cp_result_create, cp_result_release, cp_result_type, &
20 : cp_result_value_copy, cp_result_value_create, cp_result_value_init, &
21 : cp_result_value_p_reallocate, result_type_integer, result_type_logical, result_type_real
22 : USE kinds, ONLY: default_string_length,&
23 : dp
24 : USE memory_utilities, ONLY: reallocate
25 : USE message_passing, ONLY: mp_para_env_type
26 : #include "../base/base_uses.f90"
27 :
28 : IMPLICIT NONE
29 : PRIVATE
30 :
31 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'cp_result_methods'
32 :
33 : PUBLIC :: put_results, &
34 : test_for_result, &
35 : get_results, &
36 : cp_results_erase, &
37 : cp_results_mp_bcast
38 :
39 : INTERFACE put_results
40 : MODULE PROCEDURE put_result_r1, put_result_r2
41 : END INTERFACE
42 :
43 : INTERFACE get_results
44 : MODULE PROCEDURE get_result_r1, get_result_r2, get_nreps
45 : END INTERFACE
46 :
47 : CONTAINS
48 :
49 : ! **************************************************************************************************
50 : !> \brief Store a 1D array of reals in result_list
51 : !> \param results ...
52 : !> \param description ...
53 : !> \param values ...
54 : !> \par History
55 : !> 12.2007 created
56 : !> 10.2008 Teodoro Laino [tlaino] - major rewriting
57 : !> \author fschiff
58 : ! **************************************************************************************************
59 32628 : SUBROUTINE put_result_r1(results, description, values)
60 : TYPE(cp_result_type), POINTER :: results
61 : CHARACTER(LEN=default_string_length), INTENT(IN) :: description
62 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: values
63 :
64 : INTEGER :: isize, jsize
65 : LOGICAL :: check
66 :
67 32628 : CPASSERT(ASSOCIATED(results))
68 32628 : CPASSERT(description(1:1) == '[')
69 32628 : check = SIZE(results%result_label) == SIZE(results%result_value)
70 32628 : CPASSERT(check)
71 32628 : isize = SIZE(results%result_label)
72 32628 : jsize = SIZE(values)
73 :
74 32628 : CALL reallocate(results%result_label, 1, isize + 1)
75 32628 : CALL cp_result_value_p_reallocate(results%result_value, 1, isize + 1)
76 :
77 32628 : results%result_label(isize + 1) = description
78 32628 : CALL cp_result_value_init(results%result_value(isize + 1)%value, result_type_real, jsize)
79 141984 : results%result_value(isize + 1)%value%real_type = values
80 :
81 32628 : END SUBROUTINE put_result_r1
82 :
83 : ! **************************************************************************************************
84 : !> \brief Store a 2D array of reals in result_list
85 : !> \param results ...
86 : !> \param description ...
87 : !> \param values ...
88 : !> \par History
89 : !> 12.2007 created
90 : !> 10.2008 Teodoro Laino [tlaino] - major rewriting
91 : !> \author fschiff
92 : ! **************************************************************************************************
93 108 : SUBROUTINE put_result_r2(results, description, values)
94 : TYPE(cp_result_type), POINTER :: results
95 : CHARACTER(LEN=default_string_length), INTENT(IN) :: description
96 : REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: values
97 :
98 : INTEGER :: isize, jsize
99 : LOGICAL :: check
100 :
101 108 : CPASSERT(ASSOCIATED(results))
102 108 : CPASSERT(description(1:1) == '[')
103 108 : check = SIZE(results%result_label) == SIZE(results%result_value)
104 108 : CPASSERT(check)
105 108 : isize = SIZE(results%result_label)
106 108 : jsize = SIZE(values, 1)*SIZE(values, 2)
107 :
108 108 : CALL reallocate(results%result_label, 1, isize + 1)
109 108 : CALL cp_result_value_p_reallocate(results%result_value, 1, isize + 1)
110 :
111 108 : results%result_label(isize + 1) = description
112 108 : CALL cp_result_value_init(results%result_value(isize + 1)%value, result_type_real, jsize)
113 1188 : results%result_value(isize + 1)%value%real_type = RESHAPE(values, (/jsize/))
114 :
115 108 : END SUBROUTINE put_result_r2
116 :
117 : ! **************************************************************************************************
118 : !> \brief test for a certain result in the result_list
119 : !> \param results ...
120 : !> \param description ...
121 : !> \return ...
122 : !> \par History
123 : !> 10.2013
124 : !> \author Mandes
125 : ! **************************************************************************************************
126 19210 : FUNCTION test_for_result(results, description) RESULT(res_exist)
127 : TYPE(cp_result_type), POINTER :: results
128 : CHARACTER(LEN=default_string_length), INTENT(IN) :: description
129 : LOGICAL :: res_exist
130 :
131 : INTEGER :: i, nlist
132 :
133 19210 : CPASSERT(ASSOCIATED(results))
134 19210 : nlist = SIZE(results%result_value)
135 19210 : res_exist = .FALSE.
136 24510 : DO i = 1, nlist
137 24510 : IF (TRIM(results%result_label(i)) == TRIM(description)) THEN
138 : res_exist = .TRUE.
139 : EXIT
140 : END IF
141 : END DO
142 :
143 19210 : END FUNCTION test_for_result
144 :
145 : ! **************************************************************************************************
146 : !> \brief gets the required part out of the result_list
147 : !> \param results ...
148 : !> \param description ...
149 : !> \param values ...
150 : !> \param nval : if more than one entry for a given description is given you may choose
151 : !> which entry you want
152 : !> \param n_rep : integer indicating how many times the section exists in result_list
153 : !> \param n_entries : gets the number of lines used for a given description
154 : !> \par History
155 : !> 12.2007 created
156 : !> 10.2008 Teodoro Laino [tlaino] - major rewriting
157 : !> \author fschiff
158 : ! **************************************************************************************************
159 1623 : SUBROUTINE get_result_r1(results, description, values, nval, n_rep, n_entries)
160 : TYPE(cp_result_type), POINTER :: results
161 : CHARACTER(LEN=default_string_length), INTENT(IN) :: description
162 : REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: values
163 : INTEGER, INTENT(IN), OPTIONAL :: nval
164 : INTEGER, INTENT(OUT), OPTIONAL :: n_rep, n_entries
165 :
166 : INTEGER :: i, k, nlist, nrep, size_res, size_values
167 :
168 1623 : CPASSERT(ASSOCIATED(results))
169 1623 : nlist = SIZE(results%result_value)
170 1623 : CPASSERT(description(1:1) == '[')
171 1623 : CPASSERT(SIZE(results%result_label) == nlist)
172 1623 : nrep = 0
173 3809 : DO i = 1, nlist
174 3809 : IF (TRIM(results%result_label(i)) == TRIM(description)) nrep = nrep + 1
175 : END DO
176 :
177 1623 : IF (PRESENT(n_rep)) THEN
178 0 : n_rep = nrep
179 : END IF
180 :
181 1623 : IF (nrep .LE. 0) &
182 : CALL cp_abort(__LOCATION__, &
183 0 : " Trying to access result ("//TRIM(description)//") which was never stored!")
184 :
185 2159 : DO i = 1, nlist
186 2159 : IF (TRIM(results%result_label(i)) == TRIM(description)) THEN
187 1623 : IF (results%result_value(i)%value%type_in_use /= result_type_real) &
188 0 : CPABORT("Attempt to retrieve a RESULT which is not a REAL!")
189 :
190 1623 : size_res = SIZE(results%result_value(i)%value%real_type)
191 1623 : EXIT
192 : END IF
193 : END DO
194 1623 : IF (PRESENT(n_entries)) n_entries = size_res
195 1623 : size_values = SIZE(values, 1)
196 1623 : IF (PRESENT(nval)) THEN
197 917 : CPASSERT(size_res == size_values)
198 : ELSE
199 706 : CPASSERT(nrep*size_res == size_values)
200 : END IF
201 : k = 0
202 2865 : DO i = 1, nlist
203 2865 : IF (TRIM(results%result_label(i)) == TRIM(description)) THEN
204 1623 : k = k + 1
205 1623 : IF (PRESENT(nval)) THEN
206 917 : IF (k == nval) THEN
207 3668 : values = results%result_value(i)%value%real_type
208 : EXIT
209 : END IF
210 : ELSE
211 3136 : values((k - 1)*size_res + 1:k*size_res) = results%result_value(i)%value%real_type
212 : END IF
213 : END IF
214 : END DO
215 :
216 1623 : END SUBROUTINE get_result_r1
217 :
218 : ! **************************************************************************************************
219 : !> \brief gets the required part out of the result_list
220 : !> \param results ...
221 : !> \param description ...
222 : !> \param values ...
223 : !> \param nval : if more than one entry for a given description is given you may choose
224 : !> which entry you want
225 : !> \param n_rep : integer indicating how many times the section exists in result_list
226 : !> \param n_entries : gets the number of lines used for a given description
227 : !> \par History
228 : !> 12.2007 created
229 : !> 10.2008 Teodoro Laino [tlaino] - major rewriting
230 : !> \author fschiff
231 : ! **************************************************************************************************
232 24 : SUBROUTINE get_result_r2(results, description, values, nval, n_rep, n_entries)
233 : TYPE(cp_result_type), POINTER :: results
234 : CHARACTER(LEN=default_string_length), INTENT(IN) :: description
235 : REAL(KIND=dp), DIMENSION(:, :), INTENT(OUT) :: values
236 : INTEGER, INTENT(IN), OPTIONAL :: nval
237 : INTEGER, INTENT(OUT), OPTIONAL :: n_rep, n_entries
238 :
239 : INTEGER :: i, k, nlist, nrep, size_res, size_values
240 :
241 24 : CPASSERT(ASSOCIATED(results))
242 24 : nlist = SIZE(results%result_value)
243 24 : CPASSERT(description(1:1) == '[')
244 24 : CPASSERT(SIZE(results%result_label) == nlist)
245 24 : nrep = 0
246 120 : DO i = 1, nlist
247 120 : IF (TRIM(results%result_label(i)) == TRIM(description)) nrep = nrep + 1
248 : END DO
249 :
250 24 : IF (PRESENT(n_rep)) THEN
251 0 : n_rep = nrep
252 : END IF
253 :
254 24 : IF (nrep .LE. 0) &
255 : CALL cp_abort(__LOCATION__, &
256 0 : " Trying to access result ("//TRIM(description)//") which was never stored!")
257 :
258 96 : DO i = 1, nlist
259 96 : IF (TRIM(results%result_label(i)) == TRIM(description)) THEN
260 24 : IF (results%result_value(i)%value%type_in_use /= result_type_real) &
261 0 : CPABORT("Attempt to retrieve a RESULT which is not a REAL!")
262 :
263 24 : size_res = SIZE(results%result_value(i)%value%real_type)
264 24 : EXIT
265 : END IF
266 : END DO
267 24 : IF (PRESENT(n_entries)) n_entries = size_res
268 24 : size_values = SIZE(values, 1)*SIZE(values, 2)
269 24 : IF (PRESENT(nval)) THEN
270 24 : CPASSERT(size_res == size_values)
271 : ELSE
272 0 : CPASSERT(nrep*size_res == size_values)
273 : END IF
274 : k = 0
275 96 : DO i = 1, nlist
276 96 : IF (TRIM(results%result_label(i)) == TRIM(description)) THEN
277 24 : k = k + 1
278 24 : IF (PRESENT(nval)) THEN
279 24 : IF (k == nval) THEN
280 72 : values = RESHAPE(results%result_value(i)%value%real_type, (/SIZE(values, 1), SIZE(values, 2)/))
281 24 : EXIT
282 : END IF
283 : ELSE
284 : values((k - 1)*size_res + 1:k*size_res, :) = RESHAPE(results%result_value(i)%value%real_type, &
285 0 : (/SIZE(values, 1), SIZE(values, 2)/))
286 : END IF
287 : END IF
288 : END DO
289 :
290 24 : END SUBROUTINE get_result_r2
291 :
292 : ! **************************************************************************************************
293 : !> \brief gets the required part out of the result_list
294 : !> \param results ...
295 : !> \param description ...
296 : !> \param n_rep : integer indicating how many times the section exists in result_list
297 : !> \param n_entries : gets the number of lines used for a given description
298 : !> \param type_in_use ...
299 : !> \par History
300 : !> 12.2007 created
301 : !> 10.2008 Teodoro Laino [tlaino] - major rewriting
302 : !> \author fschiff
303 : ! **************************************************************************************************
304 2186 : SUBROUTINE get_nreps(results, description, n_rep, n_entries, type_in_use)
305 : TYPE(cp_result_type), POINTER :: results
306 : CHARACTER(LEN=default_string_length), INTENT(IN) :: description
307 : INTEGER, INTENT(OUT), OPTIONAL :: n_rep, n_entries, type_in_use
308 :
309 : INTEGER :: I, nlist
310 :
311 2186 : CPASSERT(ASSOCIATED(results))
312 2186 : nlist = SIZE(results%result_value)
313 2186 : CPASSERT(description(1:1) == '[')
314 2186 : CPASSERT(SIZE(results%result_label) == nlist)
315 2186 : IF (PRESENT(n_rep)) THEN
316 1292 : n_rep = 0
317 2561 : DO i = 1, nlist
318 2561 : IF (TRIM(results%result_label(i)) == TRIM(description)) n_rep = n_rep + 1
319 : END DO
320 : END IF
321 2186 : IF (PRESENT(n_entries)) THEN
322 894 : n_entries = 0
323 1080 : DO i = 1, nlist
324 1080 : IF (TRIM(results%result_label(i)) == TRIM(description)) THEN
325 1788 : SELECT CASE (results%result_value(i)%value%type_in_use)
326 : CASE (result_type_real)
327 894 : n_entries = n_entries + SIZE(results%result_value(i)%value%real_type)
328 : CASE (result_type_integer)
329 0 : n_entries = n_entries + SIZE(results%result_value(i)%value%integer_type)
330 : CASE (result_type_logical)
331 0 : n_entries = n_entries + SIZE(results%result_value(i)%value%logical_type)
332 : CASE DEFAULT
333 : ! Type not implemented in cp_result_type
334 894 : CPABORT("")
335 : END SELECT
336 : EXIT
337 : END IF
338 : END DO
339 : END IF
340 2186 : IF (PRESENT(type_in_use)) THEN
341 1080 : DO i = 1, nlist
342 1080 : IF (TRIM(results%result_label(i)) == TRIM(description)) THEN
343 894 : type_in_use = results%result_value(i)%value%type_in_use
344 894 : EXIT
345 : END IF
346 : END DO
347 : END IF
348 2186 : END SUBROUTINE get_nreps
349 :
350 : ! **************************************************************************************************
351 : !> \brief erase a part of result_list
352 : !> \param results ...
353 : !> \param description ...
354 : !> \param nval : if more than one entry for a given description is given you may choose
355 : !> which entry you want to delete
356 : !> \par History
357 : !> 12.2007 created
358 : !> 10.2008 Teodoro Laino [tlaino] - major rewriting
359 : !> \author fschiff
360 : ! **************************************************************************************************
361 33260 : SUBROUTINE cp_results_erase(results, description, nval)
362 : TYPE(cp_result_type), POINTER :: results
363 : CHARACTER(LEN=default_string_length), INTENT(IN), &
364 : OPTIONAL :: description
365 : INTEGER, INTENT(IN), OPTIONAL :: nval
366 :
367 : INTEGER :: entry_deleted, i, k, new_size, nlist, &
368 : nrep
369 : TYPE(cp_result_type), POINTER :: clean_results
370 :
371 33260 : CPASSERT(ASSOCIATED(results))
372 33260 : new_size = 0
373 33260 : IF (PRESENT(description)) THEN
374 32736 : CPASSERT(description(1:1) == '[')
375 32736 : nlist = SIZE(results%result_value)
376 32736 : nrep = 0
377 67334 : DO i = 1, nlist
378 67334 : IF (TRIM(results%result_label(i)) == TRIM(description)) nrep = nrep + 1
379 : END DO
380 32736 : IF (nrep .NE. 0) THEN
381 : k = 0
382 : entry_deleted = 0
383 58150 : DO i = 1, nlist
384 58150 : IF (TRIM(results%result_label(i)) == TRIM(description)) THEN
385 26086 : k = k + 1
386 26086 : IF (PRESENT(nval)) THEN
387 0 : IF (nval == k) THEN
388 0 : entry_deleted = entry_deleted + 1
389 0 : EXIT
390 : END IF
391 : ELSE
392 26086 : entry_deleted = entry_deleted + 1
393 : END IF
394 : END IF
395 : END DO
396 26086 : CPASSERT(nlist - entry_deleted >= 0)
397 26086 : new_size = nlist - entry_deleted
398 26086 : NULLIFY (clean_results)
399 26086 : CALL cp_result_create(clean_results)
400 26086 : CALL cp_result_clean(clean_results)
401 57400 : ALLOCATE (clean_results%result_label(new_size))
402 63378 : ALLOCATE (clean_results%result_value(new_size))
403 32064 : DO i = 1, new_size
404 5978 : NULLIFY (clean_results%result_value(i)%value)
405 32064 : CALL cp_result_value_create(clean_results%result_value(i)%value)
406 : END DO
407 : k = 0
408 58150 : DO i = 1, nlist
409 58150 : IF (TRIM(results%result_label(i)) /= TRIM(description)) THEN
410 5978 : k = k + 1
411 5978 : clean_results%result_label(k) = results%result_label(i)
412 : CALL cp_result_value_copy(clean_results%result_value(k)%value, &
413 5978 : results%result_value(i)%value)
414 : END IF
415 : END DO
416 26086 : CALL cp_result_copy(clean_results, results)
417 26086 : CALL cp_result_release(clean_results)
418 : END IF
419 : ELSE
420 524 : CALL cp_result_clean(results)
421 524 : ALLOCATE (results%result_label(new_size))
422 524 : ALLOCATE (results%result_value(new_size))
423 : END IF
424 33260 : END SUBROUTINE cp_results_erase
425 :
426 : ! **************************************************************************************************
427 : !> \brief broadcast results type
428 : !> \param results ...
429 : !> \param source ...
430 : !> \param para_env ...
431 : !> \author 10.2008 Teodoro Laino [tlaino] - University of Zurich
432 : ! **************************************************************************************************
433 11082 : SUBROUTINE cp_results_mp_bcast(results, source, para_env)
434 : TYPE(cp_result_type), POINTER :: results
435 : INTEGER, INTENT(IN) :: source
436 : TYPE(mp_para_env_type), POINTER :: para_env
437 :
438 : INTEGER :: i, nlist
439 11082 : INTEGER, ALLOCATABLE, DIMENSION(:) :: size_value, type_in_use
440 :
441 11082 : CPASSERT(ASSOCIATED(results))
442 11082 : nlist = 0
443 11082 : IF (para_env%mepos == source) nlist = SIZE(results%result_value)
444 11082 : CALL para_env%bcast(nlist, source)
445 :
446 23334 : ALLOCATE (size_value(nlist))
447 13422 : ALLOCATE (type_in_use(nlist))
448 11082 : IF (para_env%mepos == source) THEN
449 6670 : DO i = 1, nlist
450 : CALL get_nreps(results, description=results%result_label(i), &
451 6670 : n_entries=size_value(i), type_in_use=type_in_use(i))
452 : END DO
453 : END IF
454 11082 : CALL para_env%bcast(size_value, source)
455 11082 : CALL para_env%bcast(type_in_use, source)
456 :
457 11082 : IF (para_env%mepos /= source) THEN
458 5306 : CALL cp_result_clean(results)
459 11410 : ALLOCATE (results%result_value(nlist))
460 10996 : ALLOCATE (results%result_label(nlist))
461 5720 : DO i = 1, nlist
462 414 : results%result_label(i) = ""
463 414 : NULLIFY (results%result_value(i)%value)
464 414 : CALL cp_result_value_create(results%result_value(i)%value)
465 : CALL cp_result_value_init(results%result_value(i)%value, &
466 5720 : type_in_use=type_in_use(i), size_value=size_value(i))
467 : END DO
468 : END IF
469 12390 : DO i = 1, nlist
470 1308 : CALL para_env%bcast(results%result_label(i), source)
471 11082 : SELECT CASE (results%result_value(i)%value%type_in_use)
472 : CASE (result_type_real)
473 9124 : CALL para_env%bcast(results%result_value(i)%value%real_type, source)
474 : CASE (result_type_integer)
475 0 : CALL para_env%bcast(results%result_value(i)%value%integer_type, source)
476 : CASE (result_type_logical)
477 0 : CALL para_env%bcast(results%result_value(i)%value%logical_type, source)
478 : CASE DEFAULT
479 1308 : CPABORT("Type not implemented in cp_result_type")
480 : END SELECT
481 : END DO
482 11082 : DEALLOCATE (type_in_use)
483 11082 : DEALLOCATE (size_value)
484 11082 : END SUBROUTINE cp_results_mp_bcast
485 :
486 : END MODULE cp_result_methods
|
