Patchwork [libgfortran] Fix numerous formatting bugs

login
register
mail settings
Submitter Jerry DeLisle
Date April 29, 2011, 6:22 a.m.
Message ID <4DBA5936.7050407@frontier.com>
Download mbox | patch
Permalink /patch/93390/
State New
Headers show

Comments

Jerry DeLisle - April 29, 2011, 6:22 a.m.
On 04/27/2011 12:57 PM, Janne Blomqvist wrote:
> On Wed, Apr 27, 2011 at 08:53, Janne Blomqvist
> <blomqvist.janne@gmail.com>  wrote:
>> On Wed, Apr 27, 2011 at 07:09, Jerry DeLisle<jvdelisle@frontier.com>  wrote:
>>> On 04/25/2011 07:36 AM, Janne Blomqvist wrote:
>>>>
>>>> On Mon, Apr 25, 2011 at 14:44, Jerry DeLisle<jvdelisle@frontier.com>
>>>>   wrote:
>>>>>
>>>>> On 04/25/2011 03:48 AM, Janne Blomqvist wrote:
>>>>>>
>>>>>> Now, for one of the testcase changes:
>>>>>>
>>>>>> --- gcc/testsuite/gfortran.dg/char4_iunit_1.f03 (revision 172909)
>>>>>> +++ gcc/testsuite/gfortran.dg/char4_iunit_1.f03 (working copy)
>>>>>> @@ -24,11 +24,11 @@ program char4_iunit_1
>>>>>>     write(string, *) .true., .false. , .true.
>>>>>>     if (string .ne. 4_" T F T                                    ") call
>>>>>> abort
>>>>>>     write(string, *) 1.2345e-06, 4.2846e+10_8
>>>>>> -  if (string .ne. 4_"  1.23450002E-06   42846000000.000000     ") call
>>>>>> abort
>>>>>> +  if (string .ne. 4_"  1.234500019E-06   42846000000.000000    ") call
>>>>>> abort
>>>>>>
>>>>>> This looks wrong. For correctly rounded REAL(4) output, we need 9
>>>>>> significant digits, but here we print 10.
>>>>>>
>>>>>
>>>>> Well, I bumped it up for defaults based on pr48488 comment #2 shown
>>>>> below.
>>>>
>>>> Yes, that comment in the PR is correct; to guarantee that a
>>>> binary->ascii->binary roundtrip preserves the original binary value
>>>> (with the default "round to nearest, break on even" rounding mode),
>>>> one must output at least {9, 17, 21, 36} significant digits for real
>>>> kinds 4, 8, 10, and 16, respectively (yes, I double-checked IEEE
>>>> 754-2008 that this is indeed correct).
>>>>
>>>> Since for the G edit descriptor d is equivalent to the number of
>>>> significant digits, AFAICS the write.c patch below is correct and the
>>>> bug must be elsewhere, no?
>>>>
>>>
>>> No.
>>>
>>> Look at this example:
>>>
>>> program t4
>>>   implicit none
>>>   character(len=44) :: string
>>>   write(*,*) 1.2345e-06, 4.2846e+10_8
>>>   write(*,'(1x,1pG16.9e2,1x,1pG25.17e3)') 1.2345e-06, 4.2846e+10_8
>>>   write(*,'(1x,1pG15.8e2,1x,1pG25.17e3)') 1.2345e-06, 4.2846e+10_8
>>> end program t4
>>>
>>> This gives with the patch:
>>>
>>>   1.234500019E-06   42846000000.000000
>>>   1.234500019E-06   42846000000.000000
>>>   1.23450002E-06   42846000000.000000
>>>
>>> And without the patch:
>>>
>>>   1.23450002E-06   42846000000.000000
>>>   1.234500019E-06   42846000000.000000
>>>   1.23450002E-06   42846000000.000000
>>>
>>> d is the number of digits after the decimal point, not the number of
>>> significant digits.
>>
>> I stand corrected. Or well, I still stand by my previous statement
>> that with the G edit descriptor d corresponds to the number of
>> significant digits. However, only when not using the scale factor.
>>
>> Since we use a scale factor of 1, when the magnitude of the number is
>> such that the E edit descriptor is used, according to F2008 10.7.2.3.3
>> paragraph 6 for 0<  k<  d+2 we must print k significant digits to the
>> left of the decimal point and d-k+1 to the right. That is, with k=1 we
>> print one digit to the left of the decimal point and d-1+1=d to the
>> right which has the effect of increasing the number of significant
>> digits by one!
>>
>> However, when the magnitude of the value is such that F editing is
>> used, the scale factor has no effect and we thus print d significant
>> digits.
>>
>> So in order to guarantee an exact binary<->ascii roundtrip we must
>> accept an extra digit in some cases. Or then do something which would
>> make list formatted (and perhaps G0 as well?) write differ from 1PGw.d
>> (effectively, reduce d by one when the magnitude is such that E
>> editing is used)?
>
> That is, what about something like the attached patch on top of your
> patch. With the patch, the test program
>
> program t4
>   implicit none
>   character(len=44) :: string
>   write(*,*) 1.2345e-06, 4.2846e+10_8, 1.1
>   write(*,'(1x,1pG16.9e2,1x,1pG25.17e3)') 1.2345e-06, 4.2846e+10_8
>   write(*,'(1x,1pG15.8e2,1x,1pG25.17e3)') 1.2345e-06, 4.2846e+10_8
>   write(*,'(1x,1pG0,1x,1pG0)') 1.2345e-06, 1.1
>   write(*,'(1x,1pG0.9,1x,1pG0.9)') 1.2345e-06, 1.1
> end program t4
>
> outputs
>
>     1.23450002E-06   42846000000.000000        1.10000002
>    1.234500019E-06   42846000000.000000
>    1.23450002E-06   42846000000.000000
>   1.23450002E-06 1.10000002
>   1.234500019E-06 1.10000002
>
> So the change is that now it prints the same number of significant
> digits in E and F mode, both for list formatted output and kPG0 when
> k>=0. For list formatted we can do pretty much what we want, and for
> G0 the standard only says the processor can choose appropriate values
> for w, d, and e. So far we have chosen d and e only based on the kind,
> but AFAICS nothing prevents taking into account the magnitude as well.
>
> I haven't modified any of the testcases so I expect some number of
> regressions due to that, but I'm asking for opinions on the approach
> itself before doing that.
>

