1! { dg-do run } 2! { dg-options "-std=gnu" } 3! PR47567 Wrong output for small absolute values with F editing 4! Test case provided by Thomas Henlich 5call verify_fmt(1.2) 6call verify_fmt(-0.1) 7call verify_fmt(1e-7) 8call verify_fmt(1e-6) 9call verify_fmt(1e-5) 10call verify_fmt(1e-4) 11call verify_fmt(1e-3) 12call verify_fmt(1e-2) 13call verify_fmt(-1e-7) 14call verify_fmt(-1e-6) 15call verify_fmt(-1e-5) 16call verify_fmt(-1e-4) 17call verify_fmt(-1e-3) 18call verify_fmt(-1e-2) 19call verify_fmt(tiny(0.0)) 20call verify_fmt(-tiny(0.0)) 21call verify_fmt(0.0) 22call verify_fmt(-0.0) 23call verify_fmt(100.0) 24call verify_fmt(.12345) 25call verify_fmt(1.2345) 26call verify_fmt(12.345) 27call verify_fmt(123.45) 28call verify_fmt(1234.5) 29call verify_fmt(12345.6) 30call verify_fmt(123456.7) 31call verify_fmt(99.999) 32call verify_fmt(-100.0) 33call verify_fmt(-99.999) 34end 35 36! loop through values for w, d 37subroutine verify_fmt(x) 38 real, intent(in) :: x 39 integer :: w, d 40 character(len=80) :: str, str0 41 integer :: len, len0 42 character(len=80) :: fmt_w_d 43 logical :: result, have_num, verify_fmt_w_d 44 45 do d = 0, 10 46 have_num = .false. 47 do w = 1, 20 48 str = fmt_w_d(x, w, d) 49 len = len_trim(str) 50 51 result = verify_fmt_w_d(x, str, len, w, d) 52 if (.not. have_num .and. result) then 53 have_num = .true. 54 str0 = fmt_w_d(x, 0, d) 55 len0 = len_trim(str0) 56 if (len /= len0) then 57 call errormsg(x, str0, len0, 0, d, "selected width is wrong") 58 else 59 if (str(:len) /= str0(:len0)) call errormsg(x, str0, len0, 0, d, "output is wrong") 60 end if 61 end if 62 end do 63 end do 64 65end subroutine 66 67! checks for standard-compliance, returns .true. if field contains number, .false. on overflow 68function verify_fmt_w_d(x, str, len, w, d) 69 real, intent(in) :: x 70 character(len=80), intent(in) :: str 71 integer, intent(in) :: len 72 integer, intent(in) :: w, d 73 logical :: verify_fmt_w_d 74 integer :: pos 75 character :: decimal_sep = "." 76 77 verify_fmt_w_d = .false. 78 79 ! check if string is all asterisks 80 pos = verify(str(:len), "*") 81 if (pos == 0) return 82 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") 86 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") 90 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") 96 end if 97 98 verify_fmt_w_d = .true. 99end function 100 101function 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 106 107 fmt = make_fmt(w, d) 108 write (fmt_w_d, fmt) x 109end function 110 111function make_fmt(w, d) 112 integer, intent(in) :: w, d 113 character(len=10) :: make_fmt 114 115 write (make_fmt,'("(f",i0,".",i0,")")') w, d 116end function 117 118subroutine 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 123 integer :: fmt_len 124 character(len=10) :: fmt, make_fmt 125 126 fmt = make_fmt(w, d) 127 fmt_len = len_trim(fmt) 128 129 !print *, "print '", fmt(:fmt_len), "', ", x, " ! => ", str(:len), ": ", reason 130 STOP 1 131end subroutine 132