gcc/testsuite/gfortran.dg/bound_6.f90

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