Actually only saw one test case failure which I have adjusted.  The attached 
patch applies Janne's patch to my patch and the fix for pr48787.  Regression 
tested on x86-64.

OK for trunk?  I sure would like to get this in so I can move on to other things.

Jerry
Janne Blomqvist - April 29, 2011, 6:37 a.m.
On Fri, Apr 29, 2011 at 09:22, Jerry DeLisle <jvdelisle@frontier.com> wrote:
> On 04/27/2011 12:57 PM, Janne Blomqvist wrote:
>> So the change is that now it prints the same number of significant
>> digits in E and F mode, both for list formatted output and kPG0 when
>> k>=0. For list formatted we can do pretty much what we want, and for
>> G0 the standard only says the processor can choose appropriate values
>> for w, d, and e. So far we have chosen d and e only based on the kind,
>> but AFAICS nothing prevents taking into account the magnitude as well.
>>
>> I haven't modified any of the testcases so I expect some number of
>> regressions due to that, but I'm asking for opinions on the approach
>> itself before doing that.
>>
>
> Actually only saw one test case failure which I have adjusted.  The attached
> patch applies Janne's patch to my patch and the fix for pr48787.  Regression
> tested on x86-64.
>
> OK for trunk?  I sure would like to get this in so I can move on to other
> things.

Ok.

Patch

Index: gcc/testsuite/gfortran.dg/fmt_g.f
===================================================================
--- gcc/testsuite/gfortran.dg/fmt_g.f	(revision 172909)
+++ gcc/testsuite/gfortran.dg/fmt_g.f	(working copy)
@@ -31,13 +31,13 @@ 
        WRITE(buffer,"(G12.5E5,'<')") -10000.
        if (buffer.ne."************<") call abort
        WRITE(buffer,"(G13.5E5,'<')") -10000.
-       if (buffer.ne."-10000.      <") call abort
+       if (buffer.ne."*************<") call abort
        WRITE(buffer,"(G14.5E5,'<')") -10000.
-       if (buffer.ne." -10000.      <") call abort
+       if (buffer.ne."-10000.       <") call abort
        WRITE(buffer,"(G15.5E5,'<')") -10000.
-       if (buffer.ne."  -10000.      <") call abort
+       if (buffer.ne." -10000.       <") call abort
        WRITE(buffer,"(G16.5E5,'<')") -10000.
-       if (buffer.ne."   -10000.      <") call abort
+       if (buffer.ne."  -10000.       <") call abort
 
        STOP
        END
Index: gcc/testsuite/gfortran.dg/fmt_g0_1.f08
===================================================================
--- gcc/testsuite/gfortran.dg/fmt_g0_1.f08	(revision 172909)
+++ gcc/testsuite/gfortran.dg/fmt_g0_1.f08	(working copy)
@@ -2,19 +2,19 @@ 
 ! PR36420 Fortran 2008: g0 edit descriptor 
 ! Test case provided by Jerry DeLisle <jvdelisle@gcc.gnu.org>
     character(25) :: string = "(g0,g0,g0)" 
