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


git-svn-id: https://gcc.gnu.org/svn/gcc/trunk@44295 138bc75d-0d04-0410-961f-82ee72b054a4

4 files changed, 362 insertions, 0 deletions

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 00000000000..ec7b3324379
--- /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 <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
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 00000000000..8ff841866b8
--- /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 <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
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 00000000000..5ab48d65036
--- /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 <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
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 00000000000..93f1c43b0f5
--- /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 <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