Subversion Repositories openrisc

! PR 14396

! These we failing on targets which do not provide the c99 complex math

! functions.

! Extracted from intrinsic77.f in the g77 testsuite.

      logical fail

      common /flags/ fail

      fail = .false.

      call square_root

      if (fail) call abort

      end

      subroutine square_root

      intrinsic sqrt, dsqrt, csqrt

      real x, a

      x = 4.0

      a = 2.0

      call c_r(SQRT(x),a,'SQRT(real)')

      call c_d(SQRT(1.d0*x),1.d0*a,'SQRT(double)')

      call c_c(SQRT((1.,0.)*x),(1.,0.)*a,'SQRT(complex)')

      call c_d(DSQRT(1.d0*x),1.d0*a,'DSQRT(double)')

      call c_c(CSQRT((1.,0.)*x),(1.,0.)*a,'CSQRT(complex)')

      call p_r_r(SQRT,x,a,'SQRT')

      call p_d_d(DSQRT,1.d0*x,1.d0*a,'DSQRT')

      call p_c_c(CSQRT,(1.,0.)*x,(1.,0.)*a ,'CSQRT')

      end

      subroutine failure(label)

!     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)

!     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)

!     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 c_c(a,b,label)

!     Check if COMPLEX a equals b, and fail otherwise

      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 p_r_r(f,x,a,label)

!     Check if REAL f(x) equals a for REAL x

      real f,x,a

      character*(*) label

      call c_r(f(x),a,label)

      end

      subroutine p_d_d(f,x,a,label)

!     Check if DOUBLE PRECISION f(x) equals a for DOUBLE PRECISION x

      double precision f,x,a

      character*(*) label

      call c_d(f(x),a,label)

      end

      subroutine p_c_c(f,x,a,label)

!     Check if COMPLEX f(x) equals a for COMPLEX x

      complex f,x,a

      character*(*) label

      call c_c(f(x),a,label)

      end