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

Subversion Repositories openrisc

[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc2/] [gcc/] [testsuite/] [gfortran.dg/] [default_format_1.inc] - Blame information for rev 384

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 302 jeremybenn 
module test_default_format
2 
  interface test
3 
    module procedure test_r4
4 
    module procedure test_r8
5 
  end interface test
6 
 
7 
  integer, parameter :: count = 200
8 
 
9 
contains
10 
  function test_r4 (start, towards) result (res)
11 
    integer, parameter :: k = 4
12 
    integer, intent(in) :: towards
13 
    real(k), intent(in) :: start
14 
 
15 
    integer :: res, i
16 
    real(k) :: x, y
17 
    character(len=100) :: s
18 
 
19 
    res = 0
20 
 
21 
    if (towards >= 0) then
22 
      x = start
23 
      do i = 0, count
24 
        write (s,*) x
25 
        read (s,*) y
26 
        if (y /= x) res = res + 1
27 
        x = nearest(x,huge(x))
28 
      end do
29 
    end if
30 
 
31 
    if (towards <= 0) then
32 
      x = start
33 
      do i = 0, count
34 
        write (s,*) x
35 
        read (s,*) y
36 
        if (y /= x) res = res + 1
37 
        x = nearest(x,-huge(x))
38 
      end do
39 
    end if
40 
  end function test_r4
41 
 
42 
  function test_r8 (start, towards) result (res)
43 
    integer, parameter :: k = 8
44 
    integer, intent(in) :: towards
45 
    real(k), intent(in) :: start
46 
 
47 
    integer :: res, i
48 
    real(k) :: x, y
49 
    character(len=100) :: s
50 
 
51 
    res = 0
52 
 
53 
    if (towards >= 0) then
54 
      x = start
55 
      do i = 0, count
56 
        write (s,*) x
57 
        read (s,*) y
58 
        if (y /= x) res = res + 1
59 
        x = nearest(x,huge(x))
60 
      end do
61 
    end if
62 
 
63 
    if (towards <= 0) then
64 
      x = start
65 
      do i = 0, count
66 
        write (s,*) x
67 
        read (s,*) y
68 
        if (y /= x) res = res + 1
69 
        x = nearest(x,-huge(x))
70 
      end do
71 
    end if
72 
  end function test_r8
73 
 
74 
end module test_default_format

powered by: WebSVN 2.1.0

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