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