1! { dg-do run }
2!
3! This test case is inserted as a check. PR89365 inially asserted that
4! gfortran was getting the bounds wrong for allocatable and pointer
5! actual arguments. However, the reporter accepted that it is OK and
6! this is the corrected version of his testcase, which fills a gap in
7! the testsuite.
8!
9! Contributed by Reinhold Bader  <Bader@lrz.de>
10!
11module mod_ass_rank_inquiry
12  use, intrinsic :: iso_c_binding
13  implicit none
14  logical, parameter :: debug = .true.
15  integer :: error_count = 0
16!
17! using inquiry functions for assumed rank objects
18!
19  contains
20    subroutine foo_1(this)
21      real(c_float) :: this(..)
22      select case(rank(this))
23      case(0)
24         if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. &
25              size(ubound(this)) > 0) then
26            error_count = error_count + 1
27            if (debug) write(*,*) 'FAIL shape / lbound  / ubound'
28         end if
29         if (size(this) /= 1) then
30            error_count = error_count + 1
31            if (debug) write(*,*) 'FAIL size'
32         end if
33      case(1)
34         if (sum(abs(shape(this) -  [4])) > 0) then
35            error_count = error_count + 1
36            if (debug) write(*,*) 'FAIL shape'
37         end if
38         if (size(this) /= 4) then
39            error_count = error_count + 1
40            if (debug) write(*,*) 'FAIL size', size(this)
41         end if
42         if (lbound(this,1) /= 1) then
43            error_count = error_count + 1
44            if (debug) write(*,*) 'FAIL lbound',lbound(this,1)
45         end if
46         if (ubound(this,1) /= 4) then
47            error_count = error_count + 1
48            if (debug) write(*,*) 'FAIL ubound',ubound(this,1)
49         end if
50      case(3)
51         if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then
52            error_count = error_count + 1
53            if (debug) write(*,*) 'FAIL shape'
54         end if
55         if (size(this) /= 2*3*4) then
56            error_count = error_count + 1
57            if (debug) write(*,*) 'FAIL size'
58         end if
59         if (sum(abs(lbound(this) - [ 1, 1, 1 ])) > 0) then
60            error_count = error_count + 1
61            if (debug) write(*,*) 'FAIL lbound'
62         end if
63         if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then
64            error_count = error_count + 1
65            if (debug) write(*,*) 'FAIL ubound'
66         end if
67      case default
68         error_count = error_count + 1
69      end select
70    end subroutine foo_1
71    subroutine foo_2(this)
72      real(c_float), allocatable :: this(..)
73      if (.not. allocated(this)) then
74         error_count = error_count + 1
75         if (debug) write(*,*) 'FAIL allocated'
76      end if
77      select case(rank(this))
78      case(0)
79         if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. &
80              size(ubound(this)) > 0) then
81            error_count = error_count + 1
82            if (debug) write(*,*) 'FAIL shape / lbound  / ubound'
83         end if
84         if (size(this) /= 1) then
85            error_count = error_count + 1
86            if (debug) write(*,*) 'FAIL size'
87         end if
88      case(1)
89         if (sum(abs(shape(this) -  [4])) > 0) then
90            error_count = error_count + 1
91            if (debug) write(*,*) 'FAIL shape'
92         end if
93         if (size(this) /= 4) then
94            error_count = error_count + 1
95            if (debug) write(*,*) 'FAIL size', size(this)
96         end if
97         if (lbound(this,1) /= 2) then
98            error_count = error_count + 1
99            if (debug) write(*,*) 'FAIL lbound',lbound(this,1)
100         end if
101         if (ubound(this,1) /= 5) then
102            error_count = error_count + 1
103            if (debug) write(*,*) 'FAIL ubound',ubound(this,1)
104         end if
105      case(3)
106         if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then
107            error_count = error_count + 1
108            if (debug) write(*,*) 'FAIL shape'
109         end if
110         if (size(this) /= 2*3*4) then
111            error_count = error_count + 1
112            if (debug) write(*,*) 'FAIL size'
113         end if
114         if (sum(abs(lbound(this) - [ 0, -1, 1 ])) > 0) then
115            error_count = error_count + 1
116            if (debug) write(*,*) 'FAIL lbound', lbound(this)
117         end if
118         if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then
119            error_count = error_count + 1
120            if (debug) write(*,*) 'FAIL ubound', ubound(this)
121         end if
122      case default
123         error_count = error_count + 1
124      end select
125    end subroutine foo_2
126    subroutine foo_3(this)
127      real(c_float), pointer :: this(..)
128      if (.not. associated(this)) then
129         error_count = error_count + 1
130         if (debug) write(*,*) 'FAIL associated'
131      end if
132      select case(rank(this))
133      case(0)
134         if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. &
135              size(ubound(this)) > 0) then
136            error_count = error_count + 1
137            if (debug) write(*,*) 'FAIL shape / lbound  / ubound'
138         end if
139         if (size(this) /= 1) then
140            error_count = error_count + 1
141            if (debug) write(*,*) 'FAIL size'
142         end if
143      case(1)
144         if (sum(abs(shape(this) -  [4])) > 0) then
145            error_count = error_count + 1
146            if (debug) write(*,*) 'FAIL shape'
147         end if
148         if (size(this) /= 4) then
149            error_count = error_count + 1
150            if (debug) write(*,*) 'FAIL size', size(this)
151         end if
152         if (lbound(this,1) /= 2) then
153            error_count = error_count + 1
154            if (debug) write(*,*) 'FAIL lbound',lbound(this,1)
155         end if
156         if (ubound(this,1) /= 5) then
157            error_count = error_count + 1
158            if (debug) write(*,*) 'FAIL ubound',ubound(this,1)
159         end if
160      case(3)
161         if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then
162            error_count = error_count + 1
163            if (debug) write(*,*) 'FAIL shape'
164         end if
165         if (size(this) /= 2*3*4) then
166            error_count = error_count + 1
167            if (debug) write(*,*) 'FAIL size'
168         end if
169         if (sum(abs(lbound(this) - [ 0, -1, 1 ])) > 0) then
170            error_count = error_count + 1
171            if (debug) write(*,*) 'FAIL lbound', lbound(this)
172         end if
173         if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then
174            error_count = error_count + 1
175            if (debug) write(*,*) 'FAIL ubound', ubound(this)
176         end if
177      case default
178         error_count = error_count + 1
179      end select
180    end subroutine foo_3
181end module mod_ass_rank_inquiry
182program ass_rank_inquiry
183  use mod_ass_rank_inquiry
184  implicit none
185  real, allocatable :: x, y(:), z(:,:,:)
186  real, pointer :: xp, yp(:), zp(:,:,:)
187
188  allocate(x, y(2:5), z(0:1,-1:1,1:4))
189  allocate(xp, yp(2:5), zp(0:1,-1:1,1:4))
190
191
192  call foo_1(x)
193  if (error_count > 0) write(*,*) 'FAIL: after scalar ',error_count
194  call foo_1(y)
195  if (error_count > 0) write(*,*) 'FAIL: after rank-1 ',error_count
196  call foo_1(z)
197  if (error_count > 0) write(*,*) 'FAIL: after rank-3 ',error_count
198  call foo_2(x)
199  if (error_count > 0) write(*,*) 'FAIL: after allocscalar ',error_count
200  call foo_2(y)
201  if (error_count > 0) write(*,*) 'FAIL: after allocrank-1 ',error_count
202  call foo_2(z)
203  if (error_count > 0) write(*,*) 'FAIL: after allocrank-3 ',error_count
204  call foo_3(xp)
205  if (error_count > 0) write(*,*) 'FAIL: after ptrscalar ',error_count
206  call foo_3(yp)
207  if (error_count > 0) write(*,*) 'FAIL: after ptrrank-1 ',error_count
208  call foo_3(zp)
209  if (error_count > 0) write(*,*) 'FAIL: after ptrrank-3 ',error_count
210
211  if (error_count == 0) then
212    write(*,*) 'OK'
213  else
214    stop 1
215  end if
216
217  deallocate(x, y, z)
218  deallocate(xp, yp, zp)
219end program ass_rank_inquiry
220