gcc/testsuite/g77.f-torture/execute/intrinsic-vax-cd.f

   1 c  intrinsic-vax-cd.f
   2 c
   3 c Test double complex intrinsics CD*.
   4 c These functions are VAX extensions
   5 c
   6 c     David Billinghurst <David.Billinghurst@riotinto.com>
   7 c
   8       double complex z, a
   9       double precision x
  10       logical fail
  11       intrinsic cdabs, cdcos, cdexp, cdlog, cdsin, cdsqrt
  12       common /flags/ fail
  13       fail = .false.
  14
  15 c     CDABS - Absolute value
  16       z = (3.0d0,-4.0d0)
  17       x = 5.0d0
  18       call c_d(CDABS(z),x,'CDABS(double complex)')
  19       call p_d_z(CDABS,z,x,'CDABS')
  20
  21 c     CDCOS - Cosine
  22       z = (3.0d0,1.0d0)
  23       a = (-1.52763825012d0,-0.165844401919)
  24       call c_z(CDCOS(z),a,'CDCOS(double complex)')
  25       call p_z_z(CDCOS,z,a,'CDCOS')
  26
  27 c     CDEXP - Exponential
  28       z = (3.0d0,1.0d0)
  29       a = (10.8522619142d0,16.9013965352)
  30       call c_z(CDEXP(z),a,'CDEXP(double complex)')
  31       call p_z_z(CDEXP,z,a,'CDEXP')
  32
  33 c     CDLOG - Natural logarithm
  34       call c_z(CDLOG(a),z,'CDLOG(double complex)')
  35       call p_z_z(CDLOG,a,z,'CDLOG')
  36
  37 c     CDSIN - Sine
  38       z = (3.0d0,1.0d0)
  39       a = (0.217759551622d0,-1.1634403637d0)
  40       call c_z(CDSIN(z),a,'CDSIN(double complex)')
  41       call p_z_z(CDSIN,z,a,'CDSIN')
  42
  43 c     CDSQRT - Square root
  44       z = (0.0d0,-4.0d0)
  45       a = sqrt(2.0d0)*(1.0d0,-1.0d0)
  46       call c_z(CDSQRT(z),a,'CDSQRT(double complex)')
  47       call p_z_z(CDSQRT,z,a,'CDSQRT')
  48
  49       if ( fail ) call abort()
  50       end
  51
  52       subroutine failure(label)
  53 c     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)
  62 c     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)
  72 c     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)
  82 c     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)
  89 c     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