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
|
! { dg-do run }
! { dg-options "-fcheck=all" }
!
! PR fortran/48820
!
! Assumed-rank tests - same as assumed_rank_1.f90,
! but with bounds checks and w/o call to C function
!
implicit none
integer, target :: x(2:5,4:7), y(-4:4)
integer, allocatable, target :: z(:,:,:,:)
integer, allocatable :: val(:)
integer :: i
allocate(z(1:4, -2:5, 4, 10:11))
if (rank(x) /= 2) call abort ()
val = [(2*i+3, i = 1, size(x))]
x = reshape (val, shape(x))
call foo(x, rank(x), lbound(x), ubound(x), val)
call foo2(x, rank(x), lbound(x), ubound(x), val)
call bar(x,x,.true.)
call bar(x,prsnt=.false.)
if (rank(y) /= 1) call abort ()
val = [(2*i+7, i = 1, size(y))]
y = reshape (val, shape(y))
call foo(y, rank(y), lbound(y), ubound(y), val)
call foo2(y, rank(y), lbound(y), ubound(y), val)
call bar(y,y,.true.)
call bar(y,prsnt=.false.)
if (rank(z) /= 4) call abort ()
val = [(2*i+5, i = 1, size(z))]
z(:,:,:,:) = reshape (val, shape(z))
call foo(z, rank(z), lbound(z), ubound(z), val)
call foo(z, rank(z), lbound(z), ubound(z), val)
call foo2(z, rank(z), lbound(z), ubound(z), val)
call bar(z,z,.true.)
call bar(z,prsnt=.false.)
contains
subroutine bar(a,b, prsnt)
integer, pointer, optional, intent(in) :: a(..),b(..)
logical, value :: prsnt
! The following is not valid, but it goes past the constraint check
! Technically, it could be allowed and might be in Fortran 2015:
if (.not. associated(a)) call abort()
if (present(b)) then
if (.not. associated(a,b)) call abort()
else
if (.not. associated(a)) call abort()
end if
if (.not. present(a)) call abort()
if (prsnt .neqv. present(b)) call abort()
end subroutine
! POINTER argument - bounds as specified before
subroutine foo(a, rnk, low, high, val)
integer,pointer, intent(in) :: a(..)
integer, value :: rnk
integer, intent(in) :: low(:), high(:), val(:)
integer :: i
if (rank(a) /= rnk) call abort()
if (size(low) /= rnk .or. size(high) /= rnk) call abort()
if (size(a) /= product (high - low +1)) call abort()
if (rnk > 0) then
if (low(1) /= lbound(a,1)) call abort()
if (high(1) /= ubound(a,1)) call abort()
if (size (a,1) /= high(1)-low(1)+1) call abort()
end if
do i = 1, rnk
if (low(i) /= lbound(a,i)) call abort()
if (high(i) /= ubound(a,i)) call abort()
if (size (a,i) /= high(i)-low(i)+1) call abort()
end do
call foo2(a, rnk, low, high, val)
end subroutine
! Non-pointer, non-allocatable bounds. lbound == 1
subroutine foo2(a, rnk, low, high, val)
integer, intent(in) :: a(..)
integer, value :: rnk
integer, intent(in) :: low(:), high(:), val(:)
integer :: i
if (rank(a) /= rnk) call abort()
if (size(low) /= rnk .or. size(high) /= rnk) call abort()
if (size(a) /= product (high - low +1)) call abort()
if (rnk > 0) then
if (1 /= lbound(a,1)) call abort()
if (high(1)-low(1)+1 /= ubound(a,1)) call abort()
if (size (a,1) /= high(1)-low(1)+1) call abort()
end if
do i = 1, rnk
if (1 /= lbound(a,i)) call abort()
if (high(i)-low(i)+1 /= ubound(a,i)) call abort()
if (size (a,i) /= high(i)-low(i)+1) call abort()
end do
end subroutine foo2
! ALLOCATABLE argument - bounds as specified before
subroutine foo3 (a, rnk, low, high, val)
integer, allocatable, intent(in), target :: a(..)
integer, value :: rnk
integer, intent(in) :: low(:), high(:), val(:)
integer :: i
if (rank(a) /= rnk) call abort()
if (size(low) /= rnk .or. size(high) /= rnk) call abort()
if (size(a) /= product (high - low +1)) call abort()
if (rnk > 0) then
if (low(1) /= lbound(a,1)) call abort()
if (high(1) /= ubound(a,1)) call abort()
if (size (a,1) /= high(1)-low(1)+1) call abort()
end if
do i = 1, rnk
if (low(i) /= lbound(a,i)) call abort()
if (high(i) /= ubound(a,i)) call abort()
if (size (a,i) /= high(i)-low(i)+1) call abort()
end do
call foo(a, rnk, low, high, val)
end subroutine
end
|
