]>
Commit | Line | Data |
---|---|---|
597553ab | 1 | ! { dg-do run } |
4f4b0ab8 | 2 | ! { dg-skip-if "Too big for local store" { spu-*-* } } |
597553ab PT |
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. | |
93c3bf47 | 7 | ! test1 has been corrected for PR47051 |
597553ab PT |
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 | |
21 | contains | |
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 | |
93c3bf47 PT |
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 | |
597553ab PT |
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 | |
93c3bf47 PT |
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 | |
597553ab PT |
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 | |
ca474dfe | 126 | invima = 0.0 |
597553ab PT |
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 | |
152 | end | |
153 |