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