1 ! Copyright 2019-2024 Free Software Foundation, Inc. 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 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="yes") ")" 65 66 print *, "" ! Display Array Slice 1D 67 end subroutine show_1d 68 69 subroutine show_2d (array) 70 integer, dimension (:,:) :: array 71 72 print *, "Array Contents:" 73 print *, "" 74 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 *, "" 80 end do 81 82 print *, "" 83 print *, "Expected GDB Output:" 84 print *, "" 85 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 178 179 ! 180 ! Start of test program. 181 ! 182 program test 183 interface 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) 193 integer, dimension(:,:) :: array 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 203 end interface 204 205 ! Declare variables used in this test. 206 integer, dimension (-10:-1,-10:-2) :: neg_array 207 integer, dimension (1:10,1:10) :: array 208 integer, allocatable :: other (:, :) 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 215 216 ! Allocate or associate any variables as needed. 217 allocate (other (-5:4, -2:7)) 218 pointer2d => tarray 219 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)) 256 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 281 end do 282 end do 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))) 295 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)) 299 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))) 303 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. 313 deallocate (other) 314 315 ! GDB catches this final breakpoint to indicate the end of the test. 316 print *, "" ! Final Breakpoint. 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 380 end program test 381
Indexes created Mon Mar 02 05:31:46 UTC 2026