-    character(33) :: buffer
+    character(50) :: buffer
     write(buffer, '(g0,g0,g0)') ':',12340,':'
     if (buffer.ne.":12340:") call abort
     write(buffer, string) ':',0,':'
     if (buffer.ne.":0:") call abort
-    write(buffer, string) ':',1.0/3.0,':'
-    if (buffer.ne.":.33333334:") call abort
-    write(buffer, '(1x,a,g0,a)') ':',1.0/3.0,':'
-    if (buffer.ne." :.33333334:") call abort
+    write(buffer, string) ':',1.0_8/3.0_8,':'
+    if (buffer.ne.":.33333333333333331:") call abort
+    write(buffer, '(1x,a,g0,a)') ':',1.0_8/3.0_8,':'
+    if (buffer.ne." :.33333333333333331:") call abort
     write(buffer, string) ':',"hello",':'
-    if (buffer.ne.":hello:") call abort
+    if (buffer.ne.":hello:") call abort 
     write(buffer, "(g0,g0,g0,g0)") ':',.true.,.false.,':'
     if (buffer.ne.":TF:") call abort
-    write(buffer, "(g0,g0,',',g0,g0)") '(',( 1.2345, 2.4567 ),')'
-    if (buffer.ne."(1.2345001,2.4567001)") call abort
+    write(buffer, "(g0,g0,',',g0,g0)") '(',( 1.2345_8, 2.4567_8 ),')'
+    if (buffer.ne."(1.2344999999999999,2.4567000000000001)") call abort
 end
