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