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