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