gcc/testsuite/gfortran.dg/loc_2.f90

   1 ! { dg-do run }
   2 ! Series of routines for testing a loc() implementation
   3 program test
   4   common /errors/errors(12)
   5   integer i
   6   logical errors
   7   errors = .false.
   8   call testloc
   9   do i=1,12
  10      if (errors(i)) then
  11         call abort()
  12      endif
  13   end do
  14 end program test
  15
  16 ! Test loc
  17 subroutine testloc
  18   common /errors/errors(12)
  19   logical errors
  20   integer, parameter :: n = 9
  21   integer, parameter :: m = 10
  22   integer, parameter :: o = 11
  23   integer :: offset
  24   integer :: i,j,k,intsize,realsize,dblsize,chsize,ch8size
  25   integer itarg1 (n)
  26   integer itarg2 (m,n)
  27   integer itarg3 (o,m,n)
  28   real rtarg1(n)
  29   real rtarg2(m,n)
  30   real rtarg3(o,m,n)
  31   character chtarg1(n)
  32   character chtarg2(m,n)
  33   character chtarg3(o,m,n)
  34   character*8 ch8targ1(n)
  35   character*8 ch8targ2(m,n)
  36   character*8 ch8targ3(o,m,n)
  37
  38   intsize = kind(itarg1(1))
  39   realsize = kind(rtarg1(1))
  40   chsize = kind(chtarg1(1))*len(chtarg1(1))
  41   ch8size = kind(ch8targ1(1))*len(ch8targ1(1))
  42
  43   do, i=1,n
  44      offset = i-1
  45      if (loc(itarg1).ne.loc(itarg1(i))-offset*intsize) then
  46         ! Error #1
  47         errors(1) = .true.
  48      end if
  49      if (loc(rtarg1).ne.loc(rtarg1(i))-offset*realsize) then
  50         ! Error #2
  51         errors(2) = .true.
  52      end if
  53      if (loc(chtarg1).ne.loc(chtarg1(i))-offset*chsize) then
  54         ! Error #3
  55         errors(3) = .true.
  56      end if
  57      if (loc(ch8targ1).ne.loc(ch8targ1(i))-offset*ch8size) then
  58         ! Error #4
  59         errors(4) = .true.
  60      end if
  61
  62      do, j=1,m
  63         offset = (j-1)+m*(i-1)
  64         if (loc(itarg2).ne. &
  65              loc(itarg2(j,i))-offset*intsize) then
  66            ! Error #5
  67            errors(5) = .true.
  68         end if
  69         if (loc(rtarg2).ne. &
  70              loc(rtarg2(j,i))-offset*realsize) then
  71            ! Error #6
  72            errors(6) = .true.
  73         end if
  74         if (loc(chtarg2).ne. &
  75              loc(chtarg2(j,i))-offset*chsize) then
  76            ! Error #7
  77            errors(7) = .true.
  78         end if
  79         if (loc(ch8targ2).ne. &
  80              loc(ch8targ2(j,i))-offset*ch8size) then
  81            ! Error #8
  82            errors(8) = .true.
  83         end if
  84
  85         do k=1,o
  86            offset = (k-1)+o*(j-1)+o*m*(i-1)
  87            if (loc(itarg3).ne. &
  88                 loc(itarg3(k,j,i))-offset*intsize) then
  89               ! Error #9
  90               errors(9) = .true.
  91            end if
  92            if (loc(rtarg3).ne. &
  93                 loc(rtarg3(k,j,i))-offset*realsize) then
  94               ! Error #10
  95               errors(10) = .true.
  96            end if
  97            if (loc(chtarg3).ne. &
  98                 loc(chtarg3(k,j,i))-offset*chsize) then
  99               ! Error #11
 100               errors(11) = .true.
 101            end if
 102            if (loc(ch8targ3).ne. &
 103                 loc(ch8targ3(k,j,i))-offset*ch8size) then
 104               ! Error #12
 105               errors(12) = .true.
 106            end if
 107
 108         end do
 109      end do
 110   end do
 111
 112 end subroutine testloc
 113