gcc/testsuite/gfortran.dg/loc_2.f90

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