1! { dg-do run { xfail hppa*-*-hpux* } }
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!
11program 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
78end program test_qp
79