1! { dg-do run }
2!
3! Testcase for PR 94289
4!
5! - if the dummy argument is a pointer/allocatable, it has the same
6!   bounds as the dummy argument
7! - if is is nonallocatable nonpointer, the lower bounds are [1, 1, 1].
8
9module bounds_m
10
11  implicit none
12
13  private
14  public :: &
15    lb, ub
16
17  public :: &
18    bnds_p, &
19    bnds_a, &
20    bnds_e
21
22  integer, parameter :: lb1 = 3
23  integer, parameter :: lb2 = 5
24  integer, parameter :: lb3 = 9
25  integer, parameter :: ub1 = 4
26  integer, parameter :: ub2 = 50
27  integer, parameter :: ub3 = 11
28  integer, parameter :: ex1 = ub1 - lb1 + 1
29  integer, parameter :: ex2 = ub2 - lb2 + 1
30  integer, parameter :: ex3 = ub3 - lb3 + 1
31
32  integer, parameter :: lf(*) = [1,1,1]
33  integer, parameter :: lb(*) = [lb1,lb2,lb3]
34  integer, parameter :: ub(*) = [ub1,ub2,ub3]
35  integer, parameter :: ex(*) = [ex1,ex2,ex3]
36
37contains
38
39  subroutine bounds(a, lb, ub)
40    integer, pointer, intent(in) :: a(..)
41    integer,          intent(in) :: lb(3)
42    integer,          intent(in) :: ub(3)
43
44    integer :: ex(3)
45
46    ex = max(ub-lb+1, 0)
47    if(any(lbound(a)/=lb)) stop 101
48    if(any(ubound(a)/=ub)) stop 102
49    if(any( shape(a)/=ex)) stop 103
50    return
51  end subroutine bounds
52
53  subroutine bnds_p(this)
54    integer, pointer, intent(in) :: this(..)
55
56    if(any(lbound(this)/=lb)) stop 1
57    if(any(ubound(this)/=ub)) stop 2
58    if(any( shape(this)/=ex)) stop 3
59    call bounds(this, lb, ub)
60    return
61  end subroutine bnds_p
62
63  subroutine bnds_a(this)
64    integer, allocatable, target, intent(in) :: this(..)
65
66    if(any(lbound(this)/=lb)) stop 4
67    if(any(ubound(this)/=ub)) stop 5
68    if(any( shape(this)/=ex)) stop 6
69    call bounds(this, lb, ub)
70    return
71  end subroutine bnds_a
72
73  subroutine bnds_e(this)
74    integer, target, intent(in) :: this(..)
75
76    if(any(lbound(this)/=lf)) stop 7
77    if(any(ubound(this)/=ex)) stop 8
78    if(any( shape(this)/=ex)) stop 9
79    call bounds(this, lf, ex)
80    return
81  end subroutine bnds_e
82
83end module bounds_m
84
85program bounds_p
86
87  use, intrinsic :: iso_c_binding, only: c_int
88
89  use bounds_m
90
91  implicit none
92
93  integer, parameter :: fpn = 1
94  integer, parameter :: fan = 2
95  integer, parameter :: fon = 3
96
97  integer :: i
98
99  do i = fpn, fon
100    call test_p(i)
101  end do
102  do i = fpn, fon
103    call test_a(i)
104  end do
105  do i = fpn, fon
106    call test_e(i)
107  end do
108  stop
109
110contains
111
112  subroutine test_p(t)
113    integer, intent(in) :: t
114
115    integer, pointer :: a(:,:,:)
116
117    allocate(a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3)))
118    select case(t)
119    case(fpn)
120      call bnds_p(a)
121    case(fan)
122    case(fon)
123      call bnds_e(a)
124    case default
125      stop
126    end select
127    deallocate(a)
128    return
129  end subroutine test_p
130
131  subroutine test_a(t)
132    integer, intent(in) :: t
133
134    integer, allocatable, target :: a(:,:,:)
135
136    allocate(a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3)))
137    select case(t)
138    case(fpn)
139      call bnds_p(a)
140    case(fan)
141      call bnds_a(a)
142    case(fon)
143      call bnds_e(a)
144    case default
145      stop
146    end select
147    deallocate(a)
148    return
149  end subroutine test_a
150
151  subroutine test_e(t)
152    integer, intent(in) :: t
153
154    integer, target :: a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3))
155
156    select case(t)
157    case(fpn)
158      call bnds_p(a)
159    case(fan)
160    case(fon)
161      call bnds_e(a)
162    case default
163      stop
164    end select
165    return
166  end subroutine test_e
167
168end program bounds_p
169