gcc/testsuite/gfortran.dg/bound_6.f90

   1 ! { dg-do run }
   2 ! Test the fix for PR38852 and PR39006 in which LBOUND did not work
   3 ! for some arrays with negative strides.
   4 !
   5 ! Contributed by Dick Hendrickson  <dick.hendrickson@gmail.com>
   6 !                Clive Page        <clivegpage@googlemail.com>
   7 !            and Mikael Morin      <mikael.morin@tele2.fr>
   8 !
   9 program try_je0031
  10   integer ida(4)
  11   real dda(5,5,5,5,5)
  12   integer, parameter :: nx = 4, ny = 3
  13   interface
  14     SUBROUTINE PR38852(IDA,DDA,nf2,nf5,mf2)
  15       INTEGER IDA(4)
  16       REAL DDA(5,5,5,5,5)
  17       TARGET DDA
  18     END SUBROUTINE
  19   end interface
  20   integer :: array1(nx,ny), array2(nx,ny)
  21   data array2 / 1,2,3,4, 10,20,30,40, 100,200,300,400 /
  22   array1 = array2
  23   call PR38852(IDA,DDA,2,5,-2)
  24   call PR39006(array1, array2(:,ny:1:-1))
  25   call mikael         ! http://gcc.gnu.org/ml/fortran/2009-01/msg00342.html
  26 contains
  27   subroutine PR39006(array1, array2)
  28     integer, intent(in) :: array1(:,:), array2(:,:)
  29     integer :: j
  30     do j = 1, ubound(array2,2)
  31       if (any (array1(:,j) .ne. array2(:,4-j))) call abort
  32     end do
  33   end subroutine
  34 end
  35
  36 SUBROUTINE PR38852(IDA,DDA,nf2,nf5,mf2)
  37   INTEGER IDA(4)
  38   REAL DLA(:,:,:,:)
  39   REAL DDA(5,5,5,5,5)
  40   POINTER DLA
  41   TARGET DDA
  42   DLA => DDA(2:3, 1:3:2, 5:4:-1, NF2, NF5:NF2:MF2)
  43   IDA = UBOUND(DLA)
  44   if (any(ida /= 2)) call abort
  45   DLA => DDA(2:3, 1:3:2, 5:4:-1, 2, 5:2:-2)
  46   IDA = UBOUND(DLA)
  47   if (any(ida /= 2)) call abort
  48 !
  49 ! These worked.
  50 !
  51   DLA => DDA(2:3, 1:3:2, 5:4:-1, 2, 5:2:-2)
  52   IDA = shape(DLA)
  53   if (any(ida /= 2)) call abort
  54   DLA => DDA(2:3, 1:3:2, 5:4:-1, 2, 5:2:-2)
  55   IDA = LBOUND(DLA)
  56   if (any(ida /= 1)) call abort
  57 END SUBROUTINE
  58
  59 subroutine mikael
  60   implicit none
  61   call test (1,  3, 3)
  62   call test (2,  3, 3)
  63   call test (2, -1, 0)
  64   call test (1, -1, 0)
  65 contains
  66   subroutine test (a, b, expect)
  67     integer :: a, b, expect
  68     integer :: c(a:b)
  69     if (ubound (c, 1) .ne. expect) call abort
  70   end subroutine test
  71 end subroutine