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