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])) call abort ()
41      if (any (ubound (B) /= [n1,n2,n3])) call abort ()
42      if (any (lbound (B) /= [1,1,1])) call abort ()
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)) call abort ()
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])) call abort ()
81      if (any (ubound (B) /= [n1,n2,n3])) call abort ()
82      if (any (lbound (B) /= [1,1,1])) call abort ()
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)) call abort ()
91            END DO
92         END DO
93      END DO
94      DEALLOCATE(A, B)
95    end subroutine wrong_shape
96    END PROGRAM RESHAPEIT
97