gcc/testsuite/gfortran.dg/bind-c-contiguous-3.f90

   1 ! { dg-do run }
   2 ! { dg-additional-sources bind-c-contiguous-3.c }
   3
   4 ! Test that multi-dim contiguous is properly handled.
   5
   6 module m
   7   use iso_c_binding, only: c_intptr_t, c_int
   8   implicit none (type, external)
   9
  10 interface
  11   integer(c_intptr_t) function assumed_rank_alloc_c (xx) bind(c)
  12     import :: c_intptr_t
  13     integer, allocatable :: xx(..)
  14   end function
  15   integer(c_intptr_t) function assumed_rank_pointer_c (xx) bind(c)
  16     import :: c_intptr_t
  17     integer, pointer :: xx(..)
  18   end function
  19   integer(c_intptr_t) function assumed_rank_c (xx) bind(c)
  20     import :: c_intptr_t
  21     integer :: xx(..)
  22   end function
  23   integer(c_intptr_t) function assumed_rank_cont_c (xx) bind(c)
  24     import :: c_intptr_t
  25     integer, contiguous :: xx(..)
  26   end function
  27   integer(c_intptr_t) function assumed_shape_c (xx, num) bind(c)
  28     import :: c_intptr_t, c_int
  29     integer :: xx(:,:,:,:)
  30     integer(c_int), value :: num
  31   end function
  32   integer(c_intptr_t) function assumed_shape_cont_c (xx) bind(c)
  33     import :: c_intptr_t
  34     integer, contiguous :: xx(:,:,:,:)
  35   end function
  36   integer(c_intptr_t) function deferred_shape_alloc_c (xx) bind(c)
  37     import :: c_intptr_t
  38     integer, allocatable :: xx(:,:,:,:)
  39   end function
  40   integer(c_intptr_t) function deferred_shape_pointer_c (xx) bind(c)
  41     import :: c_intptr_t
  42     integer, pointer :: xx(:,:,:,:)
  43   end function
  44
  45 end interface
  46
  47 contains
  48
  49 integer function get_n (idx, lbound, extent) result(res)
  50   integer, contiguous :: idx(:), lbound(:), extent(:)
  51   integer :: i
  52   if (size(idx) /= size(lbound) .or. size(idx) /= size(extent)) &
  53     error stop 20
  54   res = idx(1) - lbound(1) + 1
  55   do i = 2, size(idx)
  56     res = res + product(extent(:i-1)) * (idx(i)-lbound(i))
  57   end do
  58 end
  59
  60 integer(c_intptr_t) function assumed_rank_alloc_f (xx) bind(c) result(res)
  61   integer, allocatable :: xx(..)
  62   integer :: i, j, k, l, lb(4)
  63   select rank (xx)
  64   rank (4)
  65     do l = lbound(xx, dim=4), ubound(xx, dim=4)
  66       do k = lbound(xx, dim=3), ubound(xx, dim=3)
  67         do j = lbound(xx, dim=2), ubound(xx, dim=2)
  68           do i = lbound(xx, dim=1), ubound(xx, dim=1)
  69             xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx))
  70           end do
  71         end do
  72       end do
  73     end do
  74     lb = lbound(xx)
  75     res = %loc(xx(lb(1),lb(2),lb(3),lb(4)))  ! { dg-warning "Legacy Extension" }
  76   rank default
  77     error stop 99
  78   end select
  79 end
  80
  81 integer(c_intptr_t) function assumed_rank_pointer_f (xx) bind(c) result(res)
  82   integer, pointer :: xx(..)
  83   integer :: i, j, k, l, lb(4)
  84   select rank (xx)
  85   rank (4)
  86     do l = lbound(xx, dim=4), ubound(xx, dim=4)
  87       do k = lbound(xx, dim=3), ubound(xx, dim=3)
  88         do j = lbound(xx, dim=2), ubound(xx, dim=2)
  89           do i = lbound(xx, dim=1), ubound(xx, dim=1)
  90             xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx))
  91           end do
  92         end do
  93       end do
  94     end do
  95     lb = lbound(xx)
  96     res = %loc(xx(lb(1),lb(2),lb(3),lb(4)))  ! { dg-warning "Legacy Extension" }
  97   rank default
  98     error stop 99
  99   end select
 100 end
 101
 102
 103 integer(c_intptr_t) function assumed_rank_f (xx) bind(c) result(res)
 104   integer :: xx(..)
 105   integer :: i, j, k, l
 106   select rank (xx)
 107   rank (4)
 108     do l = 1, size(xx, dim=4)
 109       do k = 1, size(xx, dim=3)
 110         do j = 1, size(xx, dim=2)
 111           do i = 1, size(xx, dim=1)
 112             xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx))
 113           end do
 114         end do
 115       end do
 116     end do
 117     res = %loc(xx(1,1,1,1))  ! { dg-warning "Legacy Extension" }
 118   rank default
 119     error stop 99
 120   end select
 121 end
 122
 123 integer(c_intptr_t) function assumed_rank_cont_f (xx) bind(c) result(res)
 124   integer, contiguous :: xx(..)
 125   integer :: i, j, k, l
 126   select rank (xx)
 127   rank (4)
 128     do l = 1, size(xx, dim=4)
 129       do k = 1, size(xx, dim=3)
 130         do j = 1, size(xx, dim=2)
 131           do i = 1, size(xx, dim=1)
 132             xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx))
 133           end do
 134         end do
 135       end do
 136     end do
 137     res = %loc(xx(1,1,1,1))  ! { dg-warning "Legacy Extension" }
 138   rank default
 139     error stop 99
 140   end select
 141 end
 142
 143 integer(c_intptr_t) function assumed_shape_f (xx) bind(c) result(res)
 144   integer :: xx(:,:,:,:)
 145   integer :: i, j, k, l
 146   do l = 1, ubound(xx, dim=4)
 147     do k = 1, ubound(xx, dim=3)
 148       do j = 1, ubound(xx, dim=2)
 149         do i = 1, ubound(xx, dim=1)
 150           xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx))
 151         end do
 152       end do
 153     end do
 154   end do
 155   res = %loc(xx(1,1,1,1))  ! { dg-warning "Legacy Extension" }
 156 end
 157
 158 integer(c_intptr_t) function assumed_shape2_f (xx, n) bind(c) result(res)
 159   integer, value :: n
 160   integer :: xx(-n:, -n:, -n:, -n:)
 161   integer :: i, j, k, l
 162   do l = -n, ubound(xx, dim=4)
 163     do k = -n, ubound(xx, dim=3)
 164       do j = -n, ubound(xx, dim=2)
 165         do i = -n, ubound(xx, dim=1)
 166           xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx))
 167         end do
 168       end do
 169     end do
 170   end do
 171   res = %loc(xx(-n,-n,-n,-n))  ! { dg-warning "Legacy Extension" }
 172 end
 173
 174 integer(c_intptr_t) function assumed_shape_cont_f (xx) bind(c) result(res)
 175   integer, contiguous :: xx(:,:,:,:)
 176   integer :: i, j, k, l
 177   do l = 1, ubound(xx, dim=4)
 178     do k = 1, ubound(xx, dim=3)
 179       do j = 1, ubound(xx, dim=2)
 180         do i = 1, ubound(xx, dim=1)
 181           xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx))
 182         end do
 183       end do
 184     end do
 185   end do
 186   res = %loc(xx(1,1,1,1))  ! { dg-warning "Legacy Extension" }
 187 end
 188
 189 integer(c_intptr_t) function assumed_shape2_cont_f (xx, n) bind(c) result(res)
 190   integer, value :: n
 191   integer, contiguous :: xx(-n:, -n:, -n:, -n:)
 192   integer :: i, j, k, l
 193   do l = -n, ubound(xx, dim=4)
 194     do k = -n, ubound(xx, dim=3)
 195       do j = -n, ubound(xx, dim=2)
 196         do i = -n, ubound(xx, dim=1)
 197           xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx))
 198         end do
 199       end do
 200     end do
 201   end do
 202   res = %loc(xx(-n,-n,-n,-n))  ! { dg-warning "Legacy Extension" }
 203 end
 204
 205 integer(c_intptr_t) function deferred_shape_alloc_f (xx) bind(c) result(res)
 206   integer, allocatable :: xx(:,:,:,:)
 207   integer :: i, j, k, l, lb(4)
 208   do l = lbound(xx, dim=4), ubound(xx, dim=4)
 209     do k = lbound(xx, dim=3), ubound(xx, dim=3)
 210       do j = lbound(xx, dim=2), ubound(xx, dim=2)
 211         do i = lbound(xx, dim=1), ubound(xx, dim=1)
 212           xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx))
 213         end do
 214       end do
 215     end do
 216   end do
 217   lb = lbound(xx)
 218   res = %loc(xx(lb(1),lb(2),lb(3),lb(4)))  ! { dg-warning "Legacy Extension" }
 219 end
 220
 221 integer(c_intptr_t) function deferred_shape_pointer_f (xx) bind(c) result(res)
 222   integer, pointer :: xx(:,:,:,:)
 223   integer :: i, j, k, l, lb(4)
 224   do l = lbound(xx, dim=4), ubound(xx, dim=4)
 225     do k = lbound(xx, dim=3), ubound(xx, dim=3)
 226       do j = lbound(xx, dim=2), ubound(xx, dim=2)
 227         do i = lbound(xx, dim=1), ubound(xx, dim=1)
 228           xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx))
 229         end do
 230       end do
 231     end do
 232   end do
 233   lb = lbound(xx)
 234   res = %loc(xx(lb(1),lb(2),lb(3),lb(4)))  ! { dg-warning "Legacy Extension" }
 235 end
 236 end module
 237
 238
 239 use m
 240 implicit none (type, external)
 241 integer, dimension(10,10,10,10) :: var_init, var
 242 target :: var
 243 integer, allocatable, dimension(:,:,:,:) :: a1, a2
 244 integer, pointer, dimension(:,:,:,:) :: p1, p2
 245 integer(c_intptr_t) :: loc4
 246 integer :: i, k, j, l, cnt
 247
 248 do l = 1, ubound(var_init, dim=4)
 249   do k = 1, ubound(var_init, dim=3)
 250     do j = 1, ubound(var_init, dim=2)
 251       do i = 1, ubound(var_init, dim=1)
 252         var_init(i,j,k,l) = get_n([i,j,k,l], lbound(var_init), shape(var_init))
 253       end do
 254     end do
 255   end do
 256 end do
 257
 258 ! Fortran calls
 259
 260 ! ----- allocatable + pointer dummies -------
 261
 262 allocate(a1, mold=var_init)
 263 allocate(p1, mold=var_init)
 264 allocate(a2(-5:4,-10:-1,1:10,11:20))
 265 allocate(p2(-5:4,-10:-1,1:10,11:20))
 266
 267 a1(:,:,:,:) = var_init
 268 loc4 = assumed_rank_alloc_f (a1)
 269 cnt = size(a1) - check_unmod (a1)
 270 call check  (a1, loc4, .true., cnt)
 271 call check2 (a1)
 272
 273 a2(:,:,:,:) = var_init
 274 loc4 = assumed_rank_alloc_f (a2)
 275 cnt = size(a2) - check_unmod (a2)
 276 call check  (a2, loc4, .true., cnt)
 277 call check2 (a2)
 278
 279 a1(:,:,:,:) = var_init
 280 loc4 = deferred_shape_alloc_f (a1)
 281 cnt = size(a1) - check_unmod (a1)
 282 call check  (a1, loc4, .true., cnt)
 283 call check2 (a1)
 284
 285 a2(:,:,:,:) = var_init
 286 loc4 = deferred_shape_alloc_f (a2)
 287 cnt = size(a2) - check_unmod (a2)
 288 call check  (a2, loc4, .true., cnt)
 289 call check2 (a2)
 290
 291 deallocate(a1, a2)
 292
 293 p1(:,:,:,:) = var_init
 294 loc4 = assumed_rank_pointer_f (p1)
 295 cnt = size(p1) - check_unmod (p1)
 296 call check  (p1, loc4, .true., cnt)
 297 call check2 (p1)
 298
 299 p2(:,:,:,:) = var_init
 300 loc4 = assumed_rank_pointer_f (p2)
 301 cnt = size(p2) - check_unmod (p2)
 302 call check  (p2, loc4, .true., cnt)
 303 call check2 (p2)
 304
 305 p1(:,:,:,:) = var_init
 306 loc4 = deferred_shape_pointer_f (p1)
 307 cnt = size(p1) - check_unmod (p1)
 308 call check  (p1, loc4, .true., cnt)
 309 call check2 (p1)
 310
 311 p2(:,:,:,:) = var_init
 312 loc4 = deferred_shape_pointer_f (p2)
 313 cnt = size(p2) - check_unmod (p2)
 314 call check  (p2, loc4, .true., cnt)
 315 call check2 (p2)
 316
 317 deallocate(p1, p2)
 318
 319 ! --- p => var(4:7,::3,::2,:)
 320 var = var_init
 321 p1 => var(4:7,::3,::2,:)
 322 loc4 = assumed_rank_pointer_f (p1)
 323 cnt = size(p1) - check_unmod (p1)
 324 call check  (p1, loc4, .false., cnt)
 325 call check2 (p1)
 326
 327 var = var_init
 328 p2(-5:,-10:,1:,11:) => var(4:7,::3,::2,:)
 329 loc4 = assumed_rank_pointer_f (p2)
 330 cnt = size(p2) - check_unmod (p2)
 331 call check  (p2, loc4, .false., cnt)
 332 call check2 (p2)
 333
 334 var = var_init
 335 p1 => var(4:7,::3,::2,:)
 336 loc4 = deferred_shape_pointer_f (p1)
 337 cnt = size(p1) - check_unmod (p1)
 338 call check  (p1, loc4, .false., cnt)
 339 call check2 (p1)
 340
 341 var = var_init
 342 p2(-5:,-10:,1:,11:) => var(4:7,::3,::2,:)
 343 loc4 = deferred_shape_pointer_f (p2)
 344 cnt = size(p2) - check_unmod (p2)
 345 call check  (p2, loc4, .false., cnt)
 346 call check2 (p2)
 347
 348
 349
 350 ! ----- nonallocatable + nonpointer dummies -------
 351
 352 var = var_init
 353 loc4 = assumed_rank_f (var)
 354 cnt = size(var) - check_unmod (var)
 355 call check  (var, loc4, .false., cnt)
 356 call check2 (var)
 357
 358 var = var_init
 359 loc4 = assumed_shape_f (var)
 360 cnt = size(var) - check_unmod (var)
 361 call check  (var, loc4, .false., cnt)
 362 call check2 (var)
 363
 364 var = var_init
 365 loc4 = assumed_shape2_f (var, 99)
 366 cnt = size(var) - check_unmod (var)
 367 call check  (var, loc4, .false., cnt)
 368 call check2 (var)
 369
 370 var = var_init
 371 loc4 = assumed_rank_cont_f (var)
 372 cnt = size(var) - check_unmod (var)
 373 call check  (var, loc4, .true., cnt)
 374 call check2 (var)
 375
 376 var = var_init
 377 loc4 = assumed_shape_cont_f (var)
 378 cnt = size(var) - check_unmod (var)
 379 call check  (var, loc4, .true., cnt)
 380 call check2 (var)
 381
 382 var = var_init
 383 loc4 = assumed_shape2_cont_f (var, 99)
 384 cnt = size(var) - check_unmod (var)
 385 call check  (var, loc4, .true., cnt)
 386 call check2 (var)
 387
 388 ! --- var(4:7,::3,::2,:)
 389
 390 var = var_init
 391 loc4 = assumed_rank_f (var(4:7,::3,::2,:))
 392 cnt = size(var) - check_unmod (var)
 393 call check  (var(4:7,::3,::2,:), loc4, .false., cnt)
 394 call check2 (var(4:7,::3,::2,:))
 395
 396 var = var_init
 397 loc4 = assumed_shape_f (var(4:7,::3,::2,:))
 398 cnt = size(var) - check_unmod (var)
 399 call check  (var(4:7,::3,::2,:), loc4, .false., cnt)
 400 call check2 (var(4:7,::3,::2,:))
 401
 402 var = var_init
 403 loc4 = assumed_shape2_f (var(4:7,::3,::2,:), 99)
 404 cnt = size(var) - check_unmod (var)
 405 call check  (var(4:7,::3,::2,:), loc4, .false., cnt)
 406 call check2 (var(4:7,::3,::2,:))
 407
 408 var = var_init
 409 loc4 = assumed_rank_cont_f (var(4:7,::3,::2,:))
 410 cnt = size(var) - check_unmod (var)
 411 call check  (var(4:7,::3,::2,:), loc4, .true., cnt)
 412 call check2 (var(4:7,::3,::2,:))
 413
 414 var = var_init
 415 loc4 = assumed_shape_cont_f (var(4:7,::3,::2,:))
 416 cnt = size(var) - check_unmod (var)
 417 call check  (var(4:7,::3,::2,:), loc4, .true., cnt)
 418 call check2 (var(4:7,::3,::2,:))
 419
 420 var = var_init
 421 loc4 = assumed_shape2_cont_f (var(4:7,::3,::2,:), 99)
 422 cnt = size(var) - check_unmod (var)
 423 call check  (var(4:7,::3,::2,:), loc4, .true., cnt)
 424 call check2 (var(4:7,::3,::2,:))
 425
 426
 427 ! C calls
 428
 429 ! ----- allocatable + pointer dummies -------
 430
 431 allocate(a1, mold=var_init)
 432 allocate(p1, mold=var_init)
 433 allocate(a2(-5:4,-10:-1,1:10,11:20))
 434 allocate(p2(-5:4,-10:-1,1:10,11:20))
 435
 436 a1(:,:,:,:) = var_init
 437 loc4 = assumed_rank_alloc_c (a1)
 438 cnt = size(a1) - check_unmod (a1)
 439 call check  (a1, loc4, .true., cnt)
 440 call check2 (a1)
 441
 442 a2(:,:,:,:) = var_init
 443 loc4 = assumed_rank_alloc_c (a2)
 444 cnt = size(a2) - check_unmod (a2)
 445 call check  (a2, loc4, .true., cnt)
 446 call check2 (a2)
 447
 448 a1(:,:,:,:) = var_init
 449 loc4 = deferred_shape_alloc_c (a1)
 450 cnt = size(a1) - check_unmod (a1)
 451 call check  (a1, loc4, .true., cnt)
 452 call check2 (a1)
 453
 454 a2(:,:,:,:) = var_init
 455 loc4 = deferred_shape_alloc_c (a2)
 456 cnt = size(a2) - check_unmod (a2)
 457 call check  (a2, loc4, .true., cnt)
 458 call check2 (a2)
 459
 460 deallocate(a1, a2)
 461
 462 p1(:,:,:,:) = var_init
 463 loc4 = assumed_rank_pointer_c (p1)
 464 cnt = size(p1) - check_unmod (p1)
 465 call check  (p1, loc4, .true., cnt)
 466 call check2 (p1)
 467
 468 p2(:,:,:,:) = var_init
 469 loc4 = assumed_rank_pointer_c (p2)
 470 cnt = size(p2) - check_unmod (p2)
 471 call check  (p2, loc4, .true., cnt)
 472 call check2 (p2)
 473
 474 p1(:,:,:,:) = var_init
 475 loc4 = deferred_shape_pointer_c (p1)
 476 cnt = size(p1) - check_unmod (p1)
 477 call check  (p1, loc4, .true., cnt)
 478 call check2 (p1)
 479
 480 p2(:,:,:,:) = var_init
 481 loc4 = deferred_shape_pointer_c (p2)
 482 cnt = size(p2) - check_unmod (p2)
 483 call check  (p2, loc4, .true., cnt)
 484 call check2 (p2)
 485
 486 deallocate(p1, p2)
 487
 488 ! --- p => var(4:7,::3,::2,:)
 489 var = var_init
 490 p1 => var(4:7,::3,::2,:)
 491 loc4 = assumed_rank_pointer_c (p1)
 492 cnt = size(p1) - check_unmod (p1)
 493 call check  (p1, loc4, .false., cnt)
 494 call check2 (p1)
 495
 496 var = var_init
 497 p2(-5:,-10:,1:,11:) => var(4:7,::3,::2,:)
 498 loc4 = assumed_rank_pointer_c (p2)
 499 cnt = size(p2) - check_unmod (p2)
 500 call check  (p2, loc4, .false., cnt)
 501 call check2 (p2)
 502
 503 var = var_init
 504 p1 => var(4:7,::3,::2,:)
 505 loc4 = deferred_shape_pointer_c (p1)
 506 cnt = size(p1) - check_unmod (p1)
 507 call check  (p1, loc4, .false., cnt)
 508 call check2 (p1)
 509
 510 var = var_init
 511 p2(-5:,-10:,1:,11:) => var(4:7,::3,::2,:)
 512 loc4 = deferred_shape_pointer_c (p2)
 513 cnt = size(p2) - check_unmod (p2)
 514 call check  (p2, loc4, .false., cnt)
 515 call check2 (p2)
 516
 517
 518 ! ----- nonallocatable + nonpointer dummies -------
 519
 520 var = var_init
 521 loc4 = assumed_rank_c (var)
 522 cnt = size(var) - check_unmod (var)
 523 call check  (var, loc4, .false., cnt)
 524 call check2 (var)
 525
 526 var = var_init
 527 ! calls assumed_shape_f
 528 loc4 = assumed_shape_c (var, num=1)
 529 cnt = size(var) - check_unmod (var)
 530 call check  (var, loc4, .false., cnt)
 531 call check2 (var)
 532
 533 var = var_init
 534 ! calls assumed_shape_cont_f
 535 loc4 = assumed_shape_c (var, num=2)
 536 cnt = size(var) - check_unmod (var)
 537 call check  (var, loc4, .true., cnt)
 538 call check2 (var)
 539
 540 var = var_init
 541 ! calls assumed_rank_cont_f
 542 loc4 = assumed_shape_c (var, num=3)
 543 cnt = size(var) - check_unmod (var)
 544 call check  (var, loc4, .true., cnt)
 545 call check2 (var)
 546
 547 var = var_init
 548 loc4 = assumed_rank_cont_c (var)
 549 cnt = size(var) - check_unmod (var)
 550 call check  (var, loc4, .true., cnt)
 551 call check2 (var)
 552
 553 var = var_init
 554 loc4 = assumed_shape_cont_c (var)
 555 cnt = size(var) - check_unmod (var)
 556 call check  (var, loc4, .true., cnt)
 557 call check2 (var)
 558
 559 ! --- var(4:7,::3,::2,:)
 560
 561 var = var_init
 562 loc4 = assumed_rank_c (var(4:7,::3,::2,:))
 563 cnt = size(var) - check_unmod (var)
 564 call check  (var(4:7,::3,::2,:), loc4, .false., cnt)
 565 call check2 (var(4:7,::3,::2,:))
 566
 567 var = var_init
 568 ! calls assumed_shape_f
 569 loc4 = assumed_shape_c (var(4:7,::3,::2,:), num=4)
 570 cnt = size(var) - check_unmod (var)
 571 call check  (var(4:7,::3,::2,:), loc4, .false., cnt)
 572 call check2 (var(4:7,::3,::2,:))
 573
 574 var = var_init
 575 ! calls assumed_shape_cont_f
 576 loc4 = assumed_shape_c (var(4:7,::3,::2,:), num=5)
 577 cnt = size(var) - check_unmod (var)
 578 call check  (var(4:7,::3,::2,:), loc4, .true., cnt)
 579 call check2 (var(4:7,::3,::2,:))
 580
 581 var = var_init
 582 ! calls assumed_rank_cont_f
 583 loc4 = assumed_shape_c (var(4:7,::3,::2,:), num=6)
 584 cnt = size(var) - check_unmod (var)
 585 call check  (var(4:7,::3,::2,:), loc4, .true., cnt)
 586 call check2 (var(4:7,::3,::2,:))
 587
 588 var = var_init
 589 loc4 = assumed_rank_cont_c (var(4:7,::3,::2,:))
 590 cnt = size(var) - check_unmod (var)
 591 call check  (var(4:7,::3,::2,:), loc4, .true., cnt)
 592 call check2 (var(4:7,::3,::2,:))
 593
 594 var = var_init
 595 loc4 = assumed_shape_cont_c (var(4:7,::3,::2,:))
 596 cnt = size(var) - check_unmod (var)
 597 call check  (var(4:7,::3,::2,:), loc4, .true., cnt)
 598 call check2 (var(4:7,::3,::2,:))
 599
 600
 601 contains
 602
 603 ! Ensure that the rest is still okay
 604 ! Returns the number of elements >= 0
 605 integer function check_unmod (x) result(cnt)
 606   integer, contiguous, intent(in) ::  x(:,:,:,:)
 607   integer :: i, k, j, l
 608   cnt = 0
 609   do l = 1, ubound(x, dim=4)
 610     do k = 1, ubound(x, dim=3)
 611       do j = 1, ubound(x, dim=2)
 612         do i = 1, ubound(x, dim=1)
 613           if (x(i,j,k,l) >= 0) then
 614             cnt = cnt + 1
 615             if (x(i,j,k,l) /= get_n([i,j,k,l], lbound(x), shape(x))) &
 616               error stop 5
 617           endif
 618         end do
 619       end do
 620     end do
 621   end do
 622 end
 623
 624 subroutine check(x, loc1, cont, cnt)
 625   integer, intent(in) :: x(:,:,:,:)
 626   integer(c_intptr_t), intent(in), optional :: loc1
 627   logical, intent(in), optional :: cont ! dummy has CONTIGUOUS attr
 628   integer, intent(in), optional :: cnt
 629   integer(c_intptr_t) :: loc2
 630   integer :: i, k, j, l
 631   if (present (loc1)) then
 632     loc2 = %loc(x(1,1,1,1))  ! { dg-warning "Legacy Extension" }
 633     if (is_contiguous (x) .or. .not.cont) then
 634       if (loc1 /= loc2) error stop 1
 635     else
 636       if (loc1 == loc2) error stop 2
 637     end if
 638     if (cnt /= size(x)) error stop 3
 639   end if
 640   do l = 1, ubound(x, dim=4)
 641     do k = 1, ubound(x, dim=3)
 642       do j = 1, ubound(x, dim=2)
 643         do i = 1, ubound(x, dim=1)
 644           if (x(i,j,k,l) /= -get_n([i,j,k,l], lbound(x), shape(x))) &
 645             error stop 4
 646         end do
 647       end do
 648     end do
 649   end do
 650 end
 651
 652 subroutine check2(x)
 653   integer, contiguous, intent(in) :: x(:,:,:,:)
 654   call check(x)
 655 end subroutine
 656 end