loc_2.f90

来自「linux下编程用 编译软件」· F90 代码 · 共 114 行

! { dg-do run }
! Series of routines for testing a loc() implementation
program test
  common /errors/errors(12)
  integer i
  logical errors
  errors = .false.
  call testloc
  do i=1,12
     if (errors(i)) then
        call abort()
     endif
  end do
end program test

! Test loc
subroutine testloc
  common /errors/errors(12)
  logical errors
  integer, parameter :: n = 9
  integer, parameter :: m = 10
  integer, parameter :: o = 11
  integer :: offset
  integer :: i,j,k,intsize,realsize,dblsize,chsize,ch8size
  integer itarg1 (n)
  integer itarg2 (m,n)
  integer itarg3 (o,m,n)
  real rtarg1(n)
  real rtarg2(m,n)
  real rtarg3(o,m,n)
  character chtarg1(n)
  character chtarg2(m,n)
  character chtarg3(o,m,n)
  character*8 ch8targ1(n)
  character*8 ch8targ2(m,n)
  character*8 ch8targ3(o,m,n)

  intsize = kind(itarg1(1))
  realsize = kind(rtarg1(1))
  chsize = kind(chtarg1(1))*len(chtarg1(1))
  ch8size = kind(ch8targ1(1))*len(ch8targ1(1))

  do, i=1,n
     offset = i-1
     if (loc(itarg1).ne.loc(itarg1(i))-offset*intsize) then
        ! Error #1
        errors(1) = .true.
     end if
     if (loc(rtarg1).ne.loc(rtarg1(i))-offset*realsize) then
        ! Error #2
        errors(2) = .true.
     end if
     if (loc(chtarg1).ne.loc(chtarg1(i))-offset*chsize) then
        ! Error #3
        errors(3) = .true.
     end if
     if (loc(ch8targ1).ne.loc(ch8targ1(i))-offset*ch8size) then
        ! Error #4
        errors(4) = .true.
     end if

     do, j=1,m
        offset = (j-1)+m*(i-1)
        if (loc(itarg2).ne. &
             loc(itarg2(j,i))-offset*intsize) then
           ! Error #5
           errors(5) = .true.
        end if
        if (loc(rtarg2).ne. &
             loc(rtarg2(j,i))-offset*realsize) then
           ! Error #6
           errors(6) = .true.
        end if
        if (loc(chtarg2).ne. &
             loc(chtarg2(j,i))-offset*chsize) then
           ! Error #7
           errors(7) = .true.
        end if
        if (loc(ch8targ2).ne. &
             loc(ch8targ2(j,i))-offset*ch8size) then
           ! Error #8
           errors(8) = .true.
        end if

        do k=1,o
           offset = (k-1)+o*(j-1)+o*m*(i-1)
           if (loc(itarg3).ne. &
                loc(itarg3(k,j,i))-offset*intsize) then
              ! Error #9
              errors(9) = .true.
           end if
           if (loc(rtarg3).ne. &
                loc(rtarg3(k,j,i))-offset*realsize) then
              ! Error #10
              errors(10) = .true.
           end if
           if (loc(chtarg3).ne. &
                loc(chtarg3(k,j,i))-offset*chsize) then
              ! Error #11
              errors(11) = .true.
           end if
           if (loc(ch8targ3).ne. &
                loc(ch8targ3(k,j,i))-offset*ch8size) then
              ! Error #12
              errors(12) = .true.
           end if

        end do
     end do
  end do

end subroutine testloc