1c  intrinsic-f2c-z.f
2c
3c Test double complex intrinsics Z*.
4c These functions are f2c extensions
5c
6c     David Billinghurst <David.Billinghurst@riotinto.com>
7c
8      double complex z, a
9      double precision x
10      logical fail
11      intrinsic zabs, zcos, zexp, zlog, zsin, zsqrt
12      common /flags/ fail
13      fail = .false.
14
15c     ZABS - Absolute value
16      z = (3.0d0,-4.0d0)
17      x = 5.0d0
18      call c_d(ZABS(z),x,'ZABS(double complex)')
19      call p_d_z(ZABS,z,x,'ZABS')
20
21c     ZCOS - Cosine
22      z = (3.0d0,1.0d0)
23      a = (-1.52763825012d0,-0.165844401919)
24      call c_z(ZCOS(z),a,'ZCOS(double complex)')
25      call p_z_z(ZCOS,z,a,'ZCOS')
26
27c     ZEXP - Exponential
28      z = (3.0d0,1.0d0)
29      a = (10.8522619142d0,16.9013965352)
30      call c_z(ZEXP(z),a,'ZEXP(double complex)')
31      call p_z_z(ZEXP,z,a,'ZEXP')
32
33c     ZLOG - Natural logarithm
34      call c_z(ZLOG(a),z,'ZLOG(double complex)')
35      call p_z_z(ZLOG,a,z,'ZLOG')
36
37c     ZSIN - Sine
38      z = (3.0d0,1.0d0)
39      a = (0.217759551622d0,-1.1634403637d0)
40      call c_z(ZSIN(z),a,'ZSIN(double complex)')
41      call p_z_z(ZSIN,z,a,'ZSIN')
42
43c     ZSQRT - Square root
44      z = (0.0d0,-4.0d0)
45      a = sqrt(2.0d0)*(1.0d0,-1.0d0)
46      call c_z(ZSQRT(z),a,'ZSQRT(double complex)')
47      call p_z_z(ZSQRT,z,a,'ZSQRT')
48
49      if ( fail ) call abort()
50      end
51
52      subroutine failure(label)
53c     Report failure and set flag
54      character*(*) label
55      logical fail
56      common /flags/ fail
57      write(6,'(a,a,a)') 'Test ',label,' FAILED'
58      fail = .true.
59      end
60
61      subroutine c_z(a,b,label)
62c     Check if DOUBLE COMPLEX a equals b, and fail otherwise
63      double complex a, b
64      character*(*) label
65      if ( abs(a-b) .gt. 1.0e-5 ) then
66         call failure(label)
67         write(6,*) 'Got ',a,' expected ', b
68      end if
69      end
70
71      subroutine c_d(a,b,label)
72c     Check if DOUBLE PRECISION a equals b, and fail otherwise
73      double precision a, b
74      character*(*) label
75      if ( abs(a-b) .gt. 1.0d-5 ) then
76         call failure(label)
77         write(6,*) 'Got ',a,' expected ', b
78      end if
79      end
80
81      subroutine p_z_z(f,x,a,label)
82c     Check if DOUBLE COMPLEX f(x) equals a for DOUBLE COMPLEX x
83      double complex f,x,a
84      character*(*) label
85      call c_z(f(x),a,label)
86      end
87
88      subroutine p_d_z(f,x,a,label)
89c     Check if DOUBLE PRECISION f(x) equals a for DOUBLE COMPLEX x
90      double precision f,x
91      double complex a
92      character*(*) label
93      call c_d(f(x),a,label)
94      end
95