1! { dg-do run }
2! { dg-skip-if "Too big for local store" { spu-*-* } { "*" } { "" } }
3! Tests the patch that implements F2003 automatic allocation and
4! reallocation of allocatable arrays on assignment.  The tests
5! below were generated in the final stages of the development of
6! this patch.
7! test1 has been corrected for PR47051
8!
9! Contributed by Dominique Dhumieres <dominiq@lps.ens.fr>
10!            and Tobias Burnus <burnus@gcc.gnu.org>
11!
12  integer :: nglobal
13  call test1
14  call test2
15  call test3
16  call test4
17  call test5
18  call test6
19  call test7
20  call test8
21contains
22  subroutine test1
23!
24! Check that the bounds are set correctly, when assigning
25! to an array that already has the correct shape.
26!
27    real :: a(10) = 1, b(51:60) = 2
28    real, allocatable :: c(:), d(:)
29    c=a
30    if (lbound (c, 1) .ne. lbound(a, 1)) call abort
31    if (ubound (c, 1) .ne. ubound(a, 1)) call abort
32    c=b
33! 7.4.1.3 "If variable is an allocated allocatable variable, it is
34! deallocated if expr is an array of different shape or any of the
35! corresponding length type parameter values of variable and expr
36! differ." Here the shape is the same so the deallocation does not
37! occur and the bounds are not recalculated. This was corrected
38! for the fix of PR47051. 
39    if (lbound (c, 1) .ne. lbound(a, 1)) call abort
40    if (ubound (c, 1) .ne. ubound(a, 1)) call abort
41    d=b
42    if (lbound (d, 1) .ne. lbound(b, 1)) call abort
43    if (ubound (d, 1) .ne. ubound(b, 1)) call abort
44    d=a
45! The other PR47051 correction.
46    if (lbound (d, 1) .ne. lbound(b, 1)) call abort
47    if (ubound (d, 1) .ne. ubound(b, 1)) call abort
48  end subroutine
49  subroutine test2
50!
51! Check that the bounds are set correctly, when making an
52! assignment with an implicit conversion.  First with a
53! non-descriptor variable....
54!
55    integer(4), allocatable :: a(:)
56    integer(8) :: b(5:6)
57    a = b
58    if (lbound (a, 1) .ne. lbound(b, 1)) call abort
59    if (ubound (a, 1) .ne. ubound(b, 1)) call abort
60  end subroutine
61  subroutine test3
62!
63! ...and now a descriptor variable.
64!
65    integer(4), allocatable :: a(:)
66    integer(8), allocatable :: b(:)
67    allocate (b(7:11))
68    a = b
69    if (lbound (a, 1) .ne. lbound(b, 1)) call abort
70    if (ubound (a, 1) .ne. ubound(b, 1)) call abort
71  end subroutine
72  subroutine test4
73!
74! Check assignments of the kind a = f(...)
75!
76    integer, allocatable :: a(:)
77    integer, allocatable :: c(:)
78    a = f()
79    if (any (a .ne. [1, 2, 3, 4])) call abort
80    c = a + 8
81    a = f (c)
82    if (any ((a - 8) .ne. [1, 2, 3, 4])) call abort
83    deallocate (c)
84    a = f (c)
85    if (any ((a - 4) .ne. [1, 2, 3, 4])) call abort
86  end subroutine
87  function f(b)
88    integer, allocatable, optional :: b(:)
89    integer :: f(4)
90    if (.not.present (b)) then
91      f = [1,2,3,4]
92    elseif (.not.allocated (b)) then
93      f = [5,6,7,8]
94    else
95      f = b
96    end if
97  end function f
98  
99  subroutine test5
100!
101! Extracted from rnflow.f90, Polyhedron benchmark suite,
102! http://www.polyhedron.com
103!
104    integer, parameter :: ncls = 233, ival = 16, ipic = 17
105    real, allocatable, dimension (:,:) :: utrsft
106    real, allocatable, dimension (:,:) :: dtrsft
107    real, allocatable, dimension (:,:) :: xwrkt
108    allocate (utrsft(ncls, ncls), dtrsft(ncls, ncls))
109    nglobal = 0
110    xwrkt = trs2a2 (ival, ipic, ncls)
111    if (any (shape (xwrkt) .ne. [ncls, ncls])) call abort
112    xwrkt = invima (xwrkt, ival, ipic, ncls)
113    if (nglobal .ne. 1) call abort
114    if (sum(xwrkt) .ne. xwrkt(ival, ival)) call abort
115  end subroutine
116  function trs2a2 (j, k, m)
117    real, dimension (1:m,1:m) :: trs2a2
118    integer, intent (in)      :: j, k, m
119    nglobal = nglobal + 1
120    trs2a2 = 0.0
121  end function trs2a2
122  function invima (a, j, k, m)
123    real, dimension (1:m,1:m)              :: invima
124    real, dimension (1:m,1:m), intent (in) :: a
125    integer, intent (in)            :: j, k
126    invima = 0.0
127    invima (j, j) = 1.0 / (1.0 - a (j, j))
128  end function invima
129  subroutine test6
130    character(kind=1, len=100), allocatable, dimension(:) :: str
131    str = [ "abc" ]
132    if (TRIM(str(1)) .ne. "abc") call abort
133    if (len(str) .ne. 100) call abort
134  end subroutine
135  subroutine test7
136    character(kind=4, len=100), allocatable, dimension(:) :: str
137    character(kind=4, len=3) :: test = "abc"
138    str = [ "abc" ]
139    if (TRIM(str(1)) .ne. test) call abort
140    if (len(str) .ne. 100) call abort
141  end subroutine
142  subroutine test8
143    type t
144      integer, allocatable :: a(:)
145    end type t
146    type(t) :: x
147    x%a= [1,2,3]
148    if (any (x%a .ne. [1,2,3])) call abort
149    x%a = [4]
150    if (any (x%a .ne. [4])) call abort
151  end subroutine
152end
153
154