Index: gcc/testsuite/gfortran.dg/round_3.f08
===================================================================
--- gcc/testsuite/gfortran.dg/round_3.f08	(revision 0)
+++ gcc/testsuite/gfortran.dg/round_3.f08	(revision 0)
@@ -0,0 +1,75 @@ 
+! { dg-do run }
+! PR48615 Invalid UP/DOWN rounding with E and ES descriptors
+! Test case provided by Thomas Henlich.
+program pr48615
+    call checkfmt("(RU,F17.0)", 2.5,     "               3.")
+    call checkfmt("(RU,-1P,F17.1)", 2.5, "              0.3")
+    call checkfmt("(RU,E17.1)", 2.5,     "          0.3E+01") ! 0.2E+01
+    call checkfmt("(RU,1P,E17.0)", 2.5,  "           3.E+00")
+    call checkfmt("(RU,ES17.0)", 2.5,    "           3.E+00") ! 2.E+00
+    call checkfmt("(RU,EN17.0)", 2.5,    "           3.E+00")
+
+    call checkfmt("(RD,F17.0)", 2.5,     "               2.")
+    call checkfmt("(RD,-1P,F17.1)", 2.5, "              0.2")
+    call checkfmt("(RD,E17.1)", 2.5,     "          0.2E+01")
+    call checkfmt("(RD,1P,E17.0)", 2.5,  "           2.E+00")
+    call checkfmt("(RD,ES17.0)", 2.5,    "           2.E+00")
+    call checkfmt("(RD,EN17.0)", 2.5,    "           2.E+00")
+
+    call checkfmt("(RC,F17.0)", 2.5,     "               3.")
+    call checkfmt("(RC,-1P,F17.1)", 2.5, "              0.3")
+    call checkfmt("(RC,E17.1)", 2.5,     "          0.3E+01") ! 0.2E+01
+    call checkfmt("(RC,1P,E17.0)", 2.5,  "           3.E+00")
+    call checkfmt("(RC,ES17.0)", 2.5,    "           3.E+00") ! 2.E+00
+    call checkfmt("(RC,EN17.0)", 2.5,    "           3.E+00")
+
+    call checkfmt("(RN,F17.0)", 2.5,     "               2.")
+    call checkfmt("(RN,-1P,F17.1)", 2.5, "              0.2")
+    call checkfmt("(RN,E17.1)", 2.5,     "          0.2E+01")
+    call checkfmt("(RN,1P,E17.0)", 2.5,  "           2.E+00")
+    call checkfmt("(RN,ES17.0)", 2.5,    "           2.E+00")
+    call checkfmt("(RN,EN17.0)", 2.5,    "           2.E+00")
+
+    call checkfmt("(RZ,F17.0)", 2.5,     "               2.")
+    call checkfmt("(RZ,-1P,F17.1)", 2.5, "              0.2")
+    call checkfmt("(RZ,E17.1)", 2.5,     "          0.2E+01")
+    call checkfmt("(RZ,1P,E17.0)", 2.5,  "           2.E+00")
+    call checkfmt("(RZ,ES17.0)", 2.5,    "           2.E+00")
+    call checkfmt("(RZ,EN17.0)", 2.5,    "           2.E+00")
+
+    call checkfmt("(RZ,F17.0)", -2.5,     "              -2.")
+    call checkfmt("(RZ,-1P,F17.1)", -2.5, "             -0.2")
+    call checkfmt("(RZ,E17.1)", -2.5,     "         -0.2E+01")
+    call checkfmt("(RZ,1P,E17.0)", -2.5,  "          -2.E+00")
+    call checkfmt("(RZ,ES17.0)", -2.5,    "          -2.E+00")
+    call checkfmt("(RZ,EN17.0)", -2.5,    "          -2.E+00")
+
+    call checkfmt("(RN,F17.0)", -2.5,     "              -2.")
+    call checkfmt("(RN,-1P,F17.1)", -2.5, "             -0.2")
+    call checkfmt("(RN,E17.1)", -2.5,     "         -0.2E+01")
+    call checkfmt("(RN,1P,E17.0)", -2.5,  "          -2.E+00")
+    call checkfmt("(RN,ES17.0)", -2.5,    "          -2.E+00")
+    call checkfmt("(RN,EN17.0)", -2.5,    "          -2.E+00")
+
+    call checkfmt("(RC,F17.0)", -2.5,     "              -3.")
+    call checkfmt("(RC,-1P,F17.1)", -2.5, "             -0.3")
+    call checkfmt("(RC,E17.1)", -2.5,     "         -0.3E+01") ! -0.2E+01
+    call checkfmt("(RC,1P,E17.0)", -2.5,  "          -3.E+00")
+    call checkfmt("(RC,ES17.0)", -2.5,    "          -3.E+00") ! -2.E+00
+    call checkfmt("(RC,EN17.0)", -2.5,    "          -3.E+00")
+
+    call checkfmt("(RU,E17.1)", nearest(2.0, 1.0),     "          0.3E+01") ! 0.2E+01
+    call checkfmt("(RD,E17.1)", nearest(3.0, -1.0),    "          0.2E+01") ! 0.3E+01
+
+contains
+    subroutine checkfmt(fmt, x, cmp)
+        character(len=*), intent(in) :: fmt
+        real, intent(in) :: x
+        character(len=*), intent(in) :: cmp
+        character(len=40) :: s
+        
+        write(s, fmt) x
+        if (s /= cmp) call abort
+        !if (s /= cmp) print "(a,1x,a,' expected: ',1x)", fmt, s, cmp
+    end subroutine
+end program
Index: gcc/testsuite/gfortran.dg/namelist_print_1.f
===================================================================
--- gcc/testsuite/gfortran.dg/namelist_print_1.f	(revision 172909)
+++ gcc/testsuite/gfortran.dg/namelist_print_1.f	(working copy)
@@ -9,5 +9,5 @@ 
       namelist /mynml/ x
       x = 1
 ! ( dg-output "^" }
-      print mynml ! { dg-output "&MYNML(\n|\r\n|\r) X=  1.0000000    ,(\n|\r\n|\r) /(\n|\r\n|\r)" }
+      print mynml ! { dg-output "&MYNML(\n|\r\n|\r) X=  1.00000000    ,(\n|\r\n|\r) /(\n|\r\n|\r)" }
       end
Index: gcc/testsuite/gfortran.dg/char4_iunit_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/char4_iunit_1.f03	(revision 172909)
+++ gcc/testsuite/gfortran.dg/char4_iunit_1.f03	(working copy)
@@ -5,7 +5,7 @@ 
 ! Test case prepared by Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 program char4_iunit_1
   implicit none
-  character(kind=4,len=42) :: string
+  character(kind=4,len=44) :: string
   integer(kind=4) :: i,j
   real(kind=4) :: inf, nan, large
 
@@ -24,11 +24,11 @@  program char4_iunit_1
   write(string, *) .true., .false. , .true.
   if (string .ne. 4_" T F T                                    ") call abort
   write(string, *) 1.2345e-06, 4.2846e+10_8
-  if (string .ne. 4_"  1.23450002E-06   42846000000.000000     ") call abort
+  if (string .ne. 4_"   1.23450002E-06   42846000000.000000      ") call abort
   write(string, *) nan, inf
-  if (string .ne. 4_"             NaN        Infinity          ") call abort
+  if (string .ne. 4_"              NaN         Infinity    ") call abort
   write(string, '(10x,f3.1,3x,f9.1)') nan, inf
