OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [realloc_on_assign_12.f90] - Blame information for rev 801

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 694 jeremybenn 
! { 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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.