OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [gfortran.fortran-torture/] [execute/] [csqrt_1.f90] - Blame information for rev 303

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 303 jeremybenn
! 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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.