| ! { dg-do run }
|
| ! { dg-options "-std=gnu" }
|
| ! PR47567 Wrong output for small absolute values with F editing
|
| ! Test case provided by Thomas Henlich
|
| call verify_fmt(1.2)
|
| call verify_fmt(-0.1)
|
| call verify_fmt(1e-7)
|
| call verify_fmt(1e-6)
|
| call verify_fmt(1e-5)
|
| call verify_fmt(1e-4)
|
| call verify_fmt(1e-3)
|
| call verify_fmt(1e-2)
|
| call verify_fmt(-1e-7)
|
| call verify_fmt(-1e-6)
|
| call verify_fmt(-1e-5)
|
| call verify_fmt(-1e-4)
|
| call verify_fmt(-1e-3)
|
| call verify_fmt(-1e-2)
|
| call verify_fmt(tiny(0.0))
|
| call verify_fmt(-tiny(0.0))
|
| call verify_fmt(0.0)
|
| call verify_fmt(-0.0)
|
| call verify_fmt(100.0)
|
| call verify_fmt(.12345)
|
| call verify_fmt(1.2345)
|
| call verify_fmt(12.345)
|
| call verify_fmt(123.45)
|
| call verify_fmt(1234.5)
|
| call verify_fmt(12345.6)
|
| call verify_fmt(123456.7)
|
| call verify_fmt(99.999)
|
| call verify_fmt(-100.0)
|
| call verify_fmt(-99.999)
|
| end
|
|
|
| ! loop through values for w, d
|
| subroutine verify_fmt(x)
|
| real, intent(in) :: x
|
| integer :: w, d
|
| character(len=80) :: str, str0
|
| integer :: len, len0
|
| character(len=80) :: fmt_w_d
|
| logical :: result, have_num, verify_fmt_w_d
|
|
|
| do d = 0, 10
|
| have_num = .false.
|
| do w = 1, 20
|
| str = fmt_w_d(x, w, d)
|
| len = len_trim(str)
|
|
|
| result = verify_fmt_w_d(x, str, len, w, d)
|
| if (.not. have_num .and. result) then
|
| have_num = .true.
|
| str0 = fmt_w_d(x, 0, d)
|
| len0 = len_trim(str0)
|
| if (len /= len0) then
|
| call errormsg(x, str0, len0, 0, d, "selected width is wrong")
|
| else
|
| if (str(:len) /= str0(:len0)) call errormsg(x, str0, len0, 0, d, "output is wrong")
|
| end if
|
| end if
|
| end do
|
| end do
|
|
|
| end subroutine
|
|
|
| ! checks for standard-compliance, returns .true. if field contains number, .false. on overflow
|
| function verify_fmt_w_d(x, str, len, w, d)
|
| real, intent(in) :: x
|
| character(len=80), intent(in) :: str
|
| integer, intent(in) :: len
|
| integer, intent(in) :: w, d
|
| logical :: verify_fmt_w_d
|
| integer :: pos
|
| character :: decimal_sep = "."
|
|
|
| verify_fmt_w_d = .false.
|
|
|
| ! check if string is all asterisks
|
| pos = verify(str(:len), "*")
|
| if (pos == 0) return
|
|
|
| ! check if string contains a digit
|
| pos = scan(str(:len), "0123456789")
|
| if (pos == 0) call errormsg(x, str, len, w, d, "no digits")
|
|
|
| ! contains decimal separator?
|
| pos = index(str(:len), decimal_sep)
|
| if (pos == 0) call errormsg(x, str, len, w, d, "no decimal separator")
|
|
|
| ! negative and starts with minus?
|
| if (sign(1., x) < 0.) then
|
| pos = verify(str, " ")
|
| if (pos == 0) call errormsg(x, str, len, w, d, "only spaces")
|
| if (str(pos:pos) /= "-") call errormsg(x, str, len, w, d, "no minus sign")
|
| end if
|
|
|
| verify_fmt_w_d = .true.
|
| end function
|
|
|
| function fmt_w_d(x, w, d)
|
| real, intent(in) :: x
|
| integer, intent(in) :: w, d
|
| character(len=*) :: fmt_w_d
|
| character(len=10) :: fmt, make_fmt
|
|
|
| fmt = make_fmt(w, d)
|
| write (fmt_w_d, fmt) x
|
| end function
|
|
|
| function make_fmt(w, d)
|
| integer, intent(in) :: w, d
|
| character(len=10) :: make_fmt
|
|
|
| write (make_fmt,'("(f",i0,".",i0,")")') w, d
|
| end function
|
|
|
| subroutine errormsg(x, str, len, w, d, reason)
|
| real, intent(in) :: x
|
| character(len=80), intent(in) :: str
|
| integer, intent(in) :: len, w, d
|
| character(len=*), intent(in) :: reason
|
| integer :: fmt_len
|
| character(len=10) :: fmt, make_fmt
|
|
|
| fmt = make_fmt(w, d)
|
| fmt_len = len_trim(fmt)
|
|
|
| !print *, "print '", fmt(:fmt_len), "', ", x, " ! => ", str(:len), ": ", reason
|
| STOP 1 |
| end subroutine
|