1! { dg-do run } 2! PR70235 Incorrect output with PF format. 3! Test case provided by Antoine Gardeux. 4program pr70235 5use ISO_FORTRAN_ENV 6 implicit none 7 integer, parameter :: j(size(real_kinds)+4)=[REAL_KINDS, [4, 4, 4, 4]] 8 logical :: l_skip(4) = .false. 9 integer :: i 10 integer :: n_tst = 0, n_cnt = 0, n_skip = 0 11 character(len=20) :: s, s1 12 13! Check that the default rounding mode is to nearest and to even on tie. 14 do i=1,size(real_kinds) 15 if (i == 1) then 16 write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(1)), & 17 real(9.49999905,kind=j(1)), & 18 real(9.5,kind=j(1)), real(8.5,kind=j(1)) 19 write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(1)), & 20 real(98765.0,kind=j(1)) 21 else if (i == 2) then 22 write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(2)), & 23 real(9.49999905,kind=j(2)), & 24 real(9.5,kind=j(2)), real(8.5,kind=j(2)) 25 write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(2)), & 26 real(98765.0,kind=j(2)) 27 else if (i == 3) then 28 write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(3)), & 29 real(9.49999905,kind=j(3)), & 30 real(9.5,kind=j(3)), real(8.5,kind=j(3)) 31 write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(3)), & 32 real(98765.0,kind=j(3)) 33 else if (i == 4) then 34 write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(4)), & 35 real(9.49999905,kind=j(4)), & 36 real(9.5,kind=j(4)), real(8.5,kind=j(4)) 37 write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(4)), & 38 real(98765.0,kind=j(4)) 39 end if 40 if (s /= '-9.5 9.5 10. 8.' .or. s1 /= ' 987.4E+03 98.76E+03') then 41 l_skip(i) = .true. 42! print "('Unsupported rounding for real(',i0,')')", j(i) 43 end if 44 end do 45 46 47! Original test. 48 call checkfmt("(-6PF8.3)", 1.0e4, " 0.010") 49 call checkfmt("(-6PF8.3)", 0.0, " 0.000") 50 51! Test for the bug in comment 6. 52 call checkfmt("(-8pf18.3)", 643.125, " 0.000") 53 call checkfmt("(-7pf18.3)", 643.125, " 0.000") 54 call checkfmt("(-6pf18.3)", 643.125, " 0.001") 55 call checkfmt("(-5pf18.3)", 643.125, " 0.006") 56 call checkfmt("(-4pf18.3)", 643.125, " 0.064") 57 call checkfmt("(-3pf18.3)", 643.125, " 0.643") 58 call checkfmt("(-2pf18.3)", 643.125, " 6.431") 59 call checkfmt("(-1pf18.3)", 643.125, " 64.312") 60 call checkfmt("( 0pf18.3)", 643.125, " 643.125") 61 62 call checkfmt("(ru,-8pf18.3)", 643.125, " 0.001") 63 call checkfmt("(ru,-7pf18.3)", 643.125, " 0.001") 64 call checkfmt("(ru,-6pf18.3)", 643.125, " 0.001") 65 call checkfmt("(ru,-5pf18.3)", 643.125, " 0.007") 66 call checkfmt("(ru,-4pf18.3)", 643.125, " 0.065") 67 call checkfmt("(ru,-3pf18.3)", 643.125, " 0.644") 68 call checkfmt("(ru,-2pf18.3)", 643.125, " 6.432") 69 call checkfmt("(ru,-1pf18.3)", 643.125, " 64.313") 70 call checkfmt("(ru, 0pf18.3)", 643.125, " 643.125") 71 72 call checkfmt("(rd,-8pf18.3)", 643.125, " 0.000") 73 call checkfmt("(rd,-7pf18.3)", 643.125, " 0.000") 74 call checkfmt("(rd,-6pf18.3)", 643.125, " 0.000") 75 call checkfmt("(rd,-5pf18.3)", 643.125, " 0.006") 76 call checkfmt("(rd,-4pf18.3)", 643.125, " 0.064") 77 call checkfmt("(rd,-3pf18.3)", 643.125, " 0.643") 78 call checkfmt("(rd,-2pf18.3)", 643.125, " 6.431") 79 call checkfmt("(rd,-1pf18.3)", 643.125, " 64.312") 80 call checkfmt("(rd, 0pf18.3)", 643.125, " 643.125") 81 82 call checkfmt("(rz,-8pf18.3)", 643.125, " 0.000") 83 call checkfmt("(rz,-7pf18.3)", 643.125, " 0.000") 84 call checkfmt("(rz,-6pf18.3)", 643.125, " 0.000") 85 call checkfmt("(rz,-5pf18.3)", 643.125, " 0.006") 86 call checkfmt("(rz,-4pf18.3)", 643.125, " 0.064") 87 call checkfmt("(rz,-3pf18.3)", 643.125, " 0.643") 88 call checkfmt("(rz,-2pf18.3)", 643.125, " 6.431") 89 call checkfmt("(rz,-1pf18.3)", 643.125, " 64.312") 90 call checkfmt("(rz, 0pf18.3)", 643.125, " 643.125") 91 92 call checkfmt("(rc,-8pf18.3)", 643.125, " 0.000") 93 call checkfmt("(rc,-7pf18.3)", 643.125, " 0.000") 94 call checkfmt("(rc,-6pf18.3)", 643.125, " 0.001") 95 call checkfmt("(rc,-5pf18.3)", 643.125, " 0.006") 96 call checkfmt("(rc,-4pf18.3)", 643.125, " 0.064") 97 call checkfmt("(rc,-3pf18.3)", 643.125, " 0.643") 98 call checkfmt("(rc,-2pf18.3)", 643.125, " 6.431") 99 call checkfmt("(rc,-1pf18.3)", 643.125, " 64.313") 100 call checkfmt("(rc, 0pf18.3)", 643.125, " 643.125") 101 102 call checkfmt("(rn,-8pf18.3)", 643.125, " 0.000") 103 call checkfmt("(rn,-7pf18.3)", 643.125, " 0.000") 104 call checkfmt("(rn,-6pf18.3)", 643.125, " 0.001") 105 call checkfmt("(rn,-5pf18.3)", 643.125, " 0.006") 106 call checkfmt("(rn,-4pf18.3)", 643.125, " 0.064") 107 call checkfmt("(rn,-3pf18.3)", 643.125, " 0.643") 108 call checkfmt("(rn,-2pf18.3)", 643.125, " 6.431") 109 call checkfmt("(rn,-1pf18.3)", 643.125, " 64.312") 110 call checkfmt("(rn, 0pf18.3)", 643.125, " 643.125") 111 112 call checkfmt("(rp,-8pf18.3)", 643.125, " 0.000") 113 call checkfmt("(rp,-7pf18.3)", 643.125, " 0.000") 114 call checkfmt("(rp,-6pf18.3)", 643.125, " 0.001") 115 call checkfmt("(rp,-5pf18.3)", 643.125, " 0.006") 116 call checkfmt("(rp,-4pf18.3)", 643.125, " 0.064") 117 call checkfmt("(rp,-3pf18.3)", 643.125, " 0.643") 118 call checkfmt("(rp,-2pf18.3)", 643.125, " 6.431") 119 call checkfmt("(rp,-1pf18.3)", 643.125, " 64.312") 120 call checkfmt("(rp, 0pf18.3)", 643.125, " 643.125") 121 122 call checkfmt("(-8pf18.3)", -643.125, " -0.000") 123 call checkfmt("(-7pf18.3)", -643.125, " -0.000") 124 call checkfmt("(-6pf18.3)", -643.125, " -0.001") 125 call checkfmt("(-5pf18.3)", -643.125, " -0.006") 126 call checkfmt("(-4pf18.3)", -643.125, " -0.064") 127 call checkfmt("(-3pf18.3)", -643.125, " -0.643") 128 call checkfmt("(-2pf18.3)", -643.125, " -6.431") 129 call checkfmt("(-1pf18.3)", -643.125, " -64.312") 130 call checkfmt("( 0pf18.3)", -643.125, " -643.125") 131 132 call checkfmt("(ru,-8pf18.3)", -643.125, " -0.000") 133 call checkfmt("(ru,-7pf18.3)", -643.125, " -0.000") 134 call checkfmt("(ru,-6pf18.3)", -643.125, " -0.000") 135 call checkfmt("(ru,-5pf18.3)", -643.125, " -0.006") 136 call checkfmt("(ru,-4pf18.3)", -643.125, " -0.064") 137 call checkfmt("(ru,-3pf18.3)", -643.125, " -0.643") 138 call checkfmt("(ru,-2pf18.3)", -643.125, " -6.431") 139 call checkfmt("(ru,-1pf18.3)", -643.125, " -64.312") 140 call checkfmt("(ru, 0pf18.3)", -643.125, " -643.125") 141 142 call checkfmt("(rd,-8pf18.3)", -643.125, " -0.001") 143 call checkfmt("(rd,-7pf18.3)", -643.125, " -0.001") 144 call checkfmt("(rd,-6pf18.3)", -643.125, " -0.001") 145 call checkfmt("(rd,-5pf18.3)", -643.125, " -0.007") 146 call checkfmt("(rd,-4pf18.3)", -643.125, " -0.065") 147 call checkfmt("(rd,-3pf18.3)", -643.125, " -0.644") 148 call checkfmt("(rd,-2pf18.3)", -643.125, " -6.432") 149 call checkfmt("(rd,-1pf18.3)", -643.125, " -64.313") 150 call checkfmt("(rd, 0pf18.3)", -643.125, " -643.125") 151 152 call checkfmt("(rz,-8pf18.3)", -643.125, " -0.000") 153 call checkfmt("(rz,-7pf18.3)", -643.125, " -0.000") 154 call checkfmt("(rz,-6pf18.3)", -643.125, " -0.000") 155 call checkfmt("(rz,-5pf18.3)", -643.125, " -0.006") 156 call checkfmt("(rz,-4pf18.3)", -643.125, " -0.064") 157 call checkfmt("(rz,-3pf18.3)", -643.125, " -0.643") 158 call checkfmt("(rz,-2pf18.3)", -643.125, " -6.431") 159 call checkfmt("(rz,-1pf18.3)", -643.125, " -64.312") 160 call checkfmt("(rz, 0pf18.3)", -643.125, " -643.125") 161 162 call checkfmt("(rc,-8pf18.3)", -643.125, " -0.000") 163 call checkfmt("(rc,-7pf18.3)", -643.125, " -0.000") 164 call checkfmt("(rc,-6pf18.3)", -643.125, " -0.001") 165 call checkfmt("(rc,-5pf18.3)", -643.125, " -0.006") 166 call checkfmt("(rc,-4pf18.3)", -643.125, " -0.064") 167 call checkfmt("(rc,-3pf18.3)", -643.125, " -0.643") 168 call checkfmt("(rc,-2pf18.3)", -643.125, " -6.431") 169 call checkfmt("(rc,-1pf18.3)", -643.125, " -64.313") 170 call checkfmt("(rc, 0pf18.3)", -643.125, " -643.125") 171 172 call checkfmt("(rn,-8pf18.3)", -643.125, " -0.000") 173 call checkfmt("(rn,-7pf18.3)", -643.125, " -0.000") 174 call checkfmt("(rn,-6pf18.3)", -643.125, " -0.001") 175 call checkfmt("(rn,-5pf18.3)", -643.125, " -0.006") 176 call checkfmt("(rn,-4pf18.3)", -643.125, " -0.064") 177 call checkfmt("(rn,-3pf18.3)", -643.125, " -0.643") 178 call checkfmt("(rn,-2pf18.3)", -643.125, " -6.431") 179 call checkfmt("(rn,-1pf18.3)", -643.125, " -64.312") 180 call checkfmt("(rn, 0pf18.3)", -643.125, " -643.125") 181 182 call checkfmt("(rp,-8pf18.3)", -643.125, " -0.000") 183 call checkfmt("(rp,-7pf18.3)", -643.125, " -0.000") 184 call checkfmt("(rp,-6pf18.3)", -643.125, " -0.001") 185 call checkfmt("(rp,-5pf18.3)", -643.125, " -0.006") 186 call checkfmt("(rp,-4pf18.3)", -643.125, " -0.064") 187 call checkfmt("(rp,-3pf18.3)", -643.125, " -0.643") 188 call checkfmt("(rp,-2pf18.3)", -643.125, " -6.431") 189 call checkfmt("(rp,-1pf18.3)", -643.125, " -64.312") 190 call checkfmt("(rp, 0pf18.3)", -643.125, " -643.125") 191 192 ! print *, n_tst, n_cnt, n_skip 193 if (n_cnt /= 0) call abort 194 if (all(.not. l_skip)) print *, "All kinds rounded to nearest" 195 196contains 197 subroutine checkfmt(fmt, x, cmp) 198 implicit none 199 integer :: i 200 character(len=*), intent(in) :: fmt 201 real, intent(in) :: x 202 character(len=*), intent(in) :: cmp 203 do i=1,size(real_kinds) 204 if (i == 1) then 205 write(s, fmt) real(x,kind=j(1)) 206 else if (i == 2) then 207 write(s, fmt) real(x,kind=j(2)) 208 else if (i == 3) then 209 write(s, fmt) real(x,kind=j(3)) 210 else if (i == 4) then 211 write(s, fmt) real(x,kind=j(4)) 212 end if 213 n_tst = n_tst + 1 214 if (s /= cmp) then 215 if (l_skip(i)) then 216 n_skip = n_skip + 1 217 else 218 print "(a,1x,a,' expected: ',1x,a)", fmt, s, cmp 219 n_cnt = n_cnt + 1 220 end if 221 end if 222 end do 223 224 end subroutine 225end program 226! { dg-output "All kinds rounded to nearest" { xfail { i?86-*-solaris2.9* hppa*-*-hpux* } } } 227