1! { dg-do run }
2! { dg-additional-sources assumed_rank_1_c.c }
3!
4! PR fortran/48820
5!
6! Assumed-rank tests
7!
8
9implicit none
10
11interface
12  subroutine check_value(b, n, val)
13    integer :: b(..)
14    integer, value :: n
15    integer :: val(n)
16  end subroutine
17end interface
18
19integer, target :: x(2:5,4:7), y(-4:4)
20integer, allocatable, target :: z(:,:,:,:)
21integer, allocatable :: val(:)
22integer :: i
23
24allocate(z(1:4, -2:5, 4, 10:11))
25
26if (rank(x) /= 2) STOP 1
27val = [(2*i+3, i = 1, size(x))]
28x = reshape (val, shape(x))
29call foo(x, rank(x), lbound(x), ubound(x), val)
30call foo2(x, rank(x), lbound(x), ubound(x), val)
31call bar(x,x,.true.)
32call bar(x,prsnt=.false.)
33
34if (rank(y) /= 1) STOP 2
35val = [(2*i+7, i = 1, size(y))]
36y = reshape (val, shape(y))
37call foo(y, rank(y), lbound(y), ubound(y), val)
38call foo2(y, rank(y), lbound(y), ubound(y), val)
39call bar(y,y,.true.)
40call bar(y,prsnt=.false.)
41
42if (rank(z) /= 4) STOP 3
43val = [(2*i+5, i = 1, size(z))]
44z(:,:,:,:) = reshape (val, shape(z))
45call foo(z, rank(z), lbound(z), ubound(z), val)
46call foo(z, rank(z), lbound(z), ubound(z), val)
47call foo2(z, rank(z), lbound(z), ubound(z), val)
48call bar(z,z,.true.)
49call bar(z,prsnt=.false.)
50
51contains
52  subroutine bar(a,b, prsnt)
53    integer, pointer, optional, intent(in) :: a(..),b(..)
54    logical, value :: prsnt
55    if (.not. associated(a)) STOP 4
56    if (present(b)) then
57       ! The following is not valid.
58       ! Technically, it could be allowed and might be in Fortran 2015:
59       ! if (.not. associated(a,b)) STOP 5
60    else
61      if (.not. associated(a)) STOP 6
62    end if
63    if (.not. present(a)) STOP 7
64    if (prsnt .neqv. present(b)) STOP 8
65  end subroutine
66
67  ! POINTER argument - bounds as specified before
68  subroutine foo(a, rnk, low, high, val)
69    integer,pointer, intent(in) :: a(..)
70    integer, value :: rnk
71    integer, intent(in) :: low(:), high(:), val(:)
72    integer :: i
73
74
75
76    if (rank(a) /= rnk) STOP 9
77    if (size(low) /= rnk .or. size(high) /= rnk) STOP 10
78    if (size(a) /= product (high - low +1)) STOP 11
79
80    if (rnk > 0) then
81      if (low(1) /= lbound(a,1)) STOP 12
82      if (high(1) /= ubound(a,1)) STOP 13
83      if (size (a,1) /= high(1)-low(1)+1) STOP 14
84    end if
85
86    do i = 1, rnk
87      if (low(i) /= lbound(a,i)) STOP 15
88      if (high(i) /= ubound(a,i)) STOP 16
89      if (size (a,i) /= high(i)-low(i)+1) STOP 17
90    end do
91    call check_value (a, rnk, val)
92    call foo2(a, rnk, low, high, val)
93  end subroutine
94
95  ! Non-pointer, non-allocatable bounds. lbound == 1
96  subroutine foo2(a, rnk, low, high, val)
97    integer, intent(in) :: a(..)
98    integer, value :: rnk
99    integer, intent(in) :: low(:), high(:), val(:)
100    integer :: i
101
102    if (rank(a) /= rnk) STOP 18
103    if (size(low) /= rnk .or. size(high) /= rnk) STOP 19
104    if (size(a) /= product (high - low +1)) STOP 20
105
106    if (rnk > 0) then
107      if (1 /= lbound(a,1)) STOP 21
108      if (high(1)-low(1)+1 /= ubound(a,1)) STOP 22
109      if (size (a,1) /= high(1)-low(1)+1) STOP 23
110    end if
111
112    do i = 1, rnk
113      if (1 /= lbound(a,i)) STOP 24
114      if (high(i)-low(i)+1 /= ubound(a,i)) STOP 25
115      if (size (a,i) /= high(i)-low(i)+1) STOP 26
116    end do
117    call check_value (a, rnk, val)
118  end subroutine foo2
119
120  ! ALLOCATABLE argument - bounds as specified before
121  subroutine foo3 (a, rnk, low, high, val)
122    integer, allocatable, intent(in), target :: a(..)
123    integer, value :: rnk
124    integer, intent(in) :: low(:), high(:), val(:)
125    integer :: i
126
127    if (rank(a) /= rnk) STOP 27
128    if (size(low) /= rnk .or. size(high) /= rnk) STOP 28
129    if (size(a) /= product (high - low +1)) STOP 29
130
131    if (rnk > 0) then
132      if (low(1) /= lbound(a,1)) STOP 30
133      if (high(1) /= ubound(a,1)) STOP 31
134      if (size (a,1) /= high(1)-low(1)+1) STOP 32
135    end if
136
137    do i = 1, rnk
138      if (low(i) /= lbound(a,i)) STOP 33
139      if (high(i) /= ubound(a,i)) STOP 34
140      if (size (a,i) /= high(i)-low(i)+1) STOP 35
141    end do
142    call check_value (a, rnk, val)
143    call foo(a, rnk, low, high, val)
144  end subroutine
145end
146