large_real_kind_1.f90

来自「用于进行gcc测试」· F90 代码 · 共 80 行

! { dg-do run }
! { dg-require-effective-target fortran_large_real }

module testmod
  integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1)
contains
  subroutine testoutput (a,b,length,f)
    real(kind=k),intent(in) :: a
    real(kind=8),intent(in) ::  b
    integer,intent(in) :: length
    character(len=*),intent(in) :: f

    character(len=length) :: ca
    character(len=length) :: cb

    write (ca,f) a
    write (cb,f) b
    if (ca /= cb) call abort
  end subroutine testoutput

  subroutine outputstring (a,f,s)
    real(kind=k),intent(in) :: a
    character(len=*),intent(in) :: f
    character(len=*),intent(in) :: s

    character(len=len(s)) :: c
    
    write (c,f) a
    if (c /= s) call abort
  end subroutine outputstring
end module testmod


! Testing I/O of large real kinds (larger than kind=8)
program test
  use testmod
  implicit none

  real(kind=k) :: x
  character(len=20) :: c1, c2

  call testoutput (0.0_k,0.0_8,40,'(F40.35)')

  call testoutput (1.0_k,1.0_8,40,'(F40.35)')
  call testoutput (0.1_k,0.1_8,15,'(F15.10)')
  call testoutput (1e10_k,1e10_8,15,'(F15.10)')
  call testoutput (7.51e100_k,7.51e100_8,15,'(F15.10)')
  call testoutput (1e-10_k,1e-10_8,15,'(F15.10)')
  call testoutput (7.51e-100_k,7.51e-100_8,15,'(F15.10)')

  call testoutput (-1.0_k,-1.0_8,40,'(F40.35)')
  call testoutput (-0.1_k,-0.1_8,15,'(F15.10)')
  call testoutput (-1e10_k,-1e10_8,15,'(F15.10)')
  call testoutput (-7.51e100_k,-7.51e100_8,15,'(F15.10)')
  call testoutput (-1e-10_k,-1e-10_8,15,'(F15.10)')
  call testoutput (-7.51e-100_k,-7.51e-100_8,15,'(F15.10)')

  x = huge(x)
  call outputstring (2*x,'(F20.15)','           +Infinity')
  call outputstring (-2*x,'(F20.15)','           -Infinity')

  write (c1,'(G20.10E5)') x
  write (c2,'(G20.10E5)') -x
  if (c2(1:1) /= '-') call abort
  c2(1:1) = ' '
  if (c1 /= c2) call abort

  x = tiny(x)
  call outputstring (x,'(F20.15)','   0.000000000000000')
  call outputstring (-x,'(F20.15)','  -0.000000000000000')

  write (c1,'(G20.10E5)') x
  write (c2,'(G20.10E5)') -x
  if (c2(1:1) /= '-') call abort
  c2(1:1) = ' '
  if (c1 /= c2) call abort
end program test

! { dg-final { cleanup-modules "testmod" } }