| 1 |
694 |
jeremybenn |
! { 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 (fp2 /= fp4) call abort()
|
| 35 |
|
|
read (str4, *) fp4
|
| 36 |
|
|
if (fp2 /= fp4) 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
|
