gcc/testsuite/gfortran.dg/internal_pack_6a.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR41113 and PR41117, in which unnecessary calls
   4 ! to internal_pack and internal_unpack were being generated.
   5 !
   6 ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
   7 !
   8 MODULE M1
   9  TYPE T1
  10    REAL :: data(10) = [(i, i = 1, 10)]
  11  END TYPE T1
  12 CONTAINS
  13  SUBROUTINE S1(data, i, chksum)
  14    REAL, DIMENSION(*) :: data
  15    integer :: i, j
  16    real :: subsum, chksum
  17    subsum = 0
  18    do j = 1, i
  19      subsum = subsum + data(j)
  20    end do
  21    if (abs(subsum - chksum) > 1e-6) STOP 1
  22  END SUBROUTINE S1
  23 END MODULE
  24
  25 SUBROUTINE S2
  26  use m1
  27  TYPE(T1) :: d
  28
  29  real :: data1(10) = [(i, i = 1, 10)]
  30  REAL :: data(-4:5,-4:5) = reshape ([(real(i), i = 1, 100)], [10,10])
  31
  32 ! PR41113
  33  CALL S1(d%data, 10, sum (d%data))
  34  CALL S1(data1, 10, sum (data1))
  35
  36 ! PR41117
  37  DO i=-4,5
  38     CALL S1(data(:,i), 10, sum (data(:,i)))
  39  ENDDO
  40
  41 ! With the fix for PR41113/7 this is the only time that _internal_pack
  42 ! was called.  The final part of the fix for PR43072 put paid to it too.
  43  DO i=-4,5
  44     CALL S1(data(-2:,i), 8, sum (data(-2:,i)))
  45  ENDDO
  46  DO i=-4,4
  47     CALL S1(data(:,i:i+1), 20, sum (reshape (data(:,i:i+1), [20])))
  48  ENDDO
  49  DO i=-4,5
  50     CALL S1(data(2,i), 1, data(2,i))
  51  ENDDO
  52 END SUBROUTINE S2
  53
  54  call s2
  55 end
  56