Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2026 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)])) THEN
36 0 : ERROR STOP "check_real_rank1_allocated: reallocating changed the initial values"
37 : END IF
38 :
39 22 : IF (.NOT. ALL(real_arr(11:20) == 0.)) THEN
40 0 : ERROR STOP "check_real_rank1_allocated: reallocation failed to initialise new values with 0."
41 : END IF
42 :
43 2 : DEALLOCATE (real_arr)
44 :
45 2 : PRINT *, "check_real_rank1_allocated: OK"
46 2 : END SUBROUTINE check_real_rank1_allocated
47 :
48 : ! **************************************************************************************************
49 : !> \brief Check that an unallocated and unassociated (null) r1 array can be extended
50 : ! **************************************************************************************************
51 2 : SUBROUTINE check_real_rank1_unallocated()
52 2 : REAL(KIND=dp), DIMENSION(:), POINTER :: real_arr
53 :
54 2 : NULLIFY (real_arr)
55 :
56 2 : CALL reallocate(real_arr, 1, 20)
57 :
58 42 : IF (.NOT. ALL(real_arr(1:20) == 0.)) THEN
59 0 : ERROR STOP "check_real_rank1_unallocated: reallocation failed to initialise new values with 0."
60 : END IF
61 :
62 2 : DEALLOCATE (real_arr)
63 :
64 2 : PRINT *, "check_real_rank1_unallocated: OK"
65 2 : END SUBROUTINE check_real_rank1_unallocated
66 :
67 : ! **************************************************************************************************
68 : !> \brief Check that an allocated r2 array can be extended
69 : ! **************************************************************************************************
70 2 : SUBROUTINE check_real_rank2_allocated()
71 : INTEGER :: idx
72 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: real_arr
73 :
74 2 : ALLOCATE (real_arr(5, 2))
75 26 : real_arr = RESHAPE([(idx, idx=1, 10)], [5, 2])
76 :
77 2 : CALL reallocate(real_arr, 1, 10, 1, 5)
78 :
79 22 : IF (.NOT. (ALL(real_arr(1:5, 1) == [(idx, idx=1, 5)]) .AND. ALL(real_arr(1:5, 2) == [(idx, idx=6, 10)]))) THEN
80 0 : ERROR STOP "check_real_rank2_allocated: reallocating changed the initial values"
81 : END IF
82 :
83 94 : IF (.NOT. (ALL(real_arr(6:10, 1:2) == 0.) .AND. ALL(real_arr(1:10, 3:5) == 0.))) THEN
84 0 : ERROR STOP "check_real_rank2_allocated: reallocation failed to initialise new values with 0."
85 : END IF
86 :
87 2 : DEALLOCATE (real_arr)
88 :
89 2 : PRINT *, "check_real_rank1_allocated: OK"
90 2 : END SUBROUTINE check_real_rank2_allocated
91 :
92 : ! **************************************************************************************************
93 : !> \brief Check that an unallocated and unassociated (null) r2 array can be extended
94 : ! **************************************************************************************************
95 2 : SUBROUTINE check_real_rank2_unallocated()
96 2 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: real_arr
97 :
98 2 : NULLIFY (real_arr)
99 :
100 2 : CALL reallocate(real_arr, 1, 10, 1, 5)
101 :
102 112 : IF (.NOT. ALL(real_arr(1:10, 1:5) == 0.)) THEN
103 0 : ERROR STOP "check_real_rank2_unallocated: reallocation failed to initialise new values with 0."
104 : END IF
105 :
106 2 : DEALLOCATE (real_arr)
107 :
108 2 : PRINT *, "check_real_rank2_unallocated: OK"
109 2 : END SUBROUTINE check_real_rank2_unallocated
110 :
111 : ! **************************************************************************************************
112 : !> \brief Check that an allocated string array can be extended
113 : ! **************************************************************************************************
114 2 : SUBROUTINE check_string_rank1_allocated()
115 : CHARACTER(LEN=12), DIMENSION(:), POINTER :: str_arr
116 : INTEGER :: idx
117 :
118 2 : ALLOCATE (str_arr(10))
119 22 : str_arr = [("hello, there", idx=1, 10)]
120 :
121 2 : CALL reallocate(str_arr, 1, 20)
122 :
123 22 : IF (.NOT. ALL(str_arr(1:10) == [("hello, there", idx=1, 10)])) THEN
124 0 : ERROR STOP "check_string_rank1_allocated: reallocating changed the initial values"
125 : END IF
126 :
127 22 : IF (.NOT. ALL(str_arr(11:20) == "")) THEN
128 0 : ERROR STOP "check_string_rank1_allocated: reallocation failed to initialise new values with ''."
129 : END IF
130 :
131 2 : DEALLOCATE (str_arr)
132 :
133 2 : PRINT *, "check_string_rank1_allocated: OK"
134 2 : END SUBROUTINE check_string_rank1_allocated
135 :
136 : ! **************************************************************************************************
137 : !> \brief Check that an unallocated string array can be extended
138 : ! **************************************************************************************************
139 2 : SUBROUTINE check_string_rank1_unallocated()
140 2 : CHARACTER(LEN=12), DIMENSION(:), POINTER :: str_arr
141 :
142 2 : NULLIFY (str_arr)
143 :
144 2 : CALL reallocate(str_arr, 1, 20)
145 :
146 42 : IF (.NOT. ALL(str_arr(1:20) == "")) THEN
147 0 : ERROR STOP "check_string_rank1_allocated: reallocation failed to initialise new values with ''."
148 : END IF
149 :
150 2 : DEALLOCATE (str_arr)
151 :
152 2 : PRINT *, "check_string_rank1_unallocated: OK"
153 2 : END SUBROUTINE check_string_rank1_unallocated
154 :
155 : END PROGRAM memory_utilities_TEST
156 : ! vim: set ts=3 sw=3 tw=132 :
|
