Am 23.10.18 um 18:16 schrieb Dominique d'Humières:
Anyway, the attached patch fixes this,It now gives the error 4 | integer, parameter :: I_FINDLOC_BACK(1) = findloc([1,1],1, & | 1 Error: transformational intrinsic 'findloc' at (1) is not permitted in an initialization expression
That error message was misleading, the new one now hasError: Parameter 'x' at (1) has not been declared or is a variable, which does not reduce to a constant expression
The following test
program logtest3
implicit none
! ********************************************************!
! ******* Everything depends on this parameter ***********!
integer, parameter :: A1 = 2
logical :: L
L = transfer(A1,L)
call sub(L)
end program logtest3
subroutine sub(x)
implicit none
logical x
integer a(1)
character(*), parameter :: strings(2) = ['.TRUE. ','.FALSE.']
a = findloc([1,1],1,mask=[x,.TRUE.])
write(*,'(a)') 'Value by FINDLOC(MASK): '// &
trim(strings(a(1)))
a = findloc([1,1],1,back=x)
write(*,'(a)') 'Value by FINDLOC(BACK): '// &
trim(strings(3-a(1)))
end subroutine sub
does not link:
8 | L = transfer(A1,L)
| 1
Warning: Assigning value other than 0 or 1 to LOGICAL has undefined result at
(1)
Undefined symbols for architecture x86_64:
"__gfortran_findloc0_i4", referenced from:
_sub_ in ccnoLKfH.o
"__gfortran_mfindloc0_i4", referenced from:
_sub_ in ccnoLKfH.o
ld: symbol(s) not found for architecture x86_64
collect2: error: ld returned 1 exit status
Ah, I didn't include the newly generated files in the previous patch. Now included.
Finally the line before the end of findloc_6.f90 should be if (findloc(ch,"CC ",dim=1,mask=false) /= 0) stop 23
Changed, also the whitespace fixes that Bernhard mentioned.
So, I think this should be clear for trunk now. I will supply
the documentation later.
Regards
Thomas
! { dg-do compile }
! Test errors in findloc.
program main
integer, dimension(4) :: a
logical, dimension(3) :: msk
a = [2,4,6,8]
print *,findloc(a) ! { dg-error "Missing actual argument" }
print *,findloc(a,value=.true.) ! { dg-error "must be in type conformance to argument" }
print *,findloc(a,23,dim=6) ! { dg-error "is not a valid dimension index" }
print *,findloc(a,-42,dim=2.0) ! { dg-error "must be INTEGER" }
print *,findloc(a,6,msk) ! { dg-error "Different shape for arguments 'array' and 'mask'" }
print *,findloc(a,6,kind=98) ! { dg-error "Invalid kind for INTEGER" }
end program main
! { dg-do run }
! Various tests with findloc.
program main
implicit none
real, dimension(2,2) :: a, b
integer, dimension(2,3) :: c
logical, dimension(2,2) :: lo
integer, dimension(:), allocatable :: e
a = reshape([1.,2.,3.,4.], shape(a))
b = reshape([1.,2.,1.,2.], shape(b))
lo = .true.
if (any(findloc(a, 5.) /= [0,0])) stop 1
if (any(findloc(a, 5., back=.true.) /= [0,0])) stop 2
if (any(findloc(a, 2.) /= [2,1])) stop 2
if (any(findloc(a, 2. ,back=.true.) /= [2,1])) stop 3
if (any(findloc(a,3.,mask=lo) /= [1,2])) stop 4
if (any(findloc(a,3,mask=.true.) /= [1,2])) stop 5
lo(1,2) = .false.
if (any(findloc(a,3.,mask=lo) /= [0,0])) stop 6
if (any(findloc(b,2.) /= [2,1])) stop 7
if (any(findloc(b,2.,back=.true.) /= [2,2])) stop 8
if (any(findloc(b,1.,mask=lo,back=.true.) /= [1,1])) stop 9
if (any(findloc(b,1.,mask=.false.) /= [0,0])) stop 10
c = reshape([1,2,2,2,-9,6], shape(c))
if (any(findloc(c,value=2,dim=1) /= [2,1,0])) stop 11
if (any(findloc(c,value=2,dim=2) /= [2,1])) stop 12
end program main
! { dg-do run }
! Various tests with findloc with character variables.
program main
character(len=2) :: a(3,3), c(3,3), d(3,4)
character(len=3) :: b(3,3)
integer :: ret(2)
integer :: i,j
character(len=3) :: s
logical :: lo
logical, dimension(3,4) :: msk
data a /"11", "21", "31", "12", "22", "32", "13", "23", "33" /
data b /"11 ", "21 ", "31 ", "12 ", "22 ", "32 ", "13 ", "23 ", "33 " /
if (any(findloc(a,"11 ") /= [1,1])) stop 1
ret = findloc(b,"31")
do j=1,3
do i=1,3
write(unit=s,fmt='(2I1," ")') i,j
ret = findloc(b,s)
if (b(ret(1),ret(2)) /= s) stop 2
end do
end do
if (any(findloc(b(::2,::2),"13") /= [1,2])) stop 3
do j=1,3
do i=1,3
write(unit=c(i,j),fmt='(I2)') 2+i-j
end do
end do
if (any(findloc(c," 1") /= [1,2])) stop 4
if (any(findloc(c," 1", back=.true.) /= [2,3])) stop 5
if (any(findloc(c," 1", back=.true., mask=.false.) /= [0,0])) stop 6
lo = .true.
if (any(findloc(c," 2", dim=1) /= [1,2,3])) stop 7
if (any(findloc(c," 2",dim=1,mask=lo) /= [1,2,3])) stop 8
if (any(findloc(c," 2", dim=1,back=.true.) /= [1,2,3])) stop 9
if (any(findloc(c," 2",dim=1,mask=lo,back=.true.) /= [1,2,3])) stop 10
do j=1,4
do i=1,3
if (j<= i) then
d(i,j) = "AA"
else
d(i,j) = "BB"
end if
end do
end do
print '(4A3)', transpose(d)
if (any(findloc(d,"AA") /= [1,1])) stop 11
if (any(findloc(d,"BB") /= [1,2])) stop 12
msk = .true.
if (any(findloc(d,"AA", mask=msk) /= [1,1])) stop 11
if (any(findloc(d,"BB", mask=msk) /= [1,2])) stop 12
if (any(findloc(d,"AA", dim=1) /= [1,2,3,0])) stop 13
if (any(findloc(d,"BB", dim=1) /= [0,1,1,1])) stop 14
if (any(findloc(d,"AA", dim=2) /= [1,1,1])) stop 15
if (any(findloc(d,"BB", dim=2) /= [2,3,4])) stop 16
if (any(findloc(d,"AA", dim=1,mask=msk) /= [1,2,3,0])) stop 17
if (any(findloc(d,"BB", dim=1,mask=msk) /= [0,1,1,1])) stop 18
if (any(findloc(d,"AA", dim=2,mask=msk) /= [1,1,1])) stop 19
if (any(findloc(d,"BB", dim=2,mask=msk) /= [2,3,4])) stop 20
if (any(findloc(d,"AA", dim=1, back=.true.) /= [3,3,3,0])) stop 21
if (any(findloc(d,"AA", dim=1, back=.true., mask=msk) /= [3,3,3,0])) stop 22
if (any(findloc(d,"BB", dim=2, back=.true.) /= [4,4,4])) stop 23
if (any(findloc(d,"BB", dim=2, back=.true.,mask=msk) /= [4,4,4])) stop 24
msk(1,:) = .false.
print '(4L3)', transpose(msk)
if (any(findloc(d,"AA", dim=1,mask=msk) /= [2,2,3,0])) stop 21
if (any(findloc(d,"BB", dim=2,mask=msk) /= [0,3,4])) stop 22
if (any(findloc(d,"AA", dim=2, mask=msk, back=.true.) /= [0,2,3])) stop 23
if (any(findloc(d,"AA", dim=1, mask=msk, back=.true.) /= [3,3,3,0])) stop 24
end program main
! { dg-do run }
! Test findloc with dim argument.
program main
implicit none
real, dimension(2,2) :: a, b
logical, dimension(2,2) :: lo
a = reshape([1.,2.,3.,4.], shape(a))
b = reshape([1.,1.,1.,1.], shape(b))
lo = .true.
if (any(findloc(b,value=1.,dim=1) /= [1,1])) stop 1
if (any(findloc(b,value=1.,dim=2) /= [1,1])) stop 2
if (any(findloc(b,value=1.,dim=1,back=.true.) /= [2,2])) stop 3
if (any(findloc(b,value=1.,dim=2,back=.true.) /= [2,2])) stop 4
if (any(findloc(b,value=1.,dim=1,mask=lo) /= [1,1])) stop 5
if (any(findloc(b,value=1.,dim=1,mask=lo,back=.true.) /= [2,2])) stop 6
if (any(findloc(b,value=1.,dim=1,mask=.not. lo) /= [0,0])) stop 7
lo(1,1) = .false.
if (any(findloc(b,value=1.,dim=1,mask=lo) /= [2,1])) stop 8
if (any(findloc(a,value=1.5,dim=2,back=.true.) /= [0,0])) stop 9
if (any(findloc(a,value=1,dim=1,mask=lo) /= [0,0])) stop 10
end program main
! { dg-do run }
! Check compile-time simplification of FINDLOC
program main
integer, dimension(4), parameter :: a1 = [1, 2, 3, 1]
integer, parameter :: i1 = findloc(a1, 1, dim=1)
integer, parameter :: i2 = findloc(a1, 2, dim=1)
integer, parameter :: i3 = findloc(a1, 3, dim=1)
integer, parameter :: i4 = findloc(a1, 1, dim=1, back=.true.)
integer, parameter :: i0 = findloc(a1, -1, dim=1)
logical, dimension(4), parameter :: msk = [.false., .true., .true., .true.]
integer, parameter :: i4a = findloc(a1, 1, dim=1, mask=msk)
integer, parameter :: i4b = findloc(a1, 1, dim=1, mask=msk, back=.true.)
real, dimension(2,2), parameter :: a = reshape([1.,2.,3.,4.], [2,2]), &
b = reshape([1.,2.,1.,2.], [2,2])
integer, parameter, dimension(2) :: t8 = findloc(a, 5.), t9 = findloc(a, 5., back=.true.)
integer, parameter, dimension(2) :: t10= findloc(a, 2.), t11= findloc(a, 2., back=.true.)
logical, dimension(2,2), parameter :: lo = reshape([.true., .false., .true., .true. ], [2,2])
integer, parameter, dimension(2) :: t12 = findloc(b,2., mask=lo)
integer, dimension(2,3), parameter :: c = reshape([1,2,2,2,-9,6], [2,3])
integer, parameter, dimension(3) :: t13 = findloc(c, value=2, dim=1)
integer, parameter, dimension(2) :: t14 = findloc(c, value=2, dim=2)
character(len=2), dimension(3,3), parameter :: ac = reshape ( &
["11", "21", "31", "12", "22", "32", "13", "23", "33"], [3,3]);
character(len=3), dimension(3,3), parameter :: bc = reshape (&
["11 ", "21 ", "31 ", "12 ", "22 ", "32 ", "13 ", "23 ", "33 "], [3,3]);
integer, parameter, dimension(2) :: t15 = findloc(ac, "11")
integer, parameter, dimension(2) :: t16 = findloc(bc, "31")
if (i1 /= 1) stop 1
if (i2 /= 2) stop 2
if (i3 /= 3) stop 3
if (i4 /= 4) stop 4
if (i0 /= 0) stop 5
if (i4a /= 4) stop 6
if (i4b /= 4) stop 7
if (any(t8 /= [0,0])) stop 8
if (any(t9 /= [0,0])) stop 9
if (any(t10 /= [2,1])) stop 10
if (any(t11 /= [2,1])) stop 11
if (any(t12 /= [2,2])) stop 12
if (any(t13 /= [2,1,0])) stop 13
if (any(t14 /= [2,1])) stop 14
if (any(t15 /= [1,1])) stop 15
if (any(t16 /= [3,1])) stop 16
end program main
! { dg-do run }
! Test different code paths for findloc with scalar result.
program main
integer, dimension(0:5) :: a = [1,2,3,1,2,3]
logical, dimension(6) :: mask = [.false.,.false.,.false.,.true.,.true.,.true.]
logical, dimension(6) :: mask2
logical :: true, false
character(len=2), dimension(6) :: ch = ["AA", "BB", "CC", "AA", "BB", "CC"]
true = .true.
false = .false.
mask2 = .not. mask
! Tests without mask
if (findloc(a,2,dim=1,back=false) /= 2) stop 1
if (findloc(a,2,dim=1,back=.false.) /= 2) stop 2
if (findloc(a,2,dim=1) /= 2) stop 3
if (findloc(a,2,dim=1,back=.true.) /= 5) stop 4
if (findloc(a,2,dim=1,back=true) /= 5) stop 5
! Test with array mask
if (findloc(a,2,dim=1,mask=mask) /= 5) stop 6
if (findloc(a,2,dim=1,mask=mask,back=.true.) /= 5) stop 7
if (findloc(a,2,dim=1,mask=mask,back=.false.) /= 5) stop 8
if (findloc(a,2,dim=1,mask=mask2) /= 2) stop 9
if (findloc(a,2,dim=1,mask=mask2,back=.true.) /= 2) stop 10
if (findloc(a,2,dim=1,mask=mask2,back=true) /= 2) stop 11
! Test with scalar mask
if (findloc(a,2,dim=1,mask=.true.) /= 2) stop 12
if (findloc(a,2,dim=1,mask=.false.) /= 0) stop 13
if (findloc(a,2,dim=1,mask=true) /= 2) stop 14
if (findloc(a,2,dim=1,mask=false) /= 0) stop 15
! Some character tests
if (findloc(ch,"AA",dim=1) /= 1) stop 16
if (findloc(ch,"AA",dim=1,mask=mask) /= 4) stop 17
if (findloc(ch,"AA",dim=1,back=.true.) /= 4) stop 18
if (findloc(ch,"AA",dim=1,mask=mask2,back=.true.) /= 1) stop 19
! Nothing to be found here...
if (findloc(ch,"DD",dim=1) /= 0) stop 20
if (findloc(a,4,dim=1) /= 0) stop 21
! Finally, character tests with a scalar mask.
if (findloc(ch,"CC ",dim=1,mask=true) /= 3) stop 22
if (findloc(ch,"CC ",dim=1,mask=false) /= 0) stop 23
end program main
! { dg-do compile }
! This used to ICE with an infinite recursion during development.
! Test case by Dominique d'Humieres.
program logtest3
implicit none
logical :: x = .true.
integer, parameter :: I_FINDLOC_BACK(1) = findloc([1,1],1, back=x) ! { dg-error "does not reduce to a constant expression" }
end program logtest3
p15b.diff.gz
Description: application/gzip
