(git:e7e05ae)
cp_result_methods.F
Go to the documentation of this file.
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  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  cpassert(ASSOCIATED(results))
68  cpassert(description(1:1) == '[')
69  check = SIZE(results%result_label) == SIZE(results%result_value)
70  cpassert(check)
71  isize = SIZE(results%result_label)
72  jsize = SIZE(values)
73 
74  CALL reallocate(results%result_label, 1, isize + 1)
75  CALL cp_result_value_p_reallocate(results%result_value, 1, isize + 1)
76 
77  results%result_label(isize + 1) = description
78  CALL cp_result_value_init(results%result_value(isize + 1)%value, result_type_real, jsize)
79  results%result_value(isize + 1)%value%real_type = values
80 
81  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  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  cpassert(ASSOCIATED(results))
102  cpassert(description(1:1) == '[')
103  check = SIZE(results%result_label) == SIZE(results%result_value)
104  cpassert(check)
105  isize = SIZE(results%result_label)
106  jsize = SIZE(values, 1)*SIZE(values, 2)
107 
108  CALL reallocate(results%result_label, 1, isize + 1)
109  CALL cp_result_value_p_reallocate(results%result_value, 1, isize + 1)
110 
111  results%result_label(isize + 1) = description
112  CALL cp_result_value_init(results%result_value(isize + 1)%value, result_type_real, jsize)
113  results%result_value(isize + 1)%value%real_type = reshape(values, (/jsize/))
114 
115  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  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  cpassert(ASSOCIATED(results))
134  nlist = SIZE(results%result_value)
135  res_exist = .false.
136  DO i = 1, nlist
137  IF (trim(results%result_label(i)) == trim(description)) THEN
138  res_exist = .true.
139  EXIT
140  END IF
141  END DO
142 
143  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  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  cpassert(ASSOCIATED(results))
169  nlist = SIZE(results%result_value)
170  cpassert(description(1:1) == '[')
171  cpassert(SIZE(results%result_label) == nlist)
172  nrep = 0
173  DO i = 1, nlist
174  IF (trim(results%result_label(i)) == trim(description)) nrep = nrep + 1
175  END DO
176 
177  IF (PRESENT(n_rep)) THEN
178  n_rep = nrep
179  END IF
180 
181  IF (nrep .LE. 0) &
182  CALL cp_abort(__location__, &
183  " Trying to access result ("//trim(description)//") which was never stored!")
184 
185  DO i = 1, nlist
186  IF (trim(results%result_label(i)) == trim(description)) THEN
187  IF (results%result_value(i)%value%type_in_use /= result_type_real) &
188  cpabort("Attempt to retrieve a RESULT which is not a REAL!")
189 
190  size_res = SIZE(results%result_value(i)%value%real_type)
191  EXIT
192  END IF
193  END DO
194  IF (PRESENT(n_entries)) n_entries = size_res
195  size_values = SIZE(values, 1)
196  IF (PRESENT(nval)) THEN
197  cpassert(size_res == size_values)
198  ELSE
199  cpassert(nrep*size_res == size_values)
200  END IF
201  k = 0
202  DO i = 1, nlist
203  IF (trim(results%result_label(i)) == trim(description)) THEN
204  k = k + 1
205  IF (PRESENT(nval)) THEN
206  IF (k == nval) THEN
207  values = results%result_value(i)%value%real_type
208  EXIT
209  END IF
210  ELSE
211  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  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  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  cpassert(ASSOCIATED(results))
242  nlist = SIZE(results%result_value)
243  cpassert(description(1:1) == '[')
244  cpassert(SIZE(results%result_label) == nlist)
245  nrep = 0
246  DO i = 1, nlist
247  IF (trim(results%result_label(i)) == trim(description)) nrep = nrep + 1
248  END DO
249 
250  IF (PRESENT(n_rep)) THEN
251  n_rep = nrep
252  END IF
253 
254  IF (nrep .LE. 0) &
255  CALL cp_abort(__location__, &
256  " Trying to access result ("//trim(description)//") which was never stored!")
257 
258  DO i = 1, nlist
259  IF (trim(results%result_label(i)) == trim(description)) THEN
260  IF (results%result_value(i)%value%type_in_use /= result_type_real) &
261  cpabort("Attempt to retrieve a RESULT which is not a REAL!")
262 
263  size_res = SIZE(results%result_value(i)%value%real_type)
264  EXIT
265  END IF
266  END DO
267  IF (PRESENT(n_entries)) n_entries = size_res
268  size_values = SIZE(values, 1)*SIZE(values, 2)
269  IF (PRESENT(nval)) THEN
270  cpassert(size_res == size_values)
271  ELSE
272  cpassert(nrep*size_res == size_values)
273  END IF
274  k = 0
275  DO i = 1, nlist
276  IF (trim(results%result_label(i)) == trim(description)) THEN
277  k = k + 1
278  IF (PRESENT(nval)) THEN
279  IF (k == nval) THEN
280  values = reshape(results%result_value(i)%value%real_type, (/SIZE(values, 1), SIZE(values, 2)/))
281  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  (/SIZE(values, 1), SIZE(values, 2)/))
286  END IF
287  END IF
288  END DO
289 
290  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  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  cpassert(ASSOCIATED(results))
312  nlist = SIZE(results%result_value)
313  cpassert(description(1:1) == '[')
314  cpassert(SIZE(results%result_label) == nlist)
315  IF (PRESENT(n_rep)) THEN
316  n_rep = 0
317  DO i = 1, nlist
318  IF (trim(results%result_label(i)) == trim(description)) n_rep = n_rep + 1
319  END DO
320  END IF
321  IF (PRESENT(n_entries)) THEN
322  n_entries = 0
323  DO i = 1, nlist
324  IF (trim(results%result_label(i)) == trim(description)) THEN
325  SELECT CASE (results%result_value(i)%value%type_in_use)
326  CASE (result_type_real)
327  n_entries = n_entries + SIZE(results%result_value(i)%value%real_type)
328  CASE (result_type_integer)
329  n_entries = n_entries + SIZE(results%result_value(i)%value%integer_type)
330  CASE (result_type_logical)
331  n_entries = n_entries + SIZE(results%result_value(i)%value%logical_type)
332  CASE DEFAULT
333  ! Type not implemented in cp_result_type
334  cpabort("")
335  END SELECT
336  EXIT
337  END IF
338  END DO
339  END IF
340  IF (PRESENT(type_in_use)) THEN
341  DO i = 1, nlist
342  IF (trim(results%result_label(i)) == trim(description)) THEN
343  type_in_use = results%result_value(i)%value%type_in_use
344  EXIT
345  END IF
346  END DO
347  END IF
348  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  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  cpassert(ASSOCIATED(results))
372  new_size = 0
373  IF (PRESENT(description)) THEN
374  cpassert(description(1:1) == '[')
375  nlist = SIZE(results%result_value)
376  nrep = 0
377  DO i = 1, nlist
378  IF (trim(results%result_label(i)) == trim(description)) nrep = nrep + 1
379  END DO
380  IF (nrep .NE. 0) THEN
381  k = 0
382  entry_deleted = 0
383  DO i = 1, nlist
384  IF (trim(results%result_label(i)) == trim(description)) THEN
385  k = k + 1
386  IF (PRESENT(nval)) THEN
387  IF (nval == k) THEN
388  entry_deleted = entry_deleted + 1
389  EXIT
390  END IF
391  ELSE
392  entry_deleted = entry_deleted + 1
393  END IF
394  END IF
395  END DO
396  cpassert(nlist - entry_deleted >= 0)
397  new_size = nlist - entry_deleted
398  NULLIFY (clean_results)
399  CALL cp_result_create(clean_results)
400  CALL cp_result_clean(clean_results)
401  ALLOCATE (clean_results%result_label(new_size))
402  ALLOCATE (clean_results%result_value(new_size))
403  DO i = 1, new_size
404  NULLIFY (clean_results%result_value(i)%value)
405  CALL cp_result_value_create(clean_results%result_value(i)%value)
406  END DO
407  k = 0
408  DO i = 1, nlist
409  IF (trim(results%result_label(i)) /= trim(description)) THEN
410  k = k + 1
411  clean_results%result_label(k) = results%result_label(i)
412  CALL cp_result_value_copy(clean_results%result_value(k)%value, &
413  results%result_value(i)%value)
414  END IF
415  END DO
416  CALL cp_result_copy(clean_results, results)
417  CALL cp_result_release(clean_results)
418  END IF
419  ELSE
420  CALL cp_result_clean(results)
421  ALLOCATE (results%result_label(new_size))
422  ALLOCATE (results%result_value(new_size))
423  END IF
424  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  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  INTEGER, ALLOCATABLE, DIMENSION(:) :: size_value, type_in_use
440 
441  cpassert(ASSOCIATED(results))
442  nlist = 0
443  IF (para_env%mepos == source) nlist = SIZE(results%result_value)
444  CALL para_env%bcast(nlist, source)
445 
446  ALLOCATE (size_value(nlist))
447  ALLOCATE (type_in_use(nlist))
448  IF (para_env%mepos == source) THEN
449  DO i = 1, nlist
450  CALL get_nreps(results, description=results%result_label(i), &
451  n_entries=size_value(i), type_in_use=type_in_use(i))
452  END DO
453  END IF
454  CALL para_env%bcast(size_value, source)
455  CALL para_env%bcast(type_in_use, source)
456 
457  IF (para_env%mepos /= source) THEN
458  CALL cp_result_clean(results)
459  ALLOCATE (results%result_value(nlist))
460  ALLOCATE (results%result_label(nlist))
461  DO i = 1, nlist
462  results%result_label(i) = ""
463  NULLIFY (results%result_value(i)%value)
464  CALL cp_result_value_create(results%result_value(i)%value)
465  CALL cp_result_value_init(results%result_value(i)%value, &
466  type_in_use=type_in_use(i), size_value=size_value(i))
467  END DO
468  END IF
469  DO i = 1, nlist
470  CALL para_env%bcast(results%result_label(i), source)
471  SELECT CASE (results%result_value(i)%value%type_in_use)
472  CASE (result_type_real)
473  CALL para_env%bcast(results%result_value(i)%value%real_type, source)
474  CASE (result_type_integer)
475  CALL para_env%bcast(results%result_value(i)%value%integer_type, source)
476  CASE (result_type_logical)
477  CALL para_env%bcast(results%result_value(i)%value%logical_type, source)
478  CASE DEFAULT
479  cpabort("Type not implemented in cp_result_type")
480  END SELECT
481  END DO
482  DEALLOCATE (type_in_use)
483  DEALLOCATE (size_value)
484  END SUBROUTINE cp_results_mp_bcast
485 
486 END MODULE cp_result_methods
cp_result_methods
set of type/routines to handle the storage of results in force_envs
Definition: cp_result_methods.F:17
cp_result_methods::cp_results_mp_bcast
subroutine, public cp_results_mp_bcast(results, source, para_env)
broadcast results type
Definition: cp_result_methods.F:434
cp_result_methods::cp_results_erase
subroutine, public cp_results_erase(results, description, nval)
erase a part of result_list
Definition: cp_result_methods.F:362
cp_result_methods::test_for_result
logical function, public test_for_result(results, description)
test for a certain result in the result_list
Definition: cp_result_methods.F:127
cp_result_types
set of type/routines to handle the storage of results in force_envs
Definition: cp_result_types.F:18
cp_result_types::result_type_real
integer, parameter, public result_type_real
Definition: cp_result_types.F:30
cp_result_types::cp_result_copy
subroutine, public cp_result_copy(results_in, results_out)
Copies the cp_result type.
Definition: cp_result_types.F:286
cp_result_types::result_type_logical
integer, parameter, public result_type_logical
Definition: cp_result_types.F:30
cp_result_types::cp_result_release
subroutine, public cp_result_release(results)
Releases cp_result type.
Definition: cp_result_types.F:120
cp_result_types::cp_result_value_create
subroutine, public cp_result_value_create(value)
Allocates and intitializes the cp_result_value type.
Definition: cp_result_types.F:195
cp_result_types::cp_result_clean
subroutine, public cp_result_clean(results)
Releases cp_result clean.
Definition: cp_result_types.F:154
cp_result_types::result_type_integer
integer, parameter, public result_type_integer
Definition: cp_result_types.F:30
cp_result_types::cp_result_create
subroutine, public cp_result_create(results)
Allocates and intitializes the cp_result.
Definition: cp_result_types.F:96
cp_result_types::cp_result_value_p_reallocate
subroutine, public cp_result_value_p_reallocate(result_value, istart, iend)
Reallocates the cp_result_value type.
Definition: cp_result_types.F:353
cp_result_types::cp_result_value_copy
subroutine, public cp_result_value_copy(value_out, value_in)
Copies the cp_result_value type.
Definition: cp_result_types.F:317
cp_result_types::cp_result_value_init
subroutine, public cp_result_value_init(value, type_in_use, size_value)
Setup of the cp_result_value type.
Definition: cp_result_types.F:214
kinds
Defines the basic variable types.
Definition: kinds.F:23
kinds::dp
integer, parameter, public dp
Definition: kinds.F:34
kinds::default_string_length
integer, parameter, public default_string_length
Definition: kinds.F:57
memory_utilities
Utility routines for the memory handling.
Definition: memory_utilities.F:14
message_passing
Interface to the message passing library MPI.
Definition: message_passing.F:23