gcc/testsuite/gfortran.dg/contiguous_8.f90

   1 ! { dg-do  run }
   2 ! PR 56789 - packing / unpacking of contiguous arguments
   3 ! did not happen.
   4
   5 module my_module
   6   implicit none
   7 contains
   8   subroutine cont_arg(a)
   9     real, contiguous :: a(:,:)
  10     integer :: i,j
  11     do j=1,size(a,2)
  12        do i=1,size(a,1)
  13           a(i,j) = i+10*j
  14        end do
  15     end do
  16   end subroutine cont_arg
  17   subroutine cont_pointer_arg (a)
  18     integer, pointer, contiguous :: a(:)
  19     call assumed_size(a)
  20     call assumed_size(a(::1))
  21     call assumed_size_2(a(::2))
  22   end subroutine cont_pointer_arg
  23
  24   subroutine assumed_size(y)
  25     integer, dimension(*) :: y
  26     if (y(2) /= 2 .or. y(3) /= 3 .or. y(4) /= 4 .or. y(5) /= 5 .or. y(6) /= 6) &
  27             stop 2
  28   end subroutine assumed_size
  29
  30   subroutine assumed_size_2(y)
  31     integer, dimension(*) :: y
  32     if (y(1) /= 1 .or. y(2) /= 3 .or. y(3) /= 5) stop 3
  33   end subroutine assumed_size_2
  34
  35   subroutine cont_assumed_shape(x)
  36     integer, dimension(:), contiguous :: x
  37     if (size(x,1) == 8) then
  38        if (any(x /= [1,2,3,4,5,6,7,8])) stop 4
  39     else
  40        if (any(x /= [1,3,5,7])) stop 5
  41     end if
  42   end subroutine cont_assumed_shape
  43 end module my_module
  44
  45 program main
  46   use my_module
  47   implicit none
  48   real, dimension(5,5) :: a
  49   real, dimension(5,5) :: res
  50   integer, dimension(8), target :: t
  51   integer, dimension(:), pointer, contiguous :: p
  52   res = reshape([11., 1.,12., 1.,13.,&
  53                   1., 1., 1., 1., 1.,&
  54                  21., 1.,22., 1.,23.,&
  55                   1., 1., 1., 1., 1.,&
  56                  31., 1.,32., 1., 33.], shape(res))
  57   a = 1.
  58   call cont_arg(a(1:5:2,1:5:2))
  59   if (any(a /= res)) stop 1
  60   t = [1,2,3,4,5,6,7,8]
  61   p => t
  62   call cont_pointer_arg(p)
  63   call cont_assumed_shape (t)
  64   call cont_assumed_shape (t(::2))
  65 end program main