2 ! { dg-options "-std=gnu" }
3 ! PR47567 Wrong output for small absolute values with F editing
4 ! Test case provided by Thomas Henlich
13 call verify_fmt(-1e-7)
14 call verify_fmt(-1e-6)
15 call verify_fmt(-1e-5)
16 call verify_fmt(-1e-4)
17 call verify_fmt(-1e-3)
18 call verify_fmt(-1e-2)
19 call verify_fmt(tiny(0.0))
20 call verify_fmt(-tiny(0.0))
23 call verify_fmt(100.0)
24 call verify_fmt(.12345)
25 call verify_fmt(1.2345)
26 call verify_fmt(12.345)
27 call verify_fmt(123.45)
28 call verify_fmt(1234.5)
29 call verify_fmt(12345.6)
30 call verify_fmt(123456.7)
31 call verify_fmt(99.999)
32 call verify_fmt(-100.0)
33 call verify_fmt(-99.999)
36 ! loop through values for w, d
37 subroutine verify_fmt(x
)
40 character(len
=80) :: str
, str0
42 character(len
=80) :: fmt_w_d
43 logical :: result
, have_num
, verify_fmt_w_d
48 str
= fmt_w_d(x
, w
, d
)
51 result
= verify_fmt_w_d(x
, str
, len
, w
, d
)
52 if (.not
. have_num
.and
. result
) then
54 str0
= fmt_w_d(x
, 0, d
)
57 call errormsg(x
, str0
, len0
, 0, d
, "selected width is wrong")
59 if (str(:len
) /= str0(:len0
)) call errormsg(x
, str0
, len0
, 0, d
, "output is wrong")
67 ! checks for standard-compliance, returns .true. if field contains number, .false. on overflow
68 function verify_fmt_w_d(x
, str
, len
, w
, d
)
70 character(len
=80), intent(in
) :: str
71 integer, intent(in
) :: len
72 integer, intent(in
) :: w
, d
73 logical :: verify_fmt_w_d
75 character :: decimal_sep
= "."
77 verify_fmt_w_d
= .false
.
79 ! check if string is all asterisks
80 pos
= verify(str(:len
), "*")
83 ! check if string contains a digit
84 pos
= scan(str(:len
), "0123456789")
85 if (pos
== 0) call errormsg(x
, str
, len
, w
, d
, "no digits")
87 ! contains decimal separator?
88 pos
= index(str(:len
), decimal_sep
)
89 if (pos
== 0) call errormsg(x
, str
, len
, w
, d
, "no decimal separator")
91 ! negative and starts with minus?
92 if (sign(1., x
) < 0.) then
93 pos
= verify(str
, " ")
94 if (pos
== 0) call errormsg(x
, str
, len
, w
, d
, "only spaces")
95 if (str(pos
:pos
) /= "-") call errormsg(x
, str
, len
, w
, d
, "no minus sign")
98 verify_fmt_w_d
= .true
.
101 function fmt_w_d(x
, w
, d
)
102 real, intent(in
) :: x
103 integer, intent(in
) :: w
, d
104 character(len
=*) :: fmt_w_d
105 character(len
=10) :: fmt
, make_fmt
108 write (fmt_w_d
, fmt
) x
111 function make_fmt(w
, d
)
112 integer, intent(in
) :: w
, d
113 character(len
=10) :: make_fmt
115 write (make_fmt
,'("(f",i0,".",i0,")")') w
, d
118 subroutine errormsg(x
, str
, len
, w
, d
, reason
)
119 real, intent(in
) :: x
120 character(len
=80), intent(in
) :: str
121 integer, intent(in
) :: len
, w
, d
122 character(len
=*), intent(in
) :: reason
124 character(len
=10) :: fmt
, make_fmt
127 fmt_len
= len_trim(fmt
)
129 !print *, "print '", fmt(:fmt_len), "', ", x, " ! => ", str(:len), ": ", reason