gcc/testsuite/gfortran.dg/pointer_remapping_5.f08

   1 ! { dg-do run }
   2 ! { dg-options "-std=f2008 -fall-intrinsics -fcheck=bounds" }
   3
   4 ! PR fortran/29785
   5 ! Check pointer rank remapping at runtime.
   6
   7 ! Contributed by Daniel Kraft, d@domob.eu.
   8
   9 PROGRAM main
  10   IMPLICIT NONE
  11   INTEGER, TARGET :: arr(12), basem(3, 4)
  12   INTEGER, POINTER :: vec(:), mat(:, :)
  13   INTEGER :: i
  14
  15   arr = (/ (i, i = 1, 12) /)
  16   basem = RESHAPE (arr, SHAPE (basem))
  17
  18   ! We need not necessarily change the rank...
  19   vec(2_1:5) => arr(1_1:12_1:2_1)
  20   IF (LBOUND (vec, 1) /= 2 .OR. UBOUND (vec, 1) /= 5) CALL abort ()
  21   IF (ANY (vec /= (/ 1, 3, 5, 7 /))) CALL abort ()
  22   IF (vec(2) /= 1 .OR. vec(5) /= 7) CALL abort ()
  23
  24   ! ...but it is of course the more interesting.  Also try remapping a pointer.
  25   vec => arr(1:12:2)
  26   mat(1:3, 1:2) => vec
  27   IF (ANY (LBOUND (mat) /= (/ 1, 1 /) .OR. UBOUND (mat) /= (/ 3, 2 /))) &
  28     CALL abort ()
  29   IF (ANY (mat /= RESHAPE (arr(1:12:2), SHAPE (mat)))) CALL abort ()
  30   IF (mat(1, 1) /= 1 .OR. mat(1, 2) /= 7) CALL abort ()
  31
  32   ! Remap with target of rank > 1.
  33   vec(1:12_1) => basem
  34   IF (LBOUND (vec, 1) /= 1 .OR. UBOUND (vec, 1) /= 12) CALL abort ()
  35   IF (ANY (vec /= arr)) CALL abort ()
  36   IF (vec(1) /= 1 .OR. vec(5) /= 5 .OR. vec(12) /= 12) CALL abort ()
  37 END PROGRAM main