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