Skip to content

R
riscv-gcc-1
Commit 897c6ab7 by David Billinghurst Committed by Toon Moene
Options

intrinsic-unix-bessel.f: New test 

2001-07-24  David Billinghurst <David.Billinghurst@riotinto.com>

	* g77.f-torture/execute/intrinsic-unix-bessel.f: New test
	* g77.f-torture/execute/intrinsic-unix-erf.f: New test
	* g77.f-torture/execute/intrinsic-vax-cd.f: New test
	* g77.f-torture/execute/intrinsic-f2c-z.f: New test

From-SVN: r44295
parent 46d2e8d7
Showing with 369 additions and 0 deletions
gcc/testsuite/ChangeLog
2001-07-24 David Billinghurst <David.Billinghurst@riotinto.com>
* g77.f-torture/execute/intrinsic-unix-bessel.f: New test
* g77.f-torture/execute/intrinsic-unix-erf.f: New test
* g77.f-torture/execute/intrinsic-vax-cd.f: New test
* g77.f-torture/execute/intrinsic-f2c-z.f: New test
Mon Jul 23 10:14:17 2001 Jeffrey A Law (law@cygnus.com)
* gcc.c-torture/execute/20010723-1.c: New test.
......
gcc/testsuite/g77.f-torture/execute/intrinsic-f2c-z.f 0 → 100644
c intrinsic-f2c-z.f
c
c Test double complex intrinsics Z*.
c These functions are f2c extensions
c
c David Billinghurst <David.Billinghurst@riotinto.com>
c
double complex z, a
double precision x
logical fail
intrinsic zabs, zcos, zexp, zlog, zsin, zsqrt
common /flags/ fail
fail = .false.
c ZABS - Absolute value
z = (3.0d0,-4.0d0)
x = 5.0d0
call c_d(ZABS(z),x,'ZABS(double complex)')
call p_d_z(ZABS,z,x,'ZABS')
c ZCOS - Cosine
z = (3.0d0,1.0d0)
a = (-1.52763825012d0,-0.165844401919)
call c_z(ZCOS(z),a,'ZCOS(double complex)')
call p_z_z(ZCOS,z,a,'ZCOS')
c ZEXP - Exponential
z = (3.0d0,1.0d0)
a = (10.8522619142d0,16.9013965352)
call c_z(ZEXP(z),a,'ZEXP(double complex)')
call p_z_z(ZEXP,z,a,'ZEXP')
c ZLOG - Natural logarithm
call c_z(ZLOG(a),z,'ZLOG(double complex)')
call p_z_z(ZLOG,a,z,'ZLOG')
c ZSIN - Sine
z = (3.0d0,1.0d0)
a = (0.217759551622d0,-1.1634403637d0)
call c_z(ZSIN(z),a,'ZSIN(double complex)')
call p_z_z(ZSIN,z,a,'ZSIN')
c ZSQRT - Square root
z = (0.0d0,-4.0d0)
a = sqrt(2.0d0)*(1.0d0,-1.0d0)
call c_z(ZSQRT(z),a,'ZSQRT(double complex)')
call p_z_z(ZSQRT,z,a,'ZSQRT')
if ( fail ) call abort()
end
subroutine failure(label)
c Report failure and set flag
character*(*) label
logical fail
common /flags/ fail
write(6,'(a,a,a)') 'Test ',label,' FAILED'
fail = .true.
end
subroutine c_z(a,b,label)
c Check if DOUBLE COMPLEX a equals b, and fail otherwise
double complex a, b
character*(*) label
if ( abs(a-b) .gt. 1.0e-5 ) then
call failure(label)
write(6,*) 'Got ',a,' expected ', b
end if
end
subroutine c_d(a,b,label)
c Check if DOUBLE PRECISION a equals b, and fail otherwise
double precision a, b
character*(*) label
if ( abs(a-b) .gt. 1.0d-5 ) then
call failure(label)
write(6,*) 'Got ',a,' expected ', b
end if
end
subroutine p_z_z(f,x,a,label)
c Check if DOUBLE COMPLEX f(x) equals a for DOUBLE COMPLEX x
double complex f,x,a
character*(*) label
call c_z(f(x),a,label)
end
subroutine p_d_z(f,x,a,label)
c Check if DOUBLE PRECISION f(x) equals a for DOUBLE COMPLEX x
double precision f,x
double complex a
character*(*) label
call c_d(f(x),a,label)
end
gcc/testsuite/g77.f-torture/execute/intrinsic-unix-bessel.f 0 → 100644
c intrinsic-unix-bessel.f
c
c Test Bessel function intrinsics.
c These functions are only available if provided by system
c
c David Billinghurst <David.Billinghurst@riotinto.com>
c
real x, a
double precision dx, da
integer i
integer*2 j
integer*1 k
integer*8 m
logical fail
common /flags/ fail
fail = .false.
x = 2.0
dx = x
i = 2
j = i
k = i
m = i
c BESJ0 - Bessel function of first kind of order zero
a = 0.22389077
da = a
call c_r(BESJ0(x),a,'BESJ0(real)')
call c_d(BESJ0(dx),da,'BESJ0(double)')
call c_d(DBESJ0(dx),da,'DBESJ0(double)')
c BESJ1 - Bessel function of first kind of order one
a = 0.57672480
da = a
call c_r(BESJ1(x),a,'BESJ1(real)')
call c_d(BESJ1(dx),da,'BESJ1(double)')
call c_d(DBESJ1(dx),da,'DBESJ1(double)')
c BESJN - Bessel function of first kind of order N
a = 0.3528340
da = a
call c_r(BESJN(i,x),a,'BESJN(integer,real)')
c call c_r(BESJN(j,x),a,'BESJN(integer*2,real)')
c call c_r(BESJN(k,x),a,'BESJN(integer*1,real)')
c call c_r(BESJN(m,x),a,'BESJN(integer*8,real)')
c call c_d(BESJN(i,dx),da,'BESJN(integer,double)')
c call c_d(BESJN(j,dx),da,'BESJN(integer*2,double)')
call c_d(BESJN(k,dx),da,'BESJN(integer*1,double)')
c call c_d(BESJN(m,dx),da,'BESJN(integer*8,double)')
call c_d(DBESJN(i,dx),da,'DBESJN(integer,double)')
call c_d(DBESJN(j,dx),da,'DBESJN(integer*2,double)')
call c_d(DBESJN(k,dx),da,'DBESJN(integer*1,double)')
c call c_d(DBESJN(m,dx),da,'DBESJN(integer*8,double)')
c BESY0 - Bessel function of second kind of order zero
a = 0.51037567
da = a
call c_r(BESY0(x),a,'BESY0(real)')
call c_d(BESY0(dx),da,'BESY0(double)')
call c_d(DBESY0(dx),da,'DBESY0(double)')
c BESY1 - Bessel function of second kind of order one
a = 0.-0.1070324
da = a
call c_r(BESY1(x),a,'BESY1(real)')
call c_d(BESY1(dx),da,'BESY1(double)')
call c_d(DBESY1(dx),da,'DBESY1(double)')
c BESYN - Bessel function of second kind of order N
a = -0.6174081
da = a
call c_r(BESYN(i,x),a,'BESYN(integer,real)')
c call c_r(BESYN(j,x),a,'BESYN(integer*2,real)')
c call c_r(BESYN(k,x),a,'BESYN(integer*1,real)')
c call c_r(BESYN(m,x),a,'BESYN(integer*8,real)')
c call c_d(BESYN(i,dx),da,'BESYN(integer,double)')
c call c_d(BESYN(j,dx),da,'BESYN(integer*2,double)')
call c_d(BESYN(k,dx),da,'BESYN(integer*1,double)')
c call c_d(BESYN(m,dx),da,'BESYN(integer*8,double)')
call c_d(DBESYN(i,dx),da,'DBESYN(integer,double)')
call c_d(DBESYN(j,dx),da,'DBESYN(integer*2,double)')
call c_d(DBESYN(k,dx),da,'DBESYN(integer*1,double)')
c call c_d(DBESYN(m,dx),da,'DBESYN(integer*8,double)')
if ( fail ) call abort()
end
subroutine failure(label)
c Report failure and set flag
character*(*) label
logical fail
common /flags/ fail
write(6,'(a,a,a)') 'Test ',label,' FAILED'
fail = .true.
end
subroutine c_r(a,b,label)
c Check if REAL a equals b, and fail otherwise
real a, b
character*(*) label
if ( abs(a-b) .gt. 1.0e-5 ) then
call failure(label)
write(6,*) 'Got ',a,' expected ', b
end if
end
subroutine c_d(a,b,label)
c Check if DOUBLE PRECISION a equals b, and fail otherwise
double precision a, b
character*(*) label
if ( abs(a-b) .gt. 1.0d-5 ) then
call failure(label)
write(6,*) 'Got ',a,' expected ', b
end if
end
gcc/testsuite/g77.f-torture/execute/intrinsic-unix-erf.f 0 → 100644
c intrinsic-unix-erf.f
c
c Test Bessel function intrinsics.
c These functions are only available if provided by system
c
c David Billinghurst <David.Billinghurst@riotinto.com>
c
real x, a
double precision dx, da
logical fail
common /flags/ fail
fail = .false.
x = 0.6
dx = x
c ERF - error function
a = 0.6038561
da = a
call c_r(ERF(x),a,'ERF(real)')
call c_d(ERF(dx),da,'ERF(double)')
call c_d(DERF(dx),da,'DERF(double)')
c ERFC - complementary error function
a = 1.0 - a
da = a
call c_r(ERFC(x),a,'ERFC(real)')
call c_d(ERFC(dx),da,'ERFC(double)')
call c_d(DERFC(dx),da,'DERFC(double)')
if ( fail ) call abort()
end
subroutine failure(label)
c Report failure and set flag
character*(*) label
logical fail
common /flags/ fail
write(6,'(a,a,a)') 'Test ',label,' FAILED'
fail = .true.
end
subroutine c_r(a,b,label)
c Check if REAL a equals b, and fail otherwise
real a, b
character*(*) label
if ( abs(a-b) .gt. 1.0e-5 ) then
call failure(label)
write(6,*) 'Got ',a,' expected ', b
end if
end
subroutine c_d(a,b,label)
c Check if DOUBLE PRECISION a equals b, and fail otherwise
double precision a, b
character*(*) label
if ( abs(a-b) .gt. 1.0d-5 ) then
call failure(label)
write(6,*) 'Got ',a,' expected ', b
end if
end
gcc/testsuite/g77.f-torture/execute/intrinsic-vax-cd.f 0 → 100644
c intrinsic-vax-cd.f
c
c Test double complex intrinsics CD*.
c These functions are VAX extensions
c
c David Billinghurst <David.Billinghurst@riotinto.com>
c
double complex z, a
double precision x
logical fail
intrinsic cdabs, cdcos, cdexp, cdlog, cdsin, cdsqrt
common /flags/ fail
fail = .false.
c CDABS - Absolute value
z = (3.0d0,-4.0d0)
x = 5.0d0
call c_d(CDABS(z),x,'CDABS(double complex)')
call p_d_z(CDABS,z,x,'CDABS')
c CDCOS - Cosine
z = (3.0d0,1.0d0)
a = (-1.52763825012d0,-0.165844401919)
call c_z(CDCOS(z),a,'CDCOS(double complex)')
call p_z_z(CDCOS,z,a,'CDCOS')
c CDEXP - Exponential
z = (3.0d0,1.0d0)
a = (10.8522619142d0,16.9013965352)
call c_z(CDEXP(z),a,'CDEXP(double complex)')
call p_z_z(CDEXP,z,a,'CDEXP')
c CDLOG - Natural logarithm
call c_z(CDLOG(a),z,'CDLOG(double complex)')
call p_z_z(CDLOG,a,z,'CDLOG')
c CDSIN - Sine
z = (3.0d0,1.0d0)
a = (0.217759551622d0,-1.1634403637d0)
call c_z(CDSIN(z),a,'CDSIN(double complex)')
call p_z_z(CDSIN,z,a,'CDSIN')
c CDSQRT - Square root
z = (0.0d0,-4.0d0)
a = sqrt(2.0d0)*(1.0d0,-1.0d0)
call c_z(CDSQRT(z),a,'CDSQRT(double complex)')
call p_z_z(CDSQRT,z,a,'CDSQRT')
if ( fail ) call abort()
end
subroutine failure(label)
c Report failure and set flag
character*(*) label
logical fail
common /flags/ fail
write(6,'(a,a,a)') 'Test ',label,' FAILED'
fail = .true.
end
subroutine c_z(a,b,label)
c Check if DOUBLE COMPLEX a equals b, and fail otherwise
double complex a, b
character*(*) label
if ( abs(a-b) .gt. 1.0e-5 ) then
call failure(label)
write(6,*) 'Got ',a,' expected ', b
end if
end
subroutine c_d(a,b,label)
c Check if DOUBLE PRECISION a equals b, and fail otherwise
double precision a, b
character*(*) label
if ( abs(a-b) .gt. 1.0d-5 ) then
call failure(label)
write(6,*) 'Got ',a,' expected ', b
end if
end
subroutine p_z_z(f,x,a,label)
c Check if DOUBLE COMPLEX f(x) equals a for DOUBLE COMPLEX x
double complex f,x,a
character*(*) label
call c_z(f(x),a,label)
end
subroutine p_d_z(f,x,a,label)
c Check if DOUBLE PRECISION f(x) equals a for DOUBLE COMPLEX x
double precision f,x
double complex a
character*(*) label
call c_d(f(x),a,label)
end
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment