1! { dg-do run }
2! { dg-options "-ffloat-store" }
3! PR48602 Invalid F conversion of G descriptor for values close to powers of 10
4! Test case provided by Thomas Henlich
5program test_g0fr
6    use iso_fortran_env
7    implicit none
8    integer, parameter :: RT = REAL64
9    
10    call check_all(0.0_RT, 15, 2, 0)
11    call check_all(0.991_RT, 15, 2, 0)
12    call check_all(0.995_RT, 15, 2, 0)
13    call check_all(0.996_RT, 15, 2, 0)
14    call check_all(0.999_RT, 15, 2, 0)
15contains
16    subroutine check_all(val, w, d, e)
17        real(kind=RT), intent(in) :: val
18        integer, intent(in) :: w
19        integer, intent(in) :: d
20        integer, intent(in) :: e
21
22        call check_f_fmt(val, 'C', w, d, e)
23        call check_f_fmt(val, 'U', w, d, e)
24        call check_f_fmt(val, 'D', w, d, e)
25    end subroutine check_all
26    
27    subroutine check_f_fmt(val, roundmode, w, d, e)
28        real(kind=RT), intent(in) :: val
29        character, intent(in) :: roundmode
30        integer, intent(in) :: w
31        integer, intent(in) :: d
32        integer, intent(in) :: e
33        character(len=80) :: fmt_f, fmt_g
34        character(len=80) :: s_f, s_g
35        real(kind=RT) :: mag, lower, upper
36        real(kind=RT) :: r
37        integer :: n, dec
38
39        mag = abs(val)
40        if (e == 0) then
41            n = 4
42        else
43            n = e + 2
44        end if
45        select case (roundmode)
46            case('U')
47                r = 1.0_RT
48            case('D')
49                r = 0.0_RT
50            case('C')
51                r = 0.5_RT
52        end select
53
54        if (mag == 0) then
55            write(fmt_f, "('R', a, ',F', i0, '.', i0, ',', i0, 'X')") roundmode, w - n, d - 1, n
56        else
57            do dec = d, 0, -1
58                lower = 10.0_RT ** (d - 1 - dec) - r * 10.0_RT ** (- dec - 1)
59                upper = 10.0_RT ** (d - dec) - r * 10.0_RT ** (- dec)
60                if (lower <= mag .and. mag < upper) then
61                    write(fmt_f, "('R', a, ',F', i0, '.', i0, ',', i0, 'X')") roundmode, w - n, dec, n
62                    exit
63                end if
64            end do
65        end if
66        if (len_trim(fmt_f) == 0) then
67            ! e editing
68            return
69        end if
70        if (e == 0) then
71            write(fmt_g, "('R', a, ',G', i0, '.', i0)") roundmode, w, d
72        else
73            write(fmt_g, "('R', a, ',G', i0, '.', i0, 'e', i0)") roundmode, w, d, e
74        end if
75        write(s_g, "('''', " // trim(fmt_g) // ",'''')") val
76        write(s_f, "('''', " // trim(fmt_f) // ",'''')") val
77        if (s_g /= s_f) call abort
78        !if (s_g /= s_f) then
79            !print "(a,g0,a,g0)", "lower=", lower, " upper=", upper
80           ! print "(a, ' /= ', a, ' ', a, '/', a, ':', g0)", trim(s_g), trim(s_f), trim(fmt_g), trim(fmt_f), val
81        !end if
82    end subroutine check_f_fmt
83end program test_g0fr
84