-  if (string .ne. 4_"          NaN    Infinity                 ") call abort
+  if (string .ne. 4_"          NaN    Infinity             ") call abort
   write(string, *) (1.2, 3.4 )
-  if (string .ne. 4_" (  1.2000000    ,  3.4000001    )        ") call abort
+  if (string .ne. 4_" (  1.20000005    ,  3.40000010    )  ") call abort
 end program char4_iunit_1
Index: gcc/testsuite/gfortran.dg/f2003_io_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/f2003_io_5.f03	(revision 172909)
+++ gcc/testsuite/gfortran.dg/f2003_io_5.f03	(working copy)
@@ -5,7 +5,7 @@  integer :: i
 real :: a(10) = [ (i*1.3, i=1,10) ]
 real :: b(10)
 complex :: c
-character(34) :: complex
+character(36) :: complex
 namelist /nm/ a
 
 open(99,file="mynml",form="formatted",decimal="point",status="replace")
@@ -18,9 +18,9 @@  close(99, status="delete")
 
 c = (3.123,4.456)
 write(complex,*,decimal="comma") c
-if (complex.ne." (  3,1229999    ;  4,4559999    )") call abort
+if (complex.ne." (  3,12299991    ;  4,45599985    )") call abort
 c = (0.0, 0.0)
 read(complex,*,decimal="comma") c
-if (complex.ne." (  3,1229999    ;  4,4559999    )") call abort
+if (complex.ne." (  3,12299991    ;  4,45599985    )") call abort
 
 end
Index: gcc/testsuite/gfortran.dg/coarray_15.f90
===================================================================
--- gcc/testsuite/gfortran.dg/coarray_15.f90	(revision 172909)
+++ gcc/testsuite/gfortran.dg/coarray_15.f90	(working copy)
@@ -9,7 +9,7 @@  program ex2
       implicit none
       real, allocatable :: z(:)[:]
       integer :: image
-      character(len=80) :: str
+      character(len=128) :: str
 
       allocate(z(3)[*])
       write(*,*) 'z allocated on image',this_image()
@@ -25,18 +25,18 @@  program ex2
 
       str = repeat('X', len(str))
       write(str,*) 'z=',z(:),' on image',this_image()
-      if (str /= " z=   1.2000000       1.2000000       1.2000000      on image           1") &
-        call abort ()
+      if (str /= " z=   1.20000005       1.20000005       1.20000005      on image           1") &
+        call abort
 
       str = repeat('X', len(str))
       write(str,*) 'z=',z,' on image',this_image()
-      if (str /= " z=   1.2000000       1.2000000       1.2000000      on image           1") &
-        call abort ()
+      if (str /= " z=   1.20000005       1.20000005       1.20000005      on image           1") &
+        call abort
 
       str = repeat('X', len(str))
       write(str,*) 'z=',z(1:3)[this_image()],' on image',this_image()
-      if (str /= " z=   1.2000000       1.2000000       1.2000000      on image           1") &
-        call abort ()
+      if (str /= " z=   1.20000005       1.20000005       1.20000005      on image           1") &
+        call abort
 
       call ex2a()
       call ex5()
@@ -46,7 +46,7 @@  subroutine ex2a()
       implicit none
       real, allocatable :: z(:,:)[:,:]
       integer :: image
-      character(len=100) :: str
+      character(len=128) :: str
 
       allocate(z(2,2)[1,*])
       write(*,*) 'z allocated on image',this_image()
@@ -62,38 +62,38 @@  subroutine ex2a()
 
       str = repeat('X', len(str))
       write(str,*) 'z=',z(:,:),' on image',this_image()
-      if (str /= " z=   1.2000000       1.2000000       1.2000000       1.2000000      on image           1") &
-        call abort ()
+      if (str /= " z=   1.20000005       1.20000005       1.20000005       1.20000005      on image           1") &
+        call abort
 
       str = repeat('X', len(str))
       write(str,*) 'z=',z,' on image',this_image()
-      if (str /= " z=   1.2000000       1.2000000       1.2000000       1.2000000      on image           1") &
-        call abort ()
+      if (str /= " z=   1.20000005       1.20000005       1.20000005       1.20000005      on image           1") &
+        call abort
 end subroutine ex2a
 
 subroutine ex5
    implicit none
    integer :: me
    real, save :: w(4)[*]
-   character(len=100) :: str
+   character(len=128) :: str
 
    me = this_image()
    w = me
 
    str = repeat('X', len(str))
    write(str,*) 'In main on image',this_image(), 'w= ',w 
-   if (str /= " In main on image           1 w=    1.0000000       1.0000000       1.0000000       1.0000000") &
-     call abort ()
+   if (str /= " In main on image           1 w=    1.00000000       1.00000000       1.00000000       1.00000000") &
+        call abort
 
    str = repeat('X', len(str))
    write(str,*) 'In main on image',this_image(), 'w= ',w(1:4) 
