gcc/testsuite/gfortran.fortran-torture/execute/where_7.f90

   1 ! Really test where inside forall with temporary
   2 program evil_where
   3   implicit none
   4   type t
   5     logical valid
   6     integer :: s
   7     integer, dimension(:), pointer :: p
   8   end type
   9   type (t), dimension (5) :: v
  10   integer i
  11
  12   allocate (v(1)%p(2))
  13   allocate (v(2)%p(8))
  14   v(3)%p => NULL()
  15   allocate (v(4)%p(8))
  16   allocate (v(5)%p(2))
  17
  18   v(:)%valid = (/.true., .true., .false., .true., .true./)
  19   v(:)%s = (/1, 8, 999, 6, 2/)
  20   v(1)%p(:) = (/9, 10/)
  21   v(2)%p(:) = (/1, 2, 3, 4, 5, 6, 7, 8/)
  22   v(4)%p(:) = (/13, 14, 15, 16, 17, 18, 19, 20/)
  23   v(5)%p(:) = (/11, 12/)
  24
  25   forall (i=1:5,v(i)%valid)
  26     where (v(i)%p(1:v(i)%s).gt.4)
  27       v(i)%p(1:v(i)%s) = v(6-i)%p(1:v(i)%s)
  28     end where
  29   end forall
  30
  31   if (any(v(1)%p(:) .ne. (/11, 10/))) call abort
  32   if (any(v(2)%p(:) .ne. (/1, 2, 3, 4, 17, 18, 19, 20/))) call abort
  33   if (any(v(4)%p(:) .ne. (/1, 2, 3, 4, 5, 6, 19, 20/))) call abort
  34   if (any(v(5)%p(:) .ne. (/9, 10/))) call abort
  35
  36   v(1)%p(:) = (/9, 10/)
  37   v(2)%p(:) = (/1, 2, 3, 4, 5, 6, 7, 8/)
  38   v(4)%p(:) = (/13, 14, 15, 16, 17, 18, 19, 20/)
  39   v(5)%p(:) = (/11, 12/)
  40
  41   forall (i=1:5,v(i)%valid)
  42     where (v(i)%p(1:v(i)%s).le.4)
  43       v(i)%p(1:v(i)%s) = v(6-i)%p(1:v(i)%s)
  44     end where
  45   end forall
  46
  47   if (any(v(1)%p(:) .ne. (/9, 10/))) call abort
  48   if (any(v(2)%p(:) .ne. (/13, 14, 15, 16, 5, 6, 7, 8/))) call abort
  49   if (any(v(4)%p(:) .ne. (/13, 14, 15, 16, 17, 18, 19, 20/))) call abort
  50   if (any(v(5)%p(:) .ne. (/11, 12/))) call abort
  51
  52   ! I should really free the memory I've allocated.
  53 end program