1! { dg-do run }
2! { dg-options "-std=legacy" }
3!
4! Series of routines for testing a loc() implementation
5program 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
16end program test
17
18! Test loc
19subroutine 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
114end subroutine testloc
115
116