]>
Commit | Line | Data |
---|---|---|
3666a048 | 1 | ! Copyright 2019-2021 Free Software Foundation, Inc. |
5bbd8269 AB |
2 | ! |
3 | ! This program is free software; you can redistribute it and/or modify | |
4 | ! it under the terms of the GNU General Public License as published by | |
5 | ! the Free Software Foundation; either version 3 of the License, or | |
6 | ! (at your option) any later version. | |
7 | ! | |
8 | ! This program is distributed in the hope that it will be useful, | |
9 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | ! GNU General Public License for more details. | |
12 | ! | |
13 | ! You should have received a copy of the GNU General Public License | |
14 | ! along with this program. If not, see <http://www.gnu.org/licenses/>. | |
15 | ||
a5c641b5 AB |
16 | subroutine show_elem (array) |
17 | integer :: array | |
18 | ||
19 | print *, "" | |
20 | print *, "Expected GDB Output:" | |
21 | print *, "" | |
22 | ||
23 | write(*, fmt="(A)", advance="no") "GDB = " | |
24 | write(*, fmt="(I0)", advance="no") array | |
25 | write(*, fmt="(A)", advance="yes") "" | |
26 | ||
27 | print *, "" ! Display Element | |
28 | end subroutine show_elem | |
29 | ||
30 | subroutine show_str (array) | |
31 | character (len=*) :: array | |
32 | ||
33 | print *, "" | |
34 | print *, "Expected GDB Output:" | |
35 | print *, "" | |
36 | write (*, fmt="(A)", advance="no") "GDB = '" | |
37 | write (*, fmt="(A)", advance="no") array | |
38 | write (*, fmt="(A)", advance="yes") "'" | |
39 | ||
40 | print *, "" ! Display String | |
41 | end subroutine show_str | |
42 | ||
43 | subroutine show_1d (array) | |
44 | integer, dimension (:) :: array | |
45 | ||
46 | print *, "Array Contents:" | |
47 | print *, "" | |
48 | ||
49 | do i=LBOUND (array, 1), UBOUND (array, 1), 1 | |
50 | write(*, fmt="(i4)", advance="no") array (i) | |
51 | end do | |
52 | ||
53 | print *, "" | |
54 | print *, "Expected GDB Output:" | |
55 | print *, "" | |
56 | ||
57 | write(*, fmt="(A)", advance="no") "GDB = (" | |
58 | do i=LBOUND (array, 1), UBOUND (array, 1), 1 | |
59 | if (i > LBOUND (array, 1)) then | |
60 | write(*, fmt="(A)", advance="no") ", " | |
61 | end if | |
62 | write(*, fmt="(I0)", advance="no") array (i) | |
63 | end do | |
64 | write(*, fmt="(A)", advance="no") ")" | |
65 | ||
66 | print *, "" ! Display Array Slice 1D | |
67 | end subroutine show_1d | |
68 | ||
69 | subroutine show_2d (array) | |
5bbd8269 AB |
70 | integer, dimension (:,:) :: array |
71 | ||
a5c641b5 AB |
72 | print *, "Array Contents:" |
73 | print *, "" | |
74 | ||
5bbd8269 AB |
75 | do i=LBOUND (array, 2), UBOUND (array, 2), 1 |
76 | do j=LBOUND (array, 1), UBOUND (array, 1), 1 | |
77 | write(*, fmt="(i4)", advance="no") array (j, i) | |
78 | end do | |
79 | print *, "" | |
a5c641b5 | 80 | end do |
5bbd8269 | 81 | |
a5c641b5 AB |
82 | print *, "" |
83 | print *, "Expected GDB Output:" | |
84 | print *, "" | |
5bbd8269 | 85 | |
a5c641b5 AB |
86 | write(*, fmt="(A)", advance="no") "GDB = (" |
87 | do i=LBOUND (array, 2), UBOUND (array, 2), 1 | |
88 | if (i > LBOUND (array, 2)) then | |
89 | write(*, fmt="(A)", advance="no") " " | |
90 | end if | |
91 | write(*, fmt="(A)", advance="no") "(" | |
92 | do j=LBOUND (array, 1), UBOUND (array, 1), 1 | |
93 | if (j > LBOUND (array, 1)) then | |
94 | write(*, fmt="(A)", advance="no") ", " | |
95 | end if | |
96 | write(*, fmt="(I0)", advance="no") array (j, i) | |
97 | end do | |
98 | write(*, fmt="(A)", advance="no") ")" | |
99 | end do | |
100 | write(*, fmt="(A)", advance="yes") ")" | |
101 | ||
102 | print *, "" ! Display Array Slice 2D | |
103 | end subroutine show_2d | |
104 | ||
105 | subroutine show_3d (array) | |
106 | integer, dimension (:,:,:) :: array | |
107 | ||
108 | print *, "" | |
109 | print *, "Expected GDB Output:" | |
110 | print *, "" | |
111 | ||
112 | write(*, fmt="(A)", advance="no") "GDB = (" | |
113 | do i=LBOUND (array, 3), UBOUND (array, 3), 1 | |
114 | if (i > LBOUND (array, 3)) then | |
115 | write(*, fmt="(A)", advance="no") " " | |
116 | end if | |
117 | write(*, fmt="(A)", advance="no") "(" | |
118 | do j=LBOUND (array, 2), UBOUND (array, 2), 1 | |
119 | if (j > LBOUND (array, 2)) then | |
120 | write(*, fmt="(A)", advance="no") " " | |
121 | end if | |
122 | write(*, fmt="(A)", advance="no") "(" | |
123 | do k=LBOUND (array, 1), UBOUND (array, 1), 1 | |
124 | if (k > LBOUND (array, 1)) then | |
125 | write(*, fmt="(A)", advance="no") ", " | |
126 | end if | |
127 | write(*, fmt="(I0)", advance="no") array (k, j, i) | |
128 | end do | |
129 | write(*, fmt="(A)", advance="no") ")" | |
130 | end do | |
131 | write(*, fmt="(A)", advance="no") ")" | |
132 | end do | |
133 | write(*, fmt="(A)", advance="yes") ")" | |
134 | ||
135 | print *, "" ! Display Array Slice 3D | |
136 | end subroutine show_3d | |
137 | ||
138 | subroutine show_4d (array) | |
139 | integer, dimension (:,:,:,:) :: array | |
140 | ||
141 | print *, "" | |
142 | print *, "Expected GDB Output:" | |
143 | print *, "" | |
144 | ||
145 | write(*, fmt="(A)", advance="no") "GDB = (" | |
146 | do i=LBOUND (array, 4), UBOUND (array, 4), 1 | |
147 | if (i > LBOUND (array, 4)) then | |
148 | write(*, fmt="(A)", advance="no") " " | |
149 | end if | |
150 | write(*, fmt="(A)", advance="no") "(" | |
151 | do j=LBOUND (array, 3), UBOUND (array, 3), 1 | |
152 | if (j > LBOUND (array, 3)) then | |
153 | write(*, fmt="(A)", advance="no") " " | |
154 | end if | |
155 | write(*, fmt="(A)", advance="no") "(" | |
156 | ||
157 | do k=LBOUND (array, 2), UBOUND (array, 2), 1 | |
158 | if (k > LBOUND (array, 2)) then | |
159 | write(*, fmt="(A)", advance="no") " " | |
160 | end if | |
161 | write(*, fmt="(A)", advance="no") "(" | |
162 | do l=LBOUND (array, 1), UBOUND (array, 1), 1 | |
163 | if (l > LBOUND (array, 1)) then | |
164 | write(*, fmt="(A)", advance="no") ", " | |
165 | end if | |
166 | write(*, fmt="(I0)", advance="no") array (l, k, j, i) | |
167 | end do | |
168 | write(*, fmt="(A)", advance="no") ")" | |
169 | end do | |
170 | write(*, fmt="(A)", advance="no") ")" | |
171 | end do | |
172 | write(*, fmt="(A)", advance="no") ")" | |
173 | end do | |
174 | write(*, fmt="(A)", advance="yes") ")" | |
175 | ||
176 | print *, "" ! Display Array Slice 4D | |
177 | end subroutine show_4d | |
5bbd8269 | 178 | |
a5c641b5 AB |
179 | ! |
180 | ! Start of test program. | |
181 | ! | |
182 | program test | |
5bbd8269 | 183 | interface |
a5c641b5 AB |
184 | subroutine show_str (array) |
185 | character (len=*) :: array | |
186 | end subroutine show_str | |
187 | ||
188 | subroutine show_1d (array) | |
189 | integer, dimension (:) :: array | |
190 | end subroutine show_1d | |
191 | ||
192 | subroutine show_2d (array) | |
5bbd8269 | 193 | integer, dimension(:,:) :: array |
a5c641b5 AB |
194 | end subroutine show_2d |
195 | ||
196 | subroutine show_3d (array) | |
197 | integer, dimension(:,:,:) :: array | |
198 | end subroutine show_3d | |
199 | ||
200 | subroutine show_4d (array) | |
201 | integer, dimension(:,:,:,:) :: array | |
202 | end subroutine show_4d | |
5bbd8269 AB |
203 | end interface |
204 | ||
a5c641b5 AB |
205 | ! Declare variables used in this test. |
206 | integer, dimension (-10:-1,-10:-2) :: neg_array | |
5bbd8269 AB |
207 | integer, dimension (1:10,1:10) :: array |
208 | integer, allocatable :: other (:, :) | |
a5c641b5 AB |
209 | character (len=26) :: str_1 = "abcdefghijklmnopqrstuvwxyz" |
210 | integer, dimension (-2:2,-2:2,-2:2) :: array3d | |
211 | integer, dimension (-3:3,7:10,-3:3,-10:-7) :: array4d | |
212 | integer, dimension (10:20) :: array1d | |
213 | integer, dimension(:,:), pointer :: pointer2d => null() | |
214 | integer, dimension(-1:9,-1:9), target :: tarray | |
5bbd8269 | 215 | |
a5c641b5 | 216 | ! Allocate or associate any variables as needed. |
5bbd8269 | 217 | allocate (other (-5:4, -2:7)) |
a5c641b5 | 218 | pointer2d => tarray |
5bbd8269 | 219 | |
a5c641b5 AB |
220 | ! Fill arrays with contents ready for testing. |
221 | call fill_array_1d (array1d) | |
222 | ||
223 | call fill_array_2d (neg_array) | |
224 | call fill_array_2d (array) | |
225 | call fill_array_2d (other) | |
226 | call fill_array_2d (tarray) | |
227 | ||
228 | call fill_array_3d (array3d) | |
229 | call fill_array_4d (array4d) | |
230 | ||
231 | ! The tests. Each call to a show_* function must have a unique set | |
232 | ! of arguments as GDB uses the arguments are part of the test name | |
233 | ! string, so duplicate arguments will result in duplicate test | |
234 | ! names. | |
235 | ! | |
236 | ! If a show_* line ends with VARS=... where '...' is a comma | |
237 | ! separated list of variable names, these variables are assumed to | |
238 | ! be part of the call line, and will be expanded by the test script, | |
239 | ! for example: | |
240 | ! | |
241 | ! do x=1,9,1 | |
242 | ! do y=x,10,1 | |
243 | ! call show_1d (some_array (x,y)) ! VARS=x,y | |
244 | ! end do | |
245 | ! end do | |
246 | ! | |
247 | ! In this example the test script will automatically expand 'x' and | |
248 | ! 'y' in order to better test different aspects of GDB. Do take | |
249 | ! care, the expansion is not very "smart", so try to avoid clashing | |
250 | ! with other text on the line, in the example above, avoid variables | |
251 | ! named 'some' or 'array', as these will likely clash with | |
252 | ! 'some_array'. | |
253 | call show_str (str_1) | |
254 | call show_str (str_1 (1:20)) | |
255 | call show_str (str_1 (10:20)) | |
5bbd8269 | 256 | |
a5c641b5 AB |
257 | call show_elem (array1d (11)) |
258 | call show_elem (pointer2d (2,3)) | |
259 | ||
260 | call show_1d (array1d) | |
261 | call show_1d (array1d (13:17)) | |
262 | call show_1d (array1d (17:13:-1)) | |
263 | call show_1d (array (1:5,1)) | |
264 | call show_1d (array4d (1,7,3,:)) | |
265 | call show_1d (pointer2d (-1:3, 2)) | |
266 | call show_1d (pointer2d (-1, 2:4)) | |
267 | ||
268 | ! Enclosing the array slice argument in (...) causess gfortran to | |
269 | ! repack the array. | |
270 | call show_1d ((array (1:5,1))) | |
271 | ||
272 | call show_2d (pointer2d) | |
273 | call show_2d (array) | |
274 | call show_2d (array (1:5,1:5)) | |
275 | do i=1,10,2 | |
276 | do j=1,10,3 | |
277 | call show_2d (array (1:10:i,1:10:j)) ! VARS=i,j | |
278 | call show_2d (array (10:1:-i,1:10:j)) ! VARS=i,j | |
279 | call show_2d (array (10:1:-i,10:1:-j)) ! VARS=i,j | |
280 | call show_2d (array (1:10:i,10:1:-j)) ! VARS=i,j | |
5bbd8269 AB |
281 | end do |
282 | end do | |
a5c641b5 AB |
283 | call show_2d (array (6:2:-1,3:9)) |
284 | call show_2d (array (1:10:2, 1:10:2)) | |
285 | call show_2d (other) | |
286 | call show_2d (other (-5:0, -2:0)) | |
287 | call show_2d (other (-5:4:2, -2:7:3)) | |
288 | call show_2d (neg_array) | |
289 | call show_2d (neg_array (-10:-3,-8:-4:2)) | |
290 | ||
291 | ! Enclosing the array slice argument in (...) causess gfortran to | |
292 | ! repack the array. | |
293 | call show_2d ((array (1:10:3, 1:10:2))) | |
294 | call show_2d ((neg_array (-10:-3,-8:-4:2))) | |
5bbd8269 | 295 | |
a5c641b5 AB |
296 | call show_3d (array3d) |
297 | call show_3d (array3d(-1:1,-1:1,-1:1)) | |
298 | call show_3d (array3d(1:-1:-1,1:-1:-1,1:-1:-1)) | |
5bbd8269 | 299 | |
a5c641b5 AB |
300 | ! Enclosing the array slice argument in (...) causess gfortran to |
301 | ! repack the array. | |
302 | call show_3d ((array3d(1:-1:-1,1:-1:-1,1:-1:-1))) | |
5bbd8269 | 303 | |
a5c641b5 AB |
304 | call show_4d (array4d) |
305 | call show_4d (array4d (-3:0,10:7:-1,0:3,-7:-10:-1)) | |
306 | call show_4d (array4d (3:0:-1, 10:7:-1, :, -7:-10:-1)) | |
307 | ||
308 | ! Enclosing the array slice argument in (...) causess gfortran to | |
309 | ! repack the array. | |
310 | call show_4d ((array4d (3:-2:-2, 10:7:-2, :, -7:-10:-1))) | |
311 | ||
312 | ! All done. Deallocate. | |
5bbd8269 | 313 | deallocate (other) |
a5c641b5 AB |
314 | |
315 | ! GDB catches this final breakpoint to indicate the end of the test. | |
5bbd8269 | 316 | print *, "" ! Final Breakpoint. |
a5c641b5 AB |
317 | |
318 | contains | |
319 | ||
320 | ! Fill a 1D array with a unique positive integer in each element. | |
321 | subroutine fill_array_1d (array) | |
322 | integer, dimension (:) :: array | |
323 | integer :: counter | |
324 | ||
325 | counter = 1 | |
326 | do j=LBOUND (array, 1), UBOUND (array, 1), 1 | |
327 | array (j) = counter | |
328 | counter = counter + 1 | |
329 | end do | |
330 | end subroutine fill_array_1d | |
331 | ||
332 | ! Fill a 2D array with a unique positive integer in each element. | |
333 | subroutine fill_array_2d (array) | |
334 | integer, dimension (:,:) :: array | |
335 | integer :: counter | |
336 | ||
337 | counter = 1 | |
338 | do i=LBOUND (array, 2), UBOUND (array, 2), 1 | |
339 | do j=LBOUND (array, 1), UBOUND (array, 1), 1 | |
340 | array (j,i) = counter | |
341 | counter = counter + 1 | |
342 | end do | |
343 | end do | |
344 | end subroutine fill_array_2d | |
345 | ||
346 | ! Fill a 3D array with a unique positive integer in each element. | |
347 | subroutine fill_array_3d (array) | |
348 | integer, dimension (:,:,:) :: array | |
349 | integer :: counter | |
350 | ||
351 | counter = 1 | |
352 | do i=LBOUND (array, 3), UBOUND (array, 3), 1 | |
353 | do j=LBOUND (array, 2), UBOUND (array, 2), 1 | |
354 | do k=LBOUND (array, 1), UBOUND (array, 1), 1 | |
355 | array (k, j,i) = counter | |
356 | counter = counter + 1 | |
357 | end do | |
358 | end do | |
359 | end do | |
360 | end subroutine fill_array_3d | |
361 | ||
362 | ! Fill a 4D array with a unique positive integer in each element. | |
363 | subroutine fill_array_4d (array) | |
364 | integer, dimension (:,:,:,:) :: array | |
365 | integer :: counter | |
366 | ||
367 | counter = 1 | |
368 | do i=LBOUND (array, 4), UBOUND (array, 4), 1 | |
369 | do j=LBOUND (array, 3), UBOUND (array, 3), 1 | |
370 | do k=LBOUND (array, 2), UBOUND (array, 2), 1 | |
371 | do l=LBOUND (array, 1), UBOUND (array, 1), 1 | |
372 | array (l, k, j,i) = counter | |
373 | counter = counter + 1 | |
374 | end do | |
375 | end do | |
376 | end do | |
377 | end do | |
378 | print *, "" | |
379 | end subroutine fill_array_4d | |
5bbd8269 | 380 | end program test |