gcc/testsuite/gfortran.dg/realloc_on_assign_12.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/52151
   4 !
   5 ! Check that the bounds/shape/strides are correctly set
   6 ! for (re)alloc on assignment, if the LHS is either not
   7 ! allocated or has the wrong shape. This test is for
   8 ! code which is only invoked for libgfortran intrinsic
   9 ! such as RESHAPE.
  10 !
  11 ! Based on the example of PR 52117 by Steven Hirshman
  12 !
  13     PROGRAM RESHAPEIT
  14       call unalloc ()
  15       call wrong_shape ()
  16     contains
  17     subroutine unalloc ()
  18       INTEGER, PARAMETER :: n1=2, n2=2, n3=2
  19       INTEGER            :: m1, m2, m3, lc
  20       REAL, ALLOCATABLE  :: A(:,:), B(:,:,:)
  21       REAL               :: val
  22
  23       ALLOCATE (A(n1,n2*n3))
  24 ! << B is not allocated
  25
  26       val = 0
  27       lc = 0
  28       DO m3=1,n3
  29          DO m2=1,n2
  30             lc = lc+1
  31             DO m1=1,n1
  32                val = val+1
  33                A(m1, lc) = val
  34             END DO
  35          END DO
  36       END DO
  37
  38       B = RESHAPE(A, [n1,n2,n3])
  39
  40       if (any (shape (B)  /= [n1,n2,n3])) STOP 1
  41       if (any (ubound (B) /= [n1,n2,n3])) STOP 2
  42       if (any (lbound (B) /= [1,1,1])) STOP 3
  43
  44       lc = 0
  45       DO m3=1,n3
  46          DO m2=1,n2
  47             lc = lc+1
  48             DO m1=1,n1
  49 !               PRINT *,'A(',m1,',',lc,') = ',A(m1,lc),' B = ',B(m1,m2,m3)
  50                if (A(m1,lc) /= B(m1,m2,m3)) STOP 4
  51             END DO
  52          END DO
  53       END DO
  54       DEALLOCATE(A, B)
  55     end subroutine unalloc
  56
  57     subroutine wrong_shape ()
  58       INTEGER, PARAMETER :: n1=2, n2=2, n3=2
  59       INTEGER            :: m1, m2, m3, lc
  60       REAL, ALLOCATABLE  :: A(:,:), B(:,:,:)
  61       REAL               :: val
  62
  63       ALLOCATE (A(n1,n2*n3))
  64       ALLOCATE (B(1,1,1))     ! << shape differs from RHS
  65
  66       val = 0
  67       lc = 0
  68       DO m3=1,n3
  69          DO m2=1,n2
  70             lc = lc+1
  71             DO m1=1,n1
  72                val = val+1
  73                A(m1, lc) = val
  74             END DO
  75          END DO
  76       END DO
  77
  78       B = RESHAPE(A, [n1,n2,n3])
  79
  80       if (any (shape (B)  /= [n1,n2,n3])) STOP 5
  81       if (any (ubound (B) /= [n1,n2,n3])) STOP 6
  82       if (any (lbound (B) /= [1,1,1])) STOP 7
  83
  84       lc = 0
  85       DO m3=1,n3
  86          DO m2=1,n2
  87             lc = lc+1
  88             DO m1=1,n1
  89 !               PRINT *,'A(',m1,',',lc,') = ',A(m1,lc),' B = ',B(m1,m2,m3)
  90                if (A(m1,lc) /= B(m1,m2,m3)) STOP 8
  91             END DO
  92          END DO
  93       END DO
  94       DEALLOCATE(A, B)
  95     end subroutine wrong_shape
  96     END PROGRAM RESHAPEIT