gcc/testsuite/gfortran.dg/PR95196.f90

! { dg-do run }

program rnk_p

  implicit none

  integer, parameter :: n = 10
  integer, parameter :: m = 5
  integer, parameter :: s = 4
  integer, parameter :: l = 4
  integer, parameter :: u = s+l-1
  
  integer :: a(n)
  integer :: b(n,n)
  integer :: c(n,n,n)
  integer :: r(s*s*s)
  integer :: i

  a = reshape([(i, i=1,n)], [n])
  b = reshape([(i, i=1,n*n)], [n,n])
  c = reshape([(i, i=1,n*n*n)], [n,n,n])
  r(1:s) = a(l:u)
  call rnk_s(a(l:u), r(1:s))
  r(1:s*s) = reshape(b(l:u,l:u), [s*s])
  call rnk_s(b(l:u,l:u), r(1:s*s))
  r = reshape(c(l:u,l:u,l:u), [s*s*s])
  call rnk_s(c(l:u,l:7,l:u), r)
  stop
  
contains

  subroutine rnk_s(a, b)
    integer, intent(in) :: a(..)
    integer, intent(in) :: b(:)
    
    !integer :: l(rank(a)), u(rank(a)) does not work due to Bug 94048 
    integer, allocatable :: lb(:), ub(:)
    integer              :: i, j, k, l

    lb = lbound(a)
    ub = ubound(a)
    select rank(a)
    rank(1)
      if(any(lb/=lbound(a))) stop 11
      if(any(ub/=ubound(a))) stop 12
      if(size(a)/=size(b))   stop 13
      do i = 1, size(a)
        if(a(i)/=b(i)) stop 14
      end do
    rank(2)
      if(any(lb/=lbound(a))) stop 21
      if(any(ub/=ubound(a))) stop 22
      if(size(a)/=size(b))   stop 23
      k = 0
      do j = 1, size(a, dim=2)
        do i = 1, size(a, dim=1)
          k = k + 1
          if(a(i,j)/=b(k)) stop 24
        end do
      end do
    rank(3)
      if(any(lb/=lbound(a))) stop 31
      if(any(ub/=ubound(a))) stop 32
      if(size(a)/=size(b))   stop 33
      l = 0
      do k = 1, size(a, dim=3)
        do j = 1, size(a, dim=2)
          do i = 1, size(a, dim=1)
            l = l + 1
            ! print *, a(i,j,k), b(l)
            if(a(i,j,k)/=b(l)) stop 34
          end do
        end do
      end do
    rank default
      stop 171
    end select
    deallocate(lb, ub)
    return
  end subroutine rnk_s
  
end program rnk_p