gcc/testsuite/gfortran.dg/default_format_1.inc

   1 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