Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2025 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 2 : PROGRAM memory_utilities_TEST
9 2 : USE kinds, ONLY: dp
10 : USE memory_utilities, ONLY: reallocate
11 :
12 : IMPLICIT NONE
13 :
14 2 : CALL check_real_rank1_allocated()
15 2 : CALL check_real_rank1_unallocated()
16 :
17 2 : CALL check_real_rank2_allocated()
18 2 : CALL check_real_rank2_unallocated()
19 :
20 2 : CALL check_string_rank1_allocated()
21 2 : CALL check_string_rank1_unallocated()
22 : CONTAINS
23 : ! **************************************************************************************************
24 : !> \brief Check that an allocated r1 array can be extended
25 : ! **************************************************************************************************
26 2 : SUBROUTINE check_real_rank1_allocated()
27 : INTEGER :: idx
28 : REAL(KIND=dp), DIMENSION(:), POINTER :: real_arr
29 :
30 2 : ALLOCATE (real_arr(10))
31 22 : real_arr = [(idx, idx=1, 10)]
32 :
33 2 : CALL reallocate(real_arr, 1, 20)
34 :
35 22 : IF (.NOT. ALL(real_arr(1:10) == [(idx, idx=1, 10)])) &
36 0 : ERROR STOP "check_real_rank1_allocated: reallocating changed the initial values"
37 :
38 22 : IF (.NOT. ALL(real_arr(11:20) == 0.)) &
39 0 : ERROR STOP "check_real_rank1_allocated: reallocation failed to initialise new values with 0."
40 :
41 2 : DEALLOCATE (real_arr)
42 :
43 2 : PRINT *, "check_real_rank1_allocated: OK"
44 2 : END SUBROUTINE check_real_rank1_allocated
45 :
46 : ! **************************************************************************************************
47 : !> \brief Check that an unallocated and unassociated (null) r1 array can be extended
48 : ! **************************************************************************************************
49 2 : SUBROUTINE check_real_rank1_unallocated()
50 2 : REAL(KIND=dp), DIMENSION(:), POINTER :: real_arr
51 :
52 2 : NULLIFY (real_arr)
53 :
54 2 : CALL reallocate(real_arr, 1, 20)
55 :
56 42 : IF (.NOT. ALL(real_arr(1:20) == 0.)) &
57 0 : ERROR STOP "check_real_rank1_unallocated: reallocation failed to initialise new values with 0."
58 :
59 2 : DEALLOCATE (real_arr)
60 :
61 2 : PRINT *, "check_real_rank1_unallocated: OK"
62 2 : END SUBROUTINE check_real_rank1_unallocated
63 :
64 : ! **************************************************************************************************
65 : !> \brief Check that an allocated r2 array can be extended
66 : ! **************************************************************************************************
67 2 : SUBROUTINE check_real_rank2_allocated()
68 : INTEGER :: idx
69 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: real_arr
70 :
71 2 : ALLOCATE (real_arr(5, 2))
72 26 : real_arr = RESHAPE([(idx, idx=1, 10)], [5, 2])
73 :
74 2 : CALL reallocate(real_arr, 1, 10, 1, 5)
75 :
76 22 : IF (.NOT. (ALL(real_arr(1:5, 1) == [(idx, idx=1, 5)]) .AND. ALL(real_arr(1:5, 2) == [(idx, idx=6, 10)]))) &
77 0 : ERROR STOP "check_real_rank2_allocated: reallocating changed the initial values"
78 :
79 94 : IF (.NOT. (ALL(real_arr(6:10, 1:2) == 0.) .AND. ALL(real_arr(1:10, 3:5) == 0.))) &
80 0 : ERROR STOP "check_real_rank2_allocated: reallocation failed to initialise new values with 0."
81 :
82 2 : DEALLOCATE (real_arr)
83 :
84 2 : PRINT *, "check_real_rank1_allocated: OK"
85 2 : END SUBROUTINE check_real_rank2_allocated
86 :
87 : ! **************************************************************************************************
88 : !> \brief Check that an unallocated and unassociated (null) r2 array can be extended
89 : ! **************************************************************************************************
90 2 : SUBROUTINE check_real_rank2_unallocated()
91 2 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: real_arr
92 :
93 2 : NULLIFY (real_arr)
94 :
95 2 : CALL reallocate(real_arr, 1, 10, 1, 5)
96 :
97 112 : IF (.NOT. ALL(real_arr(1:10, 1:5) == 0.)) &
98 0 : ERROR STOP "check_real_rank2_unallocated: reallocation failed to initialise new values with 0."
99 :
100 2 : DEALLOCATE (real_arr)
101 :
102 2 : PRINT *, "check_real_rank2_unallocated: OK"
103 2 : END SUBROUTINE check_real_rank2_unallocated
104 :
105 : ! **************************************************************************************************
106 : !> \brief Check that an allocated string array can be extended
107 : ! **************************************************************************************************
108 2 : SUBROUTINE check_string_rank1_allocated()
109 : CHARACTER(LEN=12), DIMENSION(:), POINTER :: str_arr
110 : INTEGER :: idx
111 :
112 2 : ALLOCATE (str_arr(10))
113 22 : str_arr = [("hello, there", idx=1, 10)]
114 :
115 2 : CALL reallocate(str_arr, 1, 20)
116 :
117 22 : IF (.NOT. ALL(str_arr(1:10) == [("hello, there", idx=1, 10)])) &
118 0 : ERROR STOP "check_string_rank1_allocated: reallocating changed the initial values"
119 :
120 22 : IF (.NOT. ALL(str_arr(11:20) == "")) &
121 0 : ERROR STOP "check_string_rank1_allocated: reallocation failed to initialise new values with ''."
122 :
123 2 : DEALLOCATE (str_arr)
124 :
125 2 : PRINT *, "check_string_rank1_allocated: OK"
126 2 : END SUBROUTINE check_string_rank1_allocated
127 :
128 : ! **************************************************************************************************
129 : !> \brief Check that an unallocated string array can be extended
130 : ! **************************************************************************************************
131 2 : SUBROUTINE check_string_rank1_unallocated()
132 2 : CHARACTER(LEN=12), DIMENSION(:), POINTER :: str_arr
133 :
134 2 : NULLIFY (str_arr)
135 :
136 2 : CALL reallocate(str_arr, 1, 20)
137 :
138 42 : IF (.NOT. ALL(str_arr(1:20) == "")) &
139 0 : ERROR STOP "check_string_rank1_allocated: reallocation failed to initialise new values with ''."
140 :
141 2 : DEALLOCATE (str_arr)
142 :
143 2 : PRINT *, "check_string_rank1_unallocated: OK"
144 2 : END SUBROUTINE check_string_rank1_unallocated
145 :
146 : END PROGRAM memory_utilities_TEST
147 : ! vim: set ts=3 sw=3 tw=132 :
|
