gcc/testsuite/gfortran.dg/quad_2.f90

   1 ! { dg-do run }
   2 ! { dg-require-effective-target fortran_largest_fp_has_sqrt }
   3 !
   4 ! This test checks whether the largest possible
   5 ! floating-point number works.
   6 !
   7 ! This is a run-time check. Depending on the architecture,
   8 ! this tests REAL(8), REAL(10) or REAL(16) and REAL(16)
   9 ! might be a hardware or libquadmath 128bit number.
  10 !
  11 program test_qp
  12    use iso_fortran_env, only: real_kinds
  13    implicit none
  14    integer, parameter :: QP = real_kinds(ubound(real_kinds,dim=1))
  15    real(qp) :: fp1, fp2, fp3, fp4
  16    character(len=80) :: str1, str2, str3, str4
  17    fp1 = 1
  18    fp2 = sqrt (2.0_qp)
  19    write (str1,*) fp1
  20    write (str2,'(g0)') fp1
  21    write (str3,*) fp2
  22    write (str4,'(g0)') fp2
  23
  24 !   print '(3a)', '>',trim(str1),'<'
  25 !   print '(3a)', '>',trim(str2),'<'
  26 !   print '(3a)', '>',trim(str3),'<'
  27 !   print '(3a)', '>',trim(str4),'<'
  28
  29    read (str1, *) fp3
  30    if (fp1 /= fp3) call abort()
  31    read (str2, *) fp3
  32    if (fp1 /= fp3) call abort()
  33    read (str3, *) fp4
  34    if (abs (fp2 - fp4)/fp2 > epsilon(fp2)) call abort()
  35    read (str4, *) fp4
  36    if (abs (fp2 - fp4)/fp2 > epsilon(fp2)) call abort()
  37
  38    select case (qp)
  39      case (8)
  40        if (str1 /= "   1.0000000000000000") call abort()
  41        if (str2 /= "1.0000000000000000") call abort()
  42        if (str3 /= "   1.4142135623730951") call abort()
  43        if (str4 /= "1.4142135623730951") call abort()
  44
  45      case (10)
  46        if (str1 /= "   1.00000000000000000000") call abort()
  47        if (str2 /= "1.00000000000000000000") call abort()
  48        if (str3 /= "   1.41421356237309504876") call abort()
  49        if (str4 /= "1.41421356237309504876") call abort()
  50
  51      case (16)
  52        if (str1 /= "   1.00000000000000000000000000000000000") call abort()
  53        if (str2 /= "1.00000000000000000000000000000000000") call abort()
  54
  55        if (digits(1.0_qp) == 113) then
  56          ! IEEE 754 binary 128 format
  57          ! e.g. libquadmath/__float128 on i686/x86_64/ia64
  58          if (str3 /= "   1.41421356237309504880168872420969798") call abort()
  59          if (str4 /= "1.41421356237309504880168872420969798") call abort()
  60        else if (digits(1.0_qp) == 106) then
  61          ! IBM binary 128 format
  62          if (str3(1:37) /= "   1.41421356237309504880168872420969") call abort()
  63          if (str4(1:34) /= "1.41421356237309504880168872420969") call abort()
  64        end if
  65
  66        ! Do a libm run-time test
  67        block
  68          real(qp), volatile :: fp2a
  69          fp2a = 2.0_qp
  70          fp2a = sqrt (fp2a)
  71          if (abs (fp2a - fp2) > sqrt(2.0_qp)-nearest(sqrt(2.0_qp),-1.0_qp)) call abort()
  72        end block
  73
  74      case default
  75        call abort()
  76    end select
  77
  78 end program test_qp