! PR 14396
|
! PR 14396
|
! These we failing on targets which do not provide the c99 complex math
|
! These we failing on targets which do not provide the c99 complex math
|
! functions.
|
! functions.
|
! Extracted from intrinsic77.f in the g77 testsuite.
|
! Extracted from intrinsic77.f in the g77 testsuite.
|
logical fail
|
logical fail
|
common /flags/ fail
|
common /flags/ fail
|
fail = .false.
|
fail = .false.
|
call square_root
|
call square_root
|
if (fail) call abort
|
if (fail) call abort
|
end
|
end
|
subroutine square_root
|
subroutine square_root
|
intrinsic sqrt, dsqrt, csqrt
|
intrinsic sqrt, dsqrt, csqrt
|
real x, a
|
real x, a
|
x = 4.0
|
x = 4.0
|
a = 2.0
|
a = 2.0
|
call c_r(SQRT(x),a,'SQRT(real)')
|
call c_r(SQRT(x),a,'SQRT(real)')
|
call c_d(SQRT(1.d0*x),1.d0*a,'SQRT(double)')
|
call c_d(SQRT(1.d0*x),1.d0*a,'SQRT(double)')
|
call c_c(SQRT((1.,0.)*x),(1.,0.)*a,'SQRT(complex)')
|
call c_c(SQRT((1.,0.)*x),(1.,0.)*a,'SQRT(complex)')
|
call c_d(DSQRT(1.d0*x),1.d0*a,'DSQRT(double)')
|
call c_d(DSQRT(1.d0*x),1.d0*a,'DSQRT(double)')
|
call c_c(CSQRT((1.,0.)*x),(1.,0.)*a,'CSQRT(complex)')
|
call c_c(CSQRT((1.,0.)*x),(1.,0.)*a,'CSQRT(complex)')
|
call p_r_r(SQRT,x,a,'SQRT')
|
call p_r_r(SQRT,x,a,'SQRT')
|
call p_d_d(DSQRT,1.d0*x,1.d0*a,'DSQRT')
|
call p_d_d(DSQRT,1.d0*x,1.d0*a,'DSQRT')
|
call p_c_c(CSQRT,(1.,0.)*x,(1.,0.)*a ,'CSQRT')
|
call p_c_c(CSQRT,(1.,0.)*x,(1.,0.)*a ,'CSQRT')
|
end
|
end
|
subroutine failure(label)
|
subroutine failure(label)
|
! Report failure and set flag
|
! Report failure and set flag
|
character*(*) label
|
character*(*) label
|
logical fail
|
logical fail
|
common /flags/ fail
|
common /flags/ fail
|
write(6,'(a,a,a)') 'Test ',label,' FAILED'
|
write(6,'(a,a,a)') 'Test ',label,' FAILED'
|
fail = .true.
|
fail = .true.
|
end
|
end
|
subroutine c_r(a,b,label)
|
subroutine c_r(a,b,label)
|
! Check if REAL a equals b, and fail otherwise
|
! Check if REAL a equals b, and fail otherwise
|
real a, b
|
real a, b
|
character*(*) label
|
character*(*) label
|
if ( abs(a-b) .gt. 1.0e-5 ) then
|
if ( abs(a-b) .gt. 1.0e-5 ) then
|
call failure(label)
|
call failure(label)
|
write(6,*) 'Got ',a,' expected ', b
|
write(6,*) 'Got ',a,' expected ', b
|
end if
|
end if
|
end
|
end
|
subroutine c_d(a,b,label)
|
subroutine c_d(a,b,label)
|
! Check if DOUBLE PRECISION a equals b, and fail otherwise
|
! Check if DOUBLE PRECISION a equals b, and fail otherwise
|
double precision a, b
|
double precision a, b
|
character*(*) label
|
character*(*) label
|
if ( abs(a-b) .gt. 1.0d-5 ) then
|
if ( abs(a-b) .gt. 1.0d-5 ) then
|
call failure(label)
|
call failure(label)
|
write(6,*) 'Got ',a,' expected ', b
|
write(6,*) 'Got ',a,' expected ', b
|
end if
|
end if
|
end
|
end
|
|
|
subroutine c_c(a,b,label)
|
subroutine c_c(a,b,label)
|
! Check if COMPLEX a equals b, and fail otherwise
|
! Check if COMPLEX a equals b, and fail otherwise
|
complex a, b
|
complex a, b
|
character*(*) label
|
character*(*) label
|
if ( abs(a-b) .gt. 1.0e-5 ) then
|
if ( abs(a-b) .gt. 1.0e-5 ) then
|
call failure(label)
|
call failure(label)
|
write(6,*) 'Got ',a,' expected ', b
|
write(6,*) 'Got ',a,' expected ', b
|
end if
|
end if
|
end
|
end
|
subroutine p_r_r(f,x,a,label)
|
subroutine p_r_r(f,x,a,label)
|
! Check if REAL f(x) equals a for REAL x
|
! Check if REAL f(x) equals a for REAL x
|
real f,x,a
|
real f,x,a
|
character*(*) label
|
character*(*) label
|
call c_r(f(x),a,label)
|
call c_r(f(x),a,label)
|
end
|
end
|
subroutine p_d_d(f,x,a,label)
|
subroutine p_d_d(f,x,a,label)
|
! Check if DOUBLE PRECISION f(x) equals a for DOUBLE PRECISION x
|
! Check if DOUBLE PRECISION f(x) equals a for DOUBLE PRECISION x
|
double precision f,x,a
|
double precision f,x,a
|
character*(*) label
|
character*(*) label
|
call c_d(f(x),a,label)
|
call c_d(f(x),a,label)
|
end
|
end
|
subroutine p_c_c(f,x,a,label)
|
subroutine p_c_c(f,x,a,label)
|
! Check if COMPLEX f(x) equals a for COMPLEX x
|
! Check if COMPLEX f(x) equals a for COMPLEX x
|
complex f,x,a
|
complex f,x,a
|
character*(*) label
|
character*(*) label
|
call c_c(f(x),a,label)
|
call c_c(f(x),a,label)
|
end
|
end
|
|
|