gcc/testsuite/gfortran.fortran-torture/execute/csqrt_1.f90

   1 ! PR 14396
   2 ! These we failing on targets which do not provide the c99 complex math
   3 ! functions.
   4 ! Extracted from intrinsic77.f in the g77 testsuite.
   5       logical fail
   6       common /flags/ fail
   7       fail = .false.
   8       call square_root
   9       if (fail) call abort
  10       end
  11       subroutine square_root
  12       intrinsic sqrt, dsqrt, csqrt
  13       real x, a
  14       x = 4.0
  15       a = 2.0
  16       call c_r(SQRT(x),a,'SQRT(real)')
  17       call c_d(SQRT(1.d0*x),1.d0*a,'SQRT(double)')
  18       call c_c(SQRT((1.,0.)*x),(1.,0.)*a,'SQRT(complex)')
  19       call c_d(DSQRT(1.d0*x),1.d0*a,'DSQRT(double)')
  20       call c_c(CSQRT((1.,0.)*x),(1.,0.)*a,'CSQRT(complex)')
  21       call p_r_r(SQRT,x,a,'SQRT')
  22       call p_d_d(DSQRT,1.d0*x,1.d0*a,'DSQRT')
  23       call p_c_c(CSQRT,(1.,0.)*x,(1.,0.)*a ,'CSQRT')
  24       end
  25       subroutine failure(label)
  26 !     Report failure and set flag
  27       character*(*) label
  28       logical fail
  29       common /flags/ fail
  30       write(6,'(a,a,a)') 'Test ',label,' FAILED'
  31       fail = .true.
  32       end
  33       subroutine c_r(a,b,label)
  34 !     Check if REAL a equals b, and fail otherwise
  35       real a, b
  36       character*(*) label
  37       if ( abs(a-b) .gt. 1.0e-5 ) then
  38          call failure(label)
  39          write(6,*) 'Got ',a,' expected ', b
  40       end if
  41       end
  42       subroutine c_d(a,b,label)
  43 !     Check if DOUBLE PRECISION a equals b, and fail otherwise
  44       double precision a, b
  45       character*(*) label
  46       if ( abs(a-b) .gt. 1.0d-5 ) then
  47          call failure(label)
  48          write(6,*) 'Got ',a,' expected ', b
  49       end if
  50       end
  51
  52       subroutine c_c(a,b,label)
  53 !     Check if COMPLEX a equals b, and fail otherwise
  54       complex a, b
  55       character*(*) label
  56       if ( abs(a-b) .gt. 1.0e-5 ) then
  57          call failure(label)
  58          write(6,*) 'Got ',a,' expected ', b
  59       end if
  60       end
  61       subroutine p_r_r(f,x,a,label)
  62 !     Check if REAL f(x) equals a for REAL x
  63       real f,x,a
  64       character*(*) label
  65       call c_r(f(x),a,label)
  66       end
  67       subroutine p_d_d(f,x,a,label)
  68 !     Check if DOUBLE PRECISION f(x) equals a for DOUBLE PRECISION x
  69       double precision f,x,a
  70       character*(*) label
  71       call c_d(f(x),a,label)
  72       end
  73       subroutine p_c_c(f,x,a,label)
  74 !     Check if COMPLEX f(x) equals a for COMPLEX x
  75       complex f,x,a
  76       character*(*) label
  77       call c_c(f(x),a,label)
  78       end