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