-   if (str /= " In main on image           1 w=    1.0000000       1.0000000       1.0000000       1.0000000") &
-     call abort ()
+   if (str /= " In main on image           1 w=    1.00000000       1.00000000       1.00000000       1.00000000") &
+        call abort
 
    str = repeat('X', len(str))
    write(str,*) 'In main on image',this_image(), 'w= ',w(:)[1]
-   if (str /= " In main on image           1 w=    1.0000000       1.0000000       1.0000000       1.0000000") &
-     call abort ()
+   if (str /= " In main on image           1 w=    1.00000000       1.00000000       1.00000000       1.00000000") &
+        call abort
 
    sync all
    call ex5_sub(me,w)
@@ -103,10 +103,10 @@  subroutine ex5_sub(n,w)
    implicit none
    integer :: n
    real :: w(n)
-   character(len=50) :: str
+   character(len=75) :: str
 
    str = repeat('X', len(str))
    write(str,*) 'In sub on image',this_image(), 'w= ',w 
-   if (str /= " In sub on image           1 w=    1.0000000") &
-     call abort ()
+   if (str /= " In sub on image           1 w=    1.00000000") &
+        call abort
 end subroutine ex5_sub
Index: gcc/testsuite/gfortran.dg/namelist_65.f90
===================================================================
--- gcc/testsuite/gfortran.dg/namelist_65.f90	(revision 172909)
+++ gcc/testsuite/gfortran.dg/namelist_65.f90	(working copy)
@@ -14,9 +14,9 @@  enddo
 
 write(out,nl1)
 if (out(1).ne."&NL1") call abort
-if (out(2).ne." A=  1.0000000    ,") call abort
-if (out(3).ne." B=  2.0000000    ,") call abort
-if (out(4).ne." C=  3.0000000    ,") call abort
+if (out(2).ne." A=  1.00000000    ,") call abort
+if (out(3).ne." B=  2.00000000    ,") call abort
+if (out(4).ne." C=  3.00000000    ,") call abort
 if (out(5).ne." /") call abort
 
 end program oneline
Index: gcc/testsuite/gfortran.dg/fmt_cache_1.f
===================================================================
--- gcc/testsuite/gfortran.dg/fmt_cache_1.f	(revision 172909)
+++ gcc/testsuite/gfortran.dg/fmt_cache_1.f	(working copy)
@@ -3,9 +3,10 @@ 
 ! pr40330  incorrect io.
 ! test case derived from pr40662, <jvdelisle@gcc.gnu.org>
       program astap
-      character(40) teststring
-      arlxca = 0.0
-      open(10, status="scratch")
+      implicit none
+      character(34) :: teststring
+      real(4) :: arlxca = 0.0
+      open(10)
       write(10,40) arlxca
       write(10,40) arlxca
 40    format(t4,"arlxca = ",1pg13.6,t27,"arlxcc = ",g13.6,t53,
@@ -21,13 +22,12 @@ 
      .            "ebalnc = ",g13.6,t79,"ebalsa = ",g13.6,t105,
      .            "ebalsc = ",g13.6)
       rewind 10
-      rewind 10
       teststring = ""
       read(10,'(a)') teststring
-      if (teststring.ne."   arlxca =   0.00000     arlxcc = ")call abort
+      if (teststring.ne."   arlxca =   0.00000     arlxcc =")call abort
       teststring = ""
       read(10,'(a)') teststring
-      if (teststring.ne."   arlxca =   0.00000     arlxcc = ")call abort
+      if (teststring.ne."   arlxca =   0.00000     arlxcc =")call abort
       end program astap
 
 
Index: gcc/testsuite/gfortran.dg/char4_iunit_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/char4_iunit_2.f03	(revision 172909)
+++ gcc/testsuite/gfortran.dg/char4_iunit_2.f03	(working copy)
@@ -43,5 +43,5 @@  program char4_iunit_2
   write(widestring,*)"test",i, x, str_default,&
    trim(str_char4)
   if (widestring .ne. &
-    k_" test         345   52.542999     0 hijklmnp qwertyuiopasd") call abort
+    k_" test         345   52.5429993     0 hijklmnp qwertyuiopasd") call abort
 end program char4_iunit_2
Index: gcc/testsuite/gfortran.dg/real_const_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/real_const_3.f90	(revision 172909)
+++ gcc/testsuite/gfortran.dg/real_const_3.f90	(working copy)
@@ -42,15 +42,15 @@  program main
   if (trim(adjustl(str)) .ne. 'NaN') call abort
 
   write(str,*) z
