gcc/testsuite/gfortran.dg/assumed_rank_1.f90

! { dg-do run }
! { dg-additional-sources assumed_rank_1_c.c }
!
! PR fortran/48820
!
! Assumed-rank tests
!

implicit none

interface
  subroutine check_value(b, n, val)
    integer :: b(..)
    integer, value :: n
    integer :: val(n)
  end subroutine
end interface

integer, target :: x(2:5,4:7), y(-4:4)
integer, allocatable, target :: z(:,:,:,:)
integer, allocatable :: val(:)
integer :: i

allocate(z(1:4, -2:5, 4, 10:11))

if (rank(x) /= 2) call abort ()
val = [(2*i+3, i = 1, size(x))]
x = reshape (val, shape(x))
call foo(x, rank(x), lbound(x), ubound(x), val)
call foo2(x, rank(x), lbound(x), ubound(x), val)
call bar(x,x,.true.)
call bar(x,prsnt=.false.)

if (rank(y) /= 1) call abort ()
val = [(2*i+7, i = 1, size(y))]
y = reshape (val, shape(y))
call foo(y, rank(y), lbound(y), ubound(y), val)
call foo2(y, rank(y), lbound(y), ubound(y), val)
call bar(y,y,.true.)
call bar(y,prsnt=.false.)

if (rank(z) /= 4) call abort ()
val = [(2*i+5, i = 1, size(z))]
z(:,:,:,:) = reshape (val, shape(z))
call foo(z, rank(z), lbound(z), ubound(z), val)
call foo(z, rank(z), lbound(z), ubound(z), val)
call foo2(z, rank(z), lbound(z), ubound(z), val)
call bar(z,z,.true.)
call bar(z,prsnt=.false.)

contains
  subroutine bar(a,b, prsnt)
    integer, pointer, optional, intent(in) :: a(..),b(..)
    logical, value :: prsnt
    if (.not. associated(a)) call abort()
    if (present(b)) then
       ! The following is not valid.
       ! Technically, it could be allowed and might be in Fortran 2015:
       ! if (.not. associated(a,b)) call abort()
    else
      if (.not. associated(a)) call abort()
    end if
    if (.not. present(a)) call abort()
    if (prsnt .neqv. present(b)) call abort()
  end subroutine

  ! POINTER argument - bounds as specified before
  subroutine foo(a, rnk, low, high, val)
    integer,pointer, intent(in) :: a(..)
    integer, value :: rnk
    integer, intent(in) :: low(:), high(:), val(:)
    integer :: i



    if (rank(a) /= rnk) call abort()
    if (size(low) /= rnk .or. size(high) /= rnk) call abort()
    if (size(a) /= product (high - low +1)) call abort()

    if (rnk > 0) then
      if (low(1) /= lbound(a,1)) call abort()
      if (high(1) /= ubound(a,1)) call abort()
      if (size (a,1) /= high(1)-low(1)+1) call abort()
    end if

    do i = 1, rnk
      if (low(i) /= lbound(a,i)) call abort()
      if (high(i) /= ubound(a,i)) call abort()
      if (size (a,i) /= high(i)-low(i)+1) call abort()
    end do
    call check_value (a, rnk, val)
    call foo2(a, rnk, low, high, val)
  end subroutine

  ! Non-pointer, non-allocatable bounds. lbound == 1
  subroutine foo2(a, rnk, low, high, val)
    integer, intent(in) :: a(..)
    integer, value :: rnk
    integer, intent(in) :: low(:), high(:), val(:)
    integer :: i

    if (rank(a) /= rnk) call abort()
    if (size(low) /= rnk .or. size(high) /= rnk) call abort()
    if (size(a) /= product (high - low +1)) call abort()

    if (rnk > 0) then
      if (1 /= lbound(a,1)) call abort()
      if (high(1)-low(1)+1 /= ubound(a,1)) call abort()
      if (size (a,1) /= high(1)-low(1)+1) call abort()
    end if

    do i = 1, rnk
      if (1 /= lbound(a,i)) call abort()
      if (high(i)-low(i)+1 /= ubound(a,i)) call abort()
      if (size (a,i) /= high(i)-low(i)+1) call abort()
    end do
    call check_value (a, rnk, val)
  end subroutine foo2

  ! ALLOCATABLE argument - bounds as specified before
  subroutine foo3 (a, rnk, low, high, val)
    integer, allocatable, intent(in), target :: a(..)
    integer, value :: rnk
    integer, intent(in) :: low(:), high(:), val(:)
    integer :: i

    if (rank(a) /= rnk) call abort()
    if (size(low) /= rnk .or. size(high) /= rnk) call abort()
    if (size(a) /= product (high - low +1)) call abort()

    if (rnk > 0) then
      if (low(1) /= lbound(a,1)) call abort()
      if (high(1) /= ubound(a,1)) call abort()
      if (size (a,1) /= high(1)-low(1)+1) call abort()
    end if

    do i = 1, rnk
      if (low(i) /= lbound(a,i)) call abort()
      if (high(i) /= ubound(a,i)) call abort()
      if (size (a,i) /= high(i)-low(i)+1) call abort()
    end do
    call check_value (a, rnk, val)
    call foo(a, rnk, low, high, val)
  end subroutine
end