From: David Billinghurst Date: Tue, 24 Jul 2001 13:32:53 +0000 (+0000) Subject: intrinsic-unix-bessel.f: New test X-Git-Tag: prereleases/libstdc++-3.0.95~3092 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=897c6ab759209a6d67178b76d4ed6d43ed36269e;p=thirdparty%2Fgcc.git intrinsic-unix-bessel.f: New test 2001-07-24 David Billinghurst * 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 --- diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index cbf9241c2f89..995daaef8325 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2001-07-24 David Billinghurst + + * 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. diff --git a/gcc/testsuite/g77.f-torture/execute/intrinsic-f2c-z.f b/gcc/testsuite/g77.f-torture/execute/intrinsic-f2c-z.f new file mode 100644 index 000000000000..ec7b33243790 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/intrinsic-f2c-z.f @@ -0,0 +1,94 @@ +c intrinsic-f2c-z.f +c +c Test double complex intrinsics Z*. +c These functions are f2c extensions +c +c David Billinghurst +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 diff --git a/gcc/testsuite/g77.f-torture/execute/intrinsic-unix-bessel.f b/gcc/testsuite/g77.f-torture/execute/intrinsic-unix-bessel.f new file mode 100644 index 000000000000..8ff841866b83 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/intrinsic-unix-bessel.f @@ -0,0 +1,114 @@ +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 +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 diff --git a/gcc/testsuite/g77.f-torture/execute/intrinsic-unix-erf.f b/gcc/testsuite/g77.f-torture/execute/intrinsic-unix-erf.f new file mode 100644 index 000000000000..5ab48d650367 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/intrinsic-unix-erf.f @@ -0,0 +1,60 @@ +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 +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 diff --git a/gcc/testsuite/g77.f-torture/execute/intrinsic-vax-cd.f b/gcc/testsuite/g77.f-torture/execute/intrinsic-vax-cd.f new file mode 100644 index 000000000000..93f1c43b0f5d --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/intrinsic-vax-cd.f @@ -0,0 +1,94 @@ +c intrinsic-vax-cd.f +c +c Test double complex intrinsics CD*. +c These functions are VAX extensions +c +c David Billinghurst +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