-  if (trim(adjustl(str)) .ne. '(            NaN,            NaN)') call abort
+  if (trim(adjustl(str)) .ne. '(             NaN,             NaN)') call abort
 
   write(str,*) z2
-  if (trim(adjustl(str)) .ne. '(            NaN,            NaN)') call abort
+  if (trim(adjustl(str)) .ne. '(             NaN,             NaN)') call abort
 
   write(str,*) z3
-  if (trim(adjustl(str)) .ne. '(       Infinity,      -Infinity)') call abort
+  if (trim(adjustl(str)) .ne. '(        Infinity,       -Infinity)') call abort
 
   write(str,*) z4
-  if (trim(adjustl(str)) .ne. '(  0.0000000    , -0.0000000    )') call abort
+  if (trim(adjustl(str)) .ne. '(  0.00000000    , -0.00000000    )') call abort
 
 end program main
Index: libgfortran/io/write.c
===================================================================
--- libgfortran/io/write.c	(revision 172909)
+++ libgfortran/io/write.c	(working copy)
@@ -1155,35 +1155,35 @@  write_z (st_parameter_dt *dtp, const fnode *f, con
 void
 write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 {
-  write_float (dtp, f, p, len);
+  write_float (dtp, f, p, len, 0);
 }
 
 
 void
 write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 {
-  write_float (dtp, f, p, len);
+  write_float (dtp, f, p, len, 0);
 }
 
 
 void
 write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 {
-  write_float (dtp, f, p, len);
+  write_float (dtp, f, p, len, 0);
 }
 
 
 void
 write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 {
-  write_float (dtp, f, p, len);
+  write_float (dtp, f, p, len, 0);
 }
 
 
 void
 write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 {
-  write_float (dtp, f, p, len);
+  write_float (dtp, f, p, len, 0);
 }
 
 
@@ -1432,8 +1432,8 @@  set_fnode_default (st_parameter_dt *dtp, fnode *f,
   switch (length)
     {
     case 4:
-      f->u.real.w = 15;
-      f->u.real.d = 8;
+      f->u.real.w = 16;
+      f->u.real.d = 9;
       f->u.real.e = 2;
       break;
     case 8:
@@ -1442,13 +1442,13 @@  set_fnode_default (st_parameter_dt *dtp, fnode *f,
       f->u.real.e = 3;
       break;
     case 10:
-      f->u.real.w = 29;
-      f->u.real.d = 20;
+      f->u.real.w = 30;
+      f->u.real.d = 21;
       f->u.real.e = 4;
       break;
     case 16:
-      f->u.real.w = 44;
-      f->u.real.d = 35;
+      f->u.real.w = 45;
+      f->u.real.d = 36;
       f->u.real.e = 4;
       break;
     default:
@@ -1468,7 +1468,7 @@  write_real (st_parameter_dt *dtp, const char *sour
   int org_scale = dtp->u.p.scale_factor;
   dtp->u.p.scale_factor = 1;
   set_fnode_default (dtp, &f, length);
-  write_float (dtp, &f, source , length);
+  write_float (dtp, &f, source , length, 1);
   dtp->u.p.scale_factor = org_scale;
 }
 
@@ -1476,12 +1476,20 @@  write_real (st_parameter_dt *dtp, const char *sour
 void
 write_real_g0 (st_parameter_dt *dtp, const char *source, int length, int d)
 {
-  fnode f ;
+  fnode f;
+  int comp_d; 
   set_fnode_default (dtp, &f, length);
   if (d > 0)
     f.u.real.d = d;
+
+  /* Compensate for extra digits when using scale factor, d is not
+     specified, and the magnitude is such that E editing is used.  */
+  if (dtp->u.p.scale_factor > 0 && d == 0)
+    comp_d = 1;
+  else
+    comp_d = 0;
   dtp->u.p.g0_no_blanks = 1;
-  write_float (dtp, &f, source , length);
+  write_float (dtp, &f, source , length, comp_d);
   dtp->u.p.g0_no_blanks = 0;
 }
 
Index: libgfortran/io/write_float.def
===================================================================
--- libgfortran/io/write_float.def	(revision 172909)
+++ libgfortran/io/write_float.def	(working copy)
@@ -289,8 +289,9 @@  output_float (st_parameter_dt *dtp, const fnode *f
     }
   else if (nbefore + nafter < ndigits)
     {
-      ndigits = nbefore + nafter;
-      i = ndigits;
+      i = ndigits = nbefore + nafter;
+      if (d == 0 && digits[1] == '0')
+	goto skip;
       if (digits[i] >= rchar)
 	{
 	  /* Propagate the carry.  */
@@ -812,7 +813,8 @@  CALCULATE_EXP(16)
 static void \
 output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \
 		      GFC_REAL_ ## x m, char *buffer, size_t size, \
-		      int sign_bit, bool zero_flag, int ndigits, int edigits) \
+		      int sign_bit, bool zero_flag, int ndigits, \
+                      int edigits, int comp_d) \
 { \
   int e = f->u.real.e;\
   int d = f->u.real.d;\
@@ -850,7 +852,7 @@  output_float_FMT_G_ ## x (st_parameter_dt *dtp, co
     { \
       newf->format = FMT_E;\
       newf->u.real.w = w;\
-      newf->u.real.d = d;\
+      newf->u.real.d = d - comp_d;\
       newf->u.real.e = e;\
       nb = 0;\
       goto finish;\
@@ -864,11 +866,10 @@  output_float_FMT_G_ ## x (st_parameter_dt *dtp, co
 \
   while (low <= high)\
     { \
-      GFC_REAL_ ## x temp;\
+      volatile GFC_REAL_ ## x temp;\
       mid = (low + high) / 2;\
 \
       temp = (calculate_exp_ ## x (mid - 1) * (1 - r * rexp_d));\
-      asm volatile ("" : "+m" (temp));\
 \
       if (m < temp)\
         { \
@@ -894,22 +895,11 @@  output_float_FMT_G_ ## x (st_parameter_dt *dtp, co
 	}\
     }\
 \
-  if (e > 4)\
-    e = 4;\
-  if (e < 0)\
-    nb = 4;\
-  else\
-    nb = e + 2;\
-\
-  nb = nb >= w ? 0 : nb;\
+  nb = e <= 0 ? 4 : e + 2;\
+  nb = nb >= w ? w - 1 : nb;\
   newf->format = FMT_F;\
-  newf->u.real.w = f->u.real.w - nb;\
-\
-  if (m == 0.0)\
-    newf->u.real.d = d - 1;\
-  else\
-    newf->u.real.d = - (mid - d - 1);\
-\
+  newf->u.real.w = w - nb;\
+  newf->u.real.d = m == 0.0 ? d - 1 : -(mid - d - 1) ;\
   dtp->u.p.scale_factor = 0;\
 \
  finish:\
@@ -931,7 +921,7 @@  output_float_FMT_G_ ## x (st_parameter_dt *dtp, co
 	  gfc_char4_t *p4 = (gfc_char4_t *) p;\
 	  memset4 (p4, pad, nb);\
 	}\
-      else\
+      else \
 	memset (p, pad, nb);\
     }\
 }\
@@ -1010,19 +1000,20 @@  __qmath_(quadmath_snprintf) (buffer, sizeof buffer
 			edigits);\
 	else \
 	  output_float_FMT_G_ ## x (dtp, f, tmp, buffer, size, sign_bit, \
-				    zero_flag, ndigits, edigits);\
+				    zero_flag, ndigits, edigits, comp_d);\
 }\
 
 /* Output a real number according to its format.  */
 
 static void
-write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
+write_float (st_parameter_dt *dtp, const fnode *f, const char *source, \
+            int len, int comp_d)
 {
 
 #if defined(HAVE_GFC_REAL_16) || __LDBL_DIG__ > 18
-# define MIN_FIELD_WIDTH 48
+# define MIN_FIELD_WIDTH 49
 #else
-# define MIN_FIELD_WIDTH 31
+# define MIN_FIELD_WIDTH 32
 #endif
 #define STR(x) STR1(x)
 #define STR1(x) #x
@@ -1039,23 +1030,8 @@  static void
      to handle the largest number of exponent digits expected.  */
   edigits=4;
 
-  if (f->format == FMT_F || f->format == FMT_EN || f->format == FMT_G 
-      || ((f->format == FMT_D || f->format == FMT_E)
-      && dtp->u.p.scale_factor != 0))
-    {
-      /* Always convert at full precision to avoid double rounding.  */
-      ndigits = MIN_FIELD_WIDTH - 4 - edigits;
-    }
-  else
-    {
-      /* The number of digits is known, so let printf do the rounding.  */
-      if (f->format == FMT_ES)
-	ndigits = f->u.real.d + 1;
-      else
-	ndigits = f->u.real.d;
-      if (ndigits > MIN_FIELD_WIDTH - 4 - edigits)
-	ndigits = MIN_FIELD_WIDTH - 4 - edigits;
-    }
+  /* Always convert at full precision to avoid double rounding.  */
+    ndigits = MIN_FIELD_WIDTH - 4 - edigits;
 
   switch (len)
     {