├── .gitignore ├── README.md ├── app └── main.f90 ├── fpm.toml ├── src ├── lookup_table.f90 ├── real32_to_shortest.f90 ├── real64_to_exp.f90 ├── real64_to_fixed.f90 ├── real64_to_shortest.f90 ├── ryu.f90 └── ryu_utils.f90 └── test ├── benchmark ├── bench_option.txt ├── benchmark.f90 └── random.f90 ├── test_d2exp ├── test_d2exp.f90 └── tester.f90 ├── test_d2fixed ├── test_d2fixed.f90 └── tester.f90 ├── test_d2shortest ├── test_d2shortest.f90 └── tester.f90 └── test_f2shortest ├── test_f2shortest.f90 └── tester.f90 /.gitignore: -------------------------------------------------------------------------------- 1 | build/* 2 | test/test_roundtrip/check*.txt 3 | *.h 4 | *.c 5 | c_ryu.f90 6 | .vscode -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ryu_fortran 2 | A Fortran implementation of [Ryu](https://dl.acm.org/doi/10.1145/3296979.3192369) algorithm which converts floating point numbers to decimal strings. It is more effective than internal file approach. 3 | 4 | This implementation is based on the [Scala](https://github.com/scala-native/scala-native/tree/master/nativelib/src/main/scala/scala/scalanative/runtime/ieee754tostring/ryu) version of Ryu. 5 | 6 | 7 | ## Install 8 | 9 | ### Fortran package manager 10 | 11 | Add fpm dependency declaration in the `fpm.toml` file of your project. 12 | ```toml 13 | [dependencies] 14 | ryu_fortran = { git = "https://github.com/St-Maxwell/ryu_fortran" } 15 | ``` 16 | 17 | ## Usage 18 | 19 | ```fortran 20 | use ryu, only: f2shortest, d2shortest, d2fixed, d2exp 21 | use iso_fortran_env, only: real32, real64 22 | 23 | write (*, "(A)") f2shortest(3.14159_real32) 24 | write (*, "(A)") d2shortest(2.718281828_real64) 25 | write (*, "(A)") d2fixed(1.2345678987654321_real64, 10) 26 | write (*, "(A)") d2exp(299792458._real64, 5) 27 | 28 | ! 3.14159 29 | ! 2.718281828 30 | ! 1.2345678988 31 | ! 2.99792E+08 32 | ``` 33 | 34 | ## Test 35 | Ryu algorithm is meant to generate the shortest decimal representaion of a floating point number, and is able to preserve the information after conversion. That is, if we convert the produced string back to a floating point number, we should obtain the same binary representation comparing to the original number. 36 | 37 | `f2shortest`, `d2shortest`, `d2fixed` and `d2exp` have been fully tested using the test cases from [ulfjack/ryu](https://github.com/ulfjack/ryu/tree/master/ryu/tests). 38 | 39 | To perform the tests, run 40 | ```bash 41 | fpm test [test-item] 42 | ``` 43 | where `test-item` can be `test-f2shortest`, `test-d2shortest`, `test-d2fixed` and `test-d2exp`. 44 | 45 | ## Benchmark 46 | * Compiler: gfortran version 9.3.0 (Ubuntu-20.04 WSL2) 47 | * Command: `fpm test benchmark --profile release` 48 | 49 | Results 50 | ``` 51 | Benchmark for f2shortest 52 | f2shortest Time (us): 0.0785894 Std Dev: 0.0118 53 | internal IO Time (us): 0.7998928 Std Dev: 0.0778 54 | 55 | Benchmark for d2shortest 56 | d2shortest Time (us): 0.1047708 Std Dev: 0.0110 57 | internal IO Time (us): 0.9942683 Std Dev: 0.1660 58 | 59 | Benchmark for d2exp 60 | d2exp Time (us): 0.1041636 Std Dev: 0.0167 61 | internal IO Time (us): 0.9326320 Std Dev: 0.1252 62 | 63 | Benchmark for d2fixed 64 | d2fixed Time (us): 0.2314018 Std Dev: 0.2261 65 | internal IO Time (us): 2.3488336 Std Dev: 2.3387 66 | ``` 67 | -------------------------------------------------------------------------------- /app/main.f90: -------------------------------------------------------------------------------- 1 | module to_string_m 2 | use ryu, only: f2shortest, d2shortest, d2fixed, d2exp 3 | use iso_fortran_env, only: int32, real32, real64 4 | implicit none 5 | private 6 | public :: to_string 7 | 8 | interface to_string 9 | module procedure :: to_string_real32 10 | module procedure :: to_string_real64 11 | end interface 12 | 13 | contains 14 | 15 | function to_string_real32(f, fmt) result(str) 16 | real(kind=real32), intent(in) :: f 17 | character(len=*), intent(in), optional :: fmt 18 | character(len=:), allocatable :: str 19 | 20 | if (.not. present(fmt)) then 21 | str = f2shortest(f) 22 | else 23 | block 24 | integer :: p, t 25 | call parse_fmt(fmt, p, t) 26 | if (t == 0) then 27 | str = f2fixed(f, p) 28 | else 29 | str = f2exp(f, p) 30 | end if 31 | end block 32 | end if 33 | 34 | end function to_string_real32 35 | 36 | function to_string_real64(f, fmt) result(str) 37 | real(kind=real64), intent(in) :: f 38 | character(len=*), intent(in), optional :: fmt 39 | character(len=:), allocatable :: str 40 | 41 | if (.not. present(fmt)) then 42 | str = d2shortest(f) 43 | else 44 | block 45 | integer :: p, t 46 | call parse_fmt(fmt, p, t) 47 | if (t == 0) then 48 | str = d2fixed(f, p) 49 | else 50 | str = d2exp(f, p) 51 | end if 52 | end block 53 | end if 54 | 55 | end function to_string_real64 56 | 57 | function f2fixed(f, precision_) result(str) 58 | real(kind=real32), intent(in) :: f 59 | integer(kind=int32), intent(in) :: precision_ 60 | character(len=:), allocatable :: str 61 | 62 | str = d2fixed(real(f, real64), precision_) 63 | 64 | end function f2fixed 65 | 66 | function f2exp(f, precision_) result(str) 67 | real(kind=real32), intent(in) :: f 68 | integer(kind=int32), intent(in) :: precision_ 69 | character(len=:), allocatable :: str 70 | 71 | str = d2exp(real(f, real64), precision_) 72 | 73 | end function f2exp 74 | 75 | subroutine parse_fmt(fmt, precision, type) 76 | character(len=*), intent(in) :: fmt ! %.xxf or %.xxe 77 | integer, intent(out) :: precision 78 | integer, intent(out) :: type ! 0: fixed; 1: exp 79 | integer :: sz 80 | 81 | ! check head 82 | if (fmt(1:2) /= "%.") error stop "Invalid format" 83 | 84 | sz = len(trim(fmt)) 85 | ! check tail 86 | if (fmt(sz:sz) == 'f') then 87 | type = 0 88 | else if (fmt(sz:sz) == 'e') then 89 | type = 1 90 | else 91 | error stop "Invalid format" 92 | end if 93 | 94 | ! read precision 95 | read(fmt(3:sz-1),*) precision 96 | 97 | end subroutine parse_fmt 98 | 99 | end module to_string_m 100 | 101 | program main 102 | use to_string_m, only: to_string 103 | use iso_fortran_env, only: real32, real64 104 | implicit none 105 | 106 | write(*,"(A)") to_string(3.14_real32) 107 | write(*,"(A)") to_string(3.14_real32, "%.5f") 108 | write(*,"(A)") to_string(3.14_real32, "%.5e") 109 | write(*,"(A)") to_string(114514.1919810_real64) 110 | write(*,"(A)") to_string(114514.1919810_real64, "%.10f") 111 | write(*,"(A)") to_string(114514.1919810_real64, "%.10e") 112 | 113 | end program main 114 | -------------------------------------------------------------------------------- /fpm.toml: -------------------------------------------------------------------------------- 1 | name = "ryu_fortran" 2 | version = "0.1.0" 3 | license = "license" 4 | maintainer = "St Maxwell" 5 | 6 | [build] 7 | auto-executables = true 8 | 9 | [dev-dependencies] 10 | test-drive.git = "https://github.com/fortran-lang/test-drive.git" 11 | 12 | [[test]] 13 | name = "test-f2shortest" 14 | source-dir = "test/test_f2shortest" 15 | main = "tester.f90" 16 | 17 | [[test]] 18 | name = "test-d2shortest" 19 | source-dir = "test/test_d2shortest" 20 | main = "tester.f90" 21 | 22 | [[test]] 23 | name = "test-d2exp" 24 | source-dir = "test/test_d2exp" 25 | main = "tester.f90" 26 | 27 | [[test]] 28 | name = "test-d2fixed" 29 | source-dir = "test/test_d2fixed" 30 | main = "tester.f90" 31 | -------------------------------------------------------------------------------- /src/real32_to_shortest.f90: -------------------------------------------------------------------------------- 1 | module real32_to_shortest 2 | use ryu_utils, only: FLOAT_MANTISSA_BITS, FLOAT_MANTISSA_MASK, FLOAT_EXPONENT_BITS, & 3 | FLOAT_EXPONENT_MASK, FLOAT_EXPONENT_BIAS, & 4 | accept_lower_bound, accept_upper_bound 5 | use iso_fortran_env, only: int32, int64, real32 6 | use ieee_arithmetic 7 | implicit none 8 | private 9 | public :: f2shortest 10 | 11 | integer(kind=int64), parameter :: LOG10_2_DENOMINATOR = 10000000_int64 12 | integer(kind=int64), parameter :: LOG10_2_NUMERATOR = int(LOG10_2_DENOMINATOR*log10(2.), int64) 13 | integer(kind=int64), parameter :: LOG10_5_DENOMINATOR = 10000000_int64 14 | integer(kind=int64), parameter :: LOG10_5_NUMERATOR = int(LOG10_5_DENOMINATOR*log10(5.), int64) 15 | integer(kind=int64), parameter :: LOG2_5_DENOMINATOR = 10000000_int64 16 | integer(kind=int64), parameter :: LOG2_5_NUMERATOR = int(LOG2_5_DENOMINATOR*(log(5.)/log(2.)), int64) 17 | integer(kind=int32), parameter :: POW5_BITCOUNT = 61_int32 18 | integer(kind=int32), parameter :: POW5_HALF_BITCOUNT = 31_int32 19 | integer(kind=int32), parameter :: POW5_INV_BITCOUNT = 59_int32 20 | integer(kind=int32), parameter :: POW5_INV_HALF_BITCOUNT = 31_int32 21 | integer(kind=int32), parameter :: POW5_ARRAY_NCOL = 2 22 | 23 | integer(kind=int64), dimension(*), parameter :: POW5_SPLIT = [ & 24 | 536870912, 0, & 25 | 671088640, 0, & 26 | 838860800, 0, & 27 | 1048576000, 0, & 28 | 655360000, 0, & 29 | 819200000, 0, & 30 | 1024000000, 0, & 31 | 640000000, 0, & 32 | 800000000, 0, & 33 | 1000000000, 0, & 34 | 625000000, 0, & 35 | 781250000, 0, & 36 | 976562500, 0, & 37 | 610351562, 1073741824, & 38 | 762939453, 268435456, & 39 | 953674316, 872415232, & 40 | 596046447, 1619001344, & 41 | 745058059, 1486880768, & 42 | 931322574, 1321730048, & 43 | 582076609, 289210368, & 44 | 727595761, 898383872, & 45 | 909494701, 1659850752, & 46 | 568434188, 1305842176, & 47 | 710542735, 1632302720, & 48 | 888178419, 1503507488, & 49 | 555111512, 671256724, & 50 | 693889390, 839070905, & 51 | 867361737, 2122580455, & 52 | 542101086, 521306416, & 53 | 677626357, 1725374844, & 54 | 847032947, 546105819, & 55 | 1058791184, 145761362, & 56 | 661744490, 91100851, & 57 | 827180612, 1187617888, & 58 | 1033975765, 1484522360, & 59 | 646234853, 1196261931, & 60 | 807793566, 2032198326, & 61 | 1009741958, 1466506084, & 62 | 631088724, 379695390, & 63 | 788860905, 474619238, & 64 | 986076131, 1130144959, & 65 | 616297582, 437905143, & 66 | 770371977, 1621123253, & 67 | 962964972, 415791331, & 68 | 601853107, 1333611405, & 69 | 752316384, 1130143345, & 70 | 940395480, 1412679181 & 71 | ] 72 | 73 | integer(kind=int64), dimension(*), parameter :: POW5_INV_SPLIT = [ & 74 | 268435456, 1, & 75 | 214748364, 1717986919, & 76 | 171798691, 1803886265, & 77 | 137438953, 1013612282, & 78 | 219902325, 1192282922, & 79 | 175921860, 953826338, & 80 | 140737488, 763061070, & 81 | 225179981, 791400982, & 82 | 180143985, 203624056, & 83 | 144115188, 162899245, & 84 | 230584300, 1978625710, & 85 | 184467440, 1582900568, & 86 | 147573952, 1266320455, & 87 | 236118324, 308125809, & 88 | 188894659, 675997377, & 89 | 151115727, 970294631, & 90 | 241785163, 1981968139, & 91 | 193428131, 297084323, & 92 | 154742504, 1955654377, & 93 | 247588007, 1840556814, & 94 | 198070406, 613451992, & 95 | 158456325, 61264864, & 96 | 253530120, 98023782, & 97 | 202824096, 78419026, & 98 | 162259276, 1780722139, & 99 | 259614842, 1990161963, & 100 | 207691874, 733136111, & 101 | 166153499, 1016005619, & 102 | 265845599, 337118801, & 103 | 212676479, 699191770, & 104 | 170141183, 988850146 & 105 | ] 106 | 107 | contains 108 | 109 | function f2shortest(fn) result(str) 110 | real(kind=real32), intent(in) :: fn 111 | character(len=:), allocatable :: str 112 | integer(kind=int32) :: bits 113 | integer(kind=int32) :: ieee_exponent, ieee_mantissa 114 | logical(kind=int32) :: ieee_sign 115 | integer(kind=int32) :: e2, m2 116 | logical(kind=int32) :: even 117 | integer(kind=int32) :: mv, mp, mm 118 | integer(kind=int32) :: dp, dv, dm, e10 119 | integer(kind=int32) :: q, k, i, j, l 120 | logical(kind=int32) :: dp_is_trailing_zeros, dv_is_trailing_zeros, dm_is_trailing_zeros 121 | integer(kind=int32) :: last_remove_digit 122 | integer(kind=int32) :: dplength 123 | integer(kind=int32) :: expn 124 | logical(kind=int32) :: scientific_notation 125 | integer(kind=int32) :: removed 126 | logical(kind=int32) :: done 127 | integer(kind=int32) :: output 128 | integer(kind=int32) :: olength 129 | integer(kind=int32) :: idx 130 | integer(kind=int32) :: c 131 | integer(kind=int32) :: current 132 | 133 | if (ieee_is_nan(fn)) then 134 | str = "NaN" 135 | return 136 | end if 137 | 138 | if (ieee_class(fn) == ieee_positive_inf) then 139 | str = "Infinity" 140 | return 141 | end if 142 | 143 | if (ieee_class(fn) == ieee_negative_inf) then 144 | str = "-Infinity" 145 | return 146 | end if 147 | 148 | if (ieee_class(fn) == ieee_positive_zero) then 149 | str = "0.0" 150 | return 151 | end if 152 | 153 | if (ieee_class(fn) == ieee_negative_zero) then 154 | str = "-0.0" 155 | return 156 | end if 157 | 158 | !! step 1 159 | bits = transfer(fn, 1_int32) 160 | ieee_sign = bits < 0 161 | ieee_exponent = iand(ishft(bits, -FLOAT_MANTISSA_BITS), FLOAT_EXPONENT_MASK) 162 | ieee_mantissa = iand(bits, FLOAT_MANTISSA_MASK) 163 | 164 | if (ieee_exponent == 0) then 165 | e2 = 1 - FLOAT_EXPONENT_BIAS - FLOAT_MANTISSA_BITS - 2 166 | m2 = ieee_mantissa 167 | else 168 | e2 = ieee_exponent - FLOAT_EXPONENT_BIAS - FLOAT_MANTISSA_BITS - 2 169 | m2 = ior(ieee_mantissa, ishft(1, FLOAT_MANTISSA_BITS)) 170 | end if 171 | 172 | 173 | !! step 2 174 | even = iand(m2, 1) == 0 175 | mv = 4*m2 176 | mp = 4*m2 + 2 177 | if (m2 /= ishft(1_int64, FLOAT_MANTISSA_BITS) .or. ieee_exponent <= 1) then 178 | mm = 4*m2 - 2 179 | else 180 | mm = 4*m2 - 1 181 | end if 182 | 183 | !! step 3 184 | last_remove_digit = 0_int32 185 | dv_is_trailing_zeros = .false. 186 | dm_is_trailing_zeros = .false. 187 | 188 | if (e2 >= 0) then 189 | q = int(e2*LOG10_2_NUMERATOR/LOG10_2_DENOMINATOR, int32) 190 | k = POW5_INV_BITCOUNT + pow5bits(q) - 1 191 | i = -e2 + q + k 192 | dv = int(mulPow5InvDivPow2(mv, q, i), int32) 193 | dp = int(mulPow5InvDivPow2(mp, q, i), int32) 194 | dm = int(mulPow5InvDivPow2(mm, q, i), int32) 195 | if (q /= 0 .and. (dp - 1)/10 <= dm/10) then 196 | l = POW5_INV_BITCOUNT + pow5bits(q - 1) - 1 197 | last_remove_digit = int(mod(mulPow5InvDivPow2(mv, q - 1, -e2 + q - 1 + l), 10), int32) 198 | end if 199 | e10 = q 200 | dp_is_trailing_zeros = pow5Factor(mp) >= q 201 | dv_is_trailing_zeros = pow5Factor(mv) >= q 202 | dm_is_trailing_zeros = pow5Factor(mm) >= q 203 | else 204 | q = int(-e2*LOG10_5_NUMERATOR/LOG10_5_DENOMINATOR, int32) 205 | i = -e2 - q 206 | k = pow5bits(i) - POW5_BITCOUNT 207 | j = q - k 208 | 209 | dv = int(mulPow5divPow2(mv, i, j), int32) 210 | dp = int(mulPow5divPow2(mp, i, j), int32) 211 | dm = int(mulPow5divPow2(mm, i, j), int32) 212 | if (q /= 0 .and. (dp - 1)/10 <= dm/10) then 213 | j = q - 1 - (pow5bits(i + 1) - POW5_BITCOUNT) 214 | last_remove_digit = int(mod(mulPow5divPow2(mv, i + 1, j), 10), int32) 215 | end if 216 | e10 = q + e2 217 | dp_is_trailing_zeros = 1 >= q 218 | dm_is_trailing_zeros = merge(0, 1, mod(mm, 2) == 1) >= q 219 | if (q <= 1) then 220 | dv_is_trailing_zeros = .true. 221 | else if (q < 31) then 222 | dv_is_trailing_zeros = iand(mv, shiftl(1, q-1) - 1) == 0 223 | end if 224 | end if 225 | 226 | !! step 4 227 | dplength = decimal_length(dp) 228 | expn = e10 + dplength - 1 229 | scientific_notation = .not. (expn >= -3 .and. expn < 7) 230 | removed = 0 231 | if (dp_is_trailing_zeros .and. .not. accept_upper_bound(even)) dp = dp - 1 232 | 233 | done = .false. 234 | do while (dp/10 > dm/10 .and. .not. done) 235 | if (dp < 100 .and. scientific_notation) then 236 | done = .true. 237 | else 238 | dm_is_trailing_zeros = dm_is_trailing_zeros .and. (mod(dm, 10) == 0) 239 | dp = dp/10 240 | last_remove_digit = mod(dv, 10) 241 | dv = dv/10 242 | dm = dm/10 243 | removed = removed + 1 244 | end if 245 | end do 246 | 247 | if (dm_is_trailing_zeros .and. accept_lower_bound(even)) then 248 | done = .false. 249 | do while (mod(dm, 10) == 0 .and. .not. done) 250 | if (dp < 100 .and. scientific_notation) then 251 | done = .true. 252 | else 253 | dp = dp/10 254 | last_remove_digit = mod(dv, 10) 255 | dv = dv/10 256 | dm = dm/10 257 | removed = removed + 1 258 | end if 259 | end do 260 | end if 261 | 262 | if (dv_is_trailing_zeros .and. last_remove_digit == 5 .and. mod(dv, 2) == 0) & 263 | last_remove_digit = 4 264 | 265 | if ((dv == dm .and. (.not. dm_is_trailing_zeros .or. .not. accept_lower_bound(even))) & 266 | .or. last_remove_digit >= 5) then 267 | output = dv + 1 268 | else 269 | output = dv 270 | end if 271 | 272 | olength = dplength - removed 273 | 274 | !! step 5 275 | str = repeat(' ', 15) 276 | 277 | idx = 1 278 | if (ieee_sign) then 279 | str(idx:idx) = '-' 280 | idx = idx + 1 281 | end if 282 | 283 | if (scientific_notation) then 284 | do i = 0, olength - 2 285 | c = mod(output, 10) 286 | output = output/10 287 | str(idx + olength - i:idx + olength - i) = char(48 + c) ! 48 is ascii '0' 288 | end do 289 | str(idx:idx) = char(48 + mod(output, 10)) 290 | str(idx + 1:idx + 1) = '.' 291 | idx = idx + olength + 1 292 | if (olength == 1) then 293 | str(idx:idx) = '0' 294 | idx = idx + 1 295 | end if 296 | str(idx:idx) = 'E' 297 | idx = idx + 1 298 | if (expn < 0) then 299 | str(idx:idx) = '-' 300 | idx = idx + 1 301 | expn = -expn 302 | end if 303 | if (expn >= 10) then 304 | str(idx:idx) = char(48 + expn/10) 305 | idx = idx + 1 306 | end if 307 | str(idx:idx) = char(48 + mod(expn, 10)) 308 | else 309 | if (expn < 0) then 310 | str(idx:idx) = '0' 311 | idx = idx + 1 312 | str(idx:idx) = '.' 313 | idx = idx + 1 314 | i = -1 315 | do while (i > expn) 316 | str(idx:idx) = '0' 317 | idx = idx + 1 318 | i = i - 1 319 | end do 320 | current = idx 321 | do i = 0, olength - 1 322 | str(current + olength - i - 1:current + olength - i - 1) = char(48 + mod(output, 10)) 323 | output = output/10 324 | idx = idx + 1 325 | end do 326 | idx = idx - 1 327 | else if (expn + 1 >= olength) then 328 | do i = 0, olength - 1 329 | str(idx + olength - i - 1:idx + olength - i - 1) = char(48 + mod(output, 10)) 330 | output = output/10 331 | end do 332 | idx = idx + olength 333 | do i = 0, expn - olength 334 | str(idx:idx) = '0' 335 | idx = idx + 1 336 | end do 337 | str(idx:idx + 1) = ".0" 338 | idx = idx + 1 339 | else 340 | current = idx 341 | do i = 0, olength - 1 342 | if (olength - i - 1 == expn) then 343 | str(current + olength - i:current + olength - i) = '.' 344 | current = current - 1 345 | end if 346 | str(current + olength - i:current + olength - i) = char(48 + mod(output, 10)) 347 | output = output/10 348 | end do 349 | idx = idx + olength 350 | end if 351 | end if 352 | 353 | str = str(1:idx) 354 | 355 | end function f2shortest 356 | 357 | pure function pow5bits(e) result(r) 358 | integer(kind=int32), intent(in) :: e 359 | integer(kind=int32) :: r 360 | 361 | if (e == 0) then 362 | r = 1 363 | else 364 | r = int((e*LOG2_5_NUMERATOR + LOG2_5_DENOMINATOR - 1)/LOG2_5_DENOMINATOR, int32) 365 | end if 366 | 367 | end function pow5bits 368 | 369 | pure function pow5Factor(v) result(count) 370 | integer(kind=int32), intent(in) :: v 371 | integer(kind=int32) :: count 372 | integer(kind=int32) :: v_ 373 | 374 | v_ = v 375 | count = 0 376 | 377 | do while (v_ > 0) 378 | if (mod(v_, 5) /= 0) return 379 | v_ = v_/5 380 | count = count + 1 381 | end do 382 | 383 | error stop "Illegal Argument" 384 | 385 | end function pow5Factor 386 | 387 | pure function mulPow5divPow2(m, q, j) result(r) 388 | integer(kind=int32), intent(in) :: m 389 | integer(kind=int32), intent(in) :: q 390 | integer(kind=int32), intent(in) :: j 391 | integer(kind=int64) :: r 392 | 393 | integer(kind=int64) :: bits0, bits1 394 | 395 | bits0 = m*POW5_SPLIT(q*POW5_ARRAY_NCOL + 1) 396 | bits1 = m*POW5_SPLIT(q*POW5_ARRAY_NCOL + 2) 397 | 398 | r = shiftr(bits0 + shiftr(bits1, POW5_HALF_BITCOUNT), j - POW5_HALF_BITCOUNT) 399 | 400 | end function mulPow5divPow2 401 | 402 | pure function mulPow5InvDivPow2(m, q, j) result(r) 403 | integer(kind=int32), intent(in) :: m 404 | integer(kind=int32), intent(in) :: q 405 | integer(kind=int32), intent(in) :: j 406 | integer(kind=int64) :: r 407 | 408 | integer(kind=int64) :: bits0, bits1 409 | 410 | bits0 = m*POW5_INV_SPLIT(q*POW5_ARRAY_NCOL + 1) 411 | bits1 = m*POW5_INV_SPLIT(q*POW5_ARRAY_NCOL + 2) 412 | 413 | r = shiftr(bits0 + shiftr(bits1, POW5_INV_HALF_BITCOUNT), j - POW5_INV_HALF_BITCOUNT) 414 | 415 | end function mulPow5InvDivPow2 416 | 417 | pure function decimal_length(v) result(r) 418 | integer(kind=int32), intent(in) :: v 419 | integer(kind=int32) :: r 420 | integer(kind=int32) :: factor 421 | logical(kind=int32) :: done 422 | 423 | r = 10_int32 424 | factor = 1000000000_int32 425 | done = .false. 426 | do while (r > 0 .and. (.not. done)) 427 | if (v >= factor) then 428 | done = .true. 429 | else 430 | factor = factor/10 431 | r = r - 1 432 | end if 433 | end do 434 | 435 | end function decimal_length 436 | 437 | end module real32_to_shortest 438 | -------------------------------------------------------------------------------- /src/real64_to_exp.f90: -------------------------------------------------------------------------------- 1 | module real64_to_exp 2 | use ryu_utils 3 | use ryu_lookup_table 4 | use iso_fortran_env, only: int32, int64, real64 5 | use ieee_arithmetic 6 | implicit none 7 | private 8 | public :: d2exp 9 | 10 | contains 11 | 12 | function d2exp(d, precision_) result(str) 13 | real(kind=real64), intent(in) :: d 14 | integer(kind=int32), intent(in) :: precision_ 15 | character(len=:), allocatable :: str 16 | 17 | character(len=2000) :: buffer 18 | integer(kind=int32) :: precision 19 | integer(kind=int64) :: bits 20 | integer(kind=int32) :: ieee_exponent 21 | integer(kind=int64) :: ieee_mantissa 22 | logical(kind=int32) :: ieee_sign 23 | integer(kind=int32) :: e2 24 | integer(kind=int64) :: m2 25 | logical(kind=int32) :: print_decimal_point 26 | integer(kind=int32) :: index 27 | integer(kind=int32) :: digits 28 | integer(kind=int32) :: printed_digits 29 | integer(kind=int32) :: available_digits 30 | integer(kind=int32) :: expn 31 | integer(kind=int32) :: idx 32 | integer(kind=int32) :: p10bits 33 | integer(kind=int32) :: len 34 | integer(kind=int32) :: i, j, k, p 35 | integer(kind=int32) :: maximum 36 | integer(kind=int32) :: last_digit 37 | integer(kind=int32) :: roundup 38 | integer(kind=int32) :: rexp 39 | integer(kind=int32) :: required_twos 40 | logical(kind=int32) :: trailing_zeros 41 | integer(kind=int32) :: required_fives 42 | integer(kind=int32) :: round_index 43 | character(len=1) :: chr 44 | integer(kind=int32) :: c 45 | 46 | ! deal with special cases 47 | if (ieee_is_nan(d)) then 48 | str = "NaN" 49 | return 50 | end if 51 | 52 | if (ieee_class(d) == ieee_positive_inf) then 53 | str = "Infinity" 54 | return 55 | end if 56 | 57 | if (ieee_class(d) == ieee_negative_inf) then 58 | str = "-Infinity" 59 | return 60 | end if 61 | 62 | if (ieee_class(d) == ieee_positive_zero) then 63 | if (precision_ > 0) then 64 | str = "0." // repeat('0', precision_) // "E+00" 65 | else 66 | str = '0E+00' 67 | end if 68 | return 69 | end if 70 | 71 | if (ieee_class(d) == ieee_negative_zero) then 72 | if (precision_ > 0) then 73 | str = "-0." // repeat('0', precision_) // "E+00" 74 | else 75 | str = "-0E+00" 76 | end if 77 | return 78 | end if 79 | 80 | bits = transfer(d, 1_int64) 81 | ieee_sign = bits < 0 82 | ieee_exponent = int(iand(shiftr(bits, DOUBLE_MANTISSA_BITS), int(DOUBLE_EXPONENT_MASK, int64)), int32) 83 | ieee_mantissa = iand(bits, DOUBLE_MANTISSA_MASK) 84 | 85 | if (ieee_exponent == 0) then 86 | e2 = 1 - DOUBLE_EXPONENT_BIAS - DOUBLE_MANTISSA_BITS 87 | m2 = ieee_mantissa 88 | else 89 | e2 = ieee_exponent - DOUBLE_EXPONENT_BIAS - DOUBLE_MANTISSA_BITS 90 | m2 = ior(ieee_mantissa, shiftl(1_int64, DOUBLE_MANTISSA_BITS)) 91 | end if 92 | 93 | precision = precision_ 94 | print_decimal_point = precision > 0 95 | precision = precision + 1 96 | 97 | index = 1 98 | if (ieee_sign) then 99 | buffer(index:index) = '-' 100 | index = index + 1 101 | end if 102 | digits = 0 103 | printed_digits = 0 104 | available_digits = 0 105 | expn = 0 106 | 107 | if (e2 >= -52) then 108 | if (e2 < 0) then 109 | idx = 0 110 | else 111 | idx = index_for_expn(e2) 112 | end if 113 | p10bits = pow10_bits_for_index(idx) 114 | len = length_for_index(idx) 115 | 116 | do i = len - 1, 0, -1 117 | j = p10bits - e2 118 | digits = mulShift_mod1e9(shiftl(m2, 8), & 119 | POW10_SPLIT(:, POW10_OFFSET(idx + 1) + i + 1), & 120 | j + 8) 121 | 122 | if (printed_digits /= 0) then 123 | if (printed_digits + 9 > precision) then 124 | available_digits = 9 125 | exit 126 | end if 127 | call append_nine_digits(digits, buffer(index:)) 128 | index = index + 9 129 | printed_digits = printed_digits + 9 130 | else if (digits /= 0) then 131 | available_digits = decimal_length9(digits) 132 | expn = i*9 + available_digits - 1 133 | if (available_digits > precision) exit 134 | if (print_decimal_point) then 135 | call append_d_digits(available_digits, digits, buffer(index:)) 136 | index = index + available_digits + 1 137 | else 138 | buffer(index:index) = char(48 + digits) 139 | index = index + 1 140 | end if 141 | printed_digits = available_digits 142 | available_digits = 0 143 | end if 144 | end do 145 | end if 146 | 147 | if (e2 < 0 .and. available_digits == 0) then 148 | idx = -e2/16 149 | do i = MIN_BLOCK_2(idx + 1), 199 150 | j = ADDITIONAL_BITS_2 + (-e2 - 16*idx) 151 | p = POW10_OFFSET_2(idx + 1) + i - MIN_BLOCK_2(idx + 1) 152 | if (p >= POW10_OFFSET_2(idx + 2)) then 153 | digits = 0 154 | else 155 | digits = mulShift_mod1e9(shiftl(m2, 8), & 156 | POW10_SPLIT_2(:, p + 1), & 157 | j + 8) 158 | end if 159 | if (printed_digits /= 0) then 160 | if (printed_digits + 9 > precision) then 161 | available_digits = 9 162 | exit 163 | end if 164 | call append_nine_digits(digits, buffer(index:)) 165 | index = index + 9 166 | printed_digits = printed_digits + 9 167 | else if (digits /= 0) then 168 | available_digits = decimal_length9(digits) 169 | expn = -(i + 1)*9 + available_digits - 1 170 | if (available_digits > precision) exit 171 | if (print_decimal_point) then 172 | call append_d_digits(available_digits, digits, buffer(index:)) 173 | index = index + available_digits + 1 174 | else 175 | buffer(index:index) = char(48 + digits) 176 | index = index + 1 177 | end if 178 | printed_digits = available_digits 179 | available_digits = 0 180 | end if 181 | end do 182 | end if 183 | 184 | maximum = precision - printed_digits 185 | 186 | if (available_digits == 0) digits = 0 187 | 188 | last_digit = 0 189 | if (available_digits > maximum) then 190 | do k = 1, available_digits - maximum 191 | last_digit = mod(digits, 10) 192 | digits = digits/10 193 | end do 194 | end if 195 | 196 | roundup = 0 197 | if (last_digit /= 5) then 198 | roundup = merge(1, 0, last_digit > 5) 199 | else 200 | rexp = precision - expn 201 | required_twos = -e2 - rexp 202 | trailing_zeros = required_twos <= 0 & 203 | .or. (required_twos < 60 .and. multiple_of_power_of2(m2, required_twos)) 204 | if (rexp < 0) then 205 | required_fives = -rexp 206 | trailing_zeros = trailing_zeros .and. multiple_of_power_of5(m2, required_fives) 207 | end if 208 | roundup = merge(2, 1, trailing_zeros) 209 | end if 210 | 211 | if (printed_digits /= 0) then 212 | if (digits == 0) then 213 | buffer(index:index + maximum - 1) = repeat('0', maximum) 214 | else 215 | call append_c_digits(maximum, digits, buffer(index:)) 216 | end if 217 | index = index + maximum 218 | else 219 | if (print_decimal_point) then 220 | call append_d_digits(maximum, digits, buffer(index:)) 221 | index = index + maximum + 1 222 | else 223 | buffer(index:index) = char(48 + digits) 224 | index = index + 1 225 | end if 226 | end if 227 | 228 | if (roundup /= 0) then 229 | round_index = index 230 | do 231 | round_index = round_index - 1 232 | if (round_index /= 0) chr = buffer(round_index:round_index) 233 | if (round_index == 0 .or. chr == '-') then 234 | buffer(round_index + 1:round_index + 1) = '1' 235 | expn = expn + 1 236 | exit 237 | end if 238 | if (chr == '.') then 239 | cycle 240 | else if (chr == '9') then 241 | buffer(round_index:round_index) = '0' 242 | roundup = 1 243 | cycle 244 | else 245 | if (roundup == 2 .and. mod(ichar(chr), 2) == 0) exit 246 | buffer(round_index:round_index) = char(ichar(chr) + 1) 247 | exit 248 | end if 249 | end do 250 | end if 251 | 252 | buffer(index:index) = 'E' 253 | index = index + 1 254 | if (expn < 0) then 255 | buffer(index:index) = '-' 256 | expn = -expn 257 | index = index + 1 258 | else 259 | buffer(index:index) = '+' 260 | index = index + 1 261 | end if 262 | 263 | if (expn >= 100) then 264 | c = mod(expn, 10) 265 | buffer(index:index + 1) = DIGIT_TABLE(2*(expn/10) + 1:2*(expn/10) + 2) 266 | buffer(index + 2:index + 2) = char(48 + c) 267 | index = index + 2 268 | else 269 | buffer(index:index + 1) = DIGIT_TABLE(2*expn + 1:2*expn + 2) 270 | index = index + 1 271 | end if 272 | 273 | str = buffer(:index) 274 | 275 | end function d2exp 276 | 277 | end module real64_to_exp 278 | -------------------------------------------------------------------------------- /src/real64_to_fixed.f90: -------------------------------------------------------------------------------- 1 | module real64_to_fixed 2 | use ryu_utils 3 | use ryu_lookup_table 4 | use iso_fortran_env, only: int32, int64, real64 5 | use ieee_arithmetic 6 | implicit none 7 | private 8 | public :: d2fixed 9 | 10 | contains 11 | 12 | function d2fixed(d, precision_) result(str) 13 | real(kind=real64), intent(in) :: d 14 | integer(kind=int32), intent(in) :: precision_ 15 | character(len=:), allocatable :: str 16 | 17 | character(len=2000) :: buffer 18 | integer(kind=int32) :: precision 19 | integer(kind=int64) :: bits 20 | integer(kind=int32) :: ieee_exponent 21 | integer(kind=int64) :: ieee_mantissa 22 | logical(kind=int32) :: ieee_sign 23 | integer(kind=int32) :: e2 24 | integer(kind=int64) :: m2 25 | integer(kind=int32) :: index 26 | logical(kind=int32) :: nonzero 27 | integer(kind=int32) :: digits 28 | integer(kind=int32) :: olength 29 | integer(kind=int32) :: blocks 30 | integer(kind=int32) :: fill 31 | integer(kind=int32) :: idx 32 | integer(kind=int32) :: p10bits 33 | integer(kind=int32) :: len 34 | integer(kind=int32) :: i, j, k, p 35 | integer(kind=int32) :: maximum 36 | integer(kind=int32) :: last_digit 37 | integer(kind=int32) :: roundup 38 | integer(kind=int32) :: required_twos 39 | logical(kind=int32) :: trailing_zeros 40 | integer(kind=int32) :: round_index 41 | integer(kind=int32) :: dot_index 42 | character(len=1) :: chr 43 | 44 | ! deal with special cases 45 | if (ieee_is_nan(d)) then 46 | str = "NaN" 47 | return 48 | end if 49 | 50 | if (ieee_class(d) == ieee_positive_inf) then 51 | str = "Infinity" 52 | return 53 | end if 54 | 55 | if (ieee_class(d) == ieee_negative_inf) then 56 | str = "-Infinity" 57 | return 58 | end if 59 | 60 | if (ieee_class(d) == ieee_positive_zero) then 61 | if (precision_ > 0) then 62 | str = "0." // repeat('0', precision_) 63 | else 64 | str = '0' 65 | end if 66 | return 67 | end if 68 | 69 | if (ieee_class(d) == ieee_negative_zero) then 70 | if (precision_ > 0) then 71 | str = "-0." // repeat('0', precision_) 72 | else 73 | str = "-0" 74 | end if 75 | return 76 | end if 77 | 78 | bits = transfer(d, 1_int64) 79 | ieee_sign = bits < 0 80 | ieee_exponent = int(iand(shiftr(bits, DOUBLE_MANTISSA_BITS), int(DOUBLE_EXPONENT_MASK, int64)), int32) 81 | ieee_mantissa = iand(bits, DOUBLE_MANTISSA_MASK) 82 | 83 | if (ieee_exponent == 0) then 84 | e2 = 1 - DOUBLE_EXPONENT_BIAS - DOUBLE_MANTISSA_BITS 85 | m2 = ieee_mantissa 86 | else 87 | e2 = ieee_exponent - DOUBLE_EXPONENT_BIAS - DOUBLE_MANTISSA_BITS 88 | m2 = ior(ieee_mantissa, shiftl(1_int64, DOUBLE_MANTISSA_BITS)) 89 | end if 90 | 91 | precision = precision_ 92 | 93 | index = 1 94 | nonzero = .false. 95 | if (ieee_sign) then 96 | buffer(index:index) = '-' 97 | index = index + 1 98 | end if 99 | 100 | if (e2 >= -52) then 101 | if (e2 < 0) then 102 | idx = 0 103 | else 104 | idx = index_for_expn(e2) 105 | end if 106 | p10bits = pow10_bits_for_index(idx) 107 | len = length_for_index(idx) 108 | 109 | do i = len - 1, 0, -1 110 | j = p10bits - e2 111 | digits = mulShift_mod1e9(shiftl(m2, 8), & 112 | POW10_SPLIT(:, POW10_OFFSET(idx + 1) + i + 1), & 113 | j + 8) 114 | 115 | if (nonzero) then 116 | call append_nine_digits(digits, buffer(index:)) 117 | index = index + 9 118 | else if (digits /= 0) then 119 | olength = decimal_length9(digits) 120 | call append_n_digits(olength, digits, buffer(index:)) 121 | index = index + olength 122 | nonzero = .true. 123 | end if 124 | 125 | end do 126 | end if 127 | 128 | if (.not. nonzero) then 129 | buffer(index:index) = '0' 130 | index = index + 1 131 | end if 132 | if (precision > 0) then 133 | buffer(index:index) = '.' 134 | index = index + 1 135 | end if 136 | 137 | if (e2 < 0) then 138 | idx = -e2/16 139 | blocks = precision/9 + 1 140 | roundup = 0 141 | i = 0 142 | 143 | if (blocks <= MIN_BLOCK_2(idx + 1)) then 144 | i = blocks 145 | buffer(index:index + precision - 1) = repeat('0', precision) 146 | index = index + precision 147 | else if (i < MIN_BLOCK_2(idx + 1)) then 148 | i = MIN_BLOCK_2(idx + 1) 149 | buffer(index:index + 9*i - 1) = repeat('0', 9*i) 150 | index = index + 9*i 151 | end if 152 | 153 | do while (i < blocks) 154 | j = ADDITIONAL_BITS_2 + (-e2 - 16*idx) 155 | p = POW10_OFFSET_2(idx + 1) + i - MIN_BLOCK_2(idx + 1) 156 | 157 | if (p >= POW10_OFFSET_2(idx + 2)) then 158 | fill = precision - 9*i 159 | buffer(index:index + fill - 1) = repeat('0', fill) 160 | index = index + fill 161 | exit 162 | end if 163 | 164 | digits = mulShift_mod1e9(shiftl(m2, 8), & 165 | POW10_SPLIT_2(:, p + 1), & 166 | j + 8) 167 | 168 | if (i < blocks - 1) then 169 | call append_nine_digits(digits, buffer(index:)) 170 | index = index + 9 171 | else 172 | maximum = precision - 9*i 173 | last_digit = 0 174 | do k = 0, 8 - maximum 175 | last_digit = mod(digits, 10) 176 | digits = digits/10 177 | end do 178 | 179 | if (last_digit /= 5) then 180 | roundup = merge(1, 0, last_digit > 5) 181 | else 182 | required_twos = -e2 - precision - 1 183 | trailing_zeros = required_twos <= 0 & 184 | .or. (required_twos < 60 .and. multiple_of_power_of2(m2, required_twos)) 185 | roundup = merge(2, 1, trailing_zeros) 186 | end if 187 | if (maximum > 0) then 188 | call append_c_digits(maximum, digits, buffer(index:)) 189 | index = index + maximum 190 | end if 191 | exit 192 | end if 193 | 194 | i = i + 1 195 | end do 196 | 197 | if (roundup /= 0) then 198 | round_index = index 199 | dot_index = 1 200 | do 201 | round_index = round_index - 1 202 | if (round_index /= 0) chr = buffer(round_index:round_index) 203 | if (round_index == 0 .or. chr == '-') then 204 | buffer(round_index + 1:round_index + 1) = '1' 205 | if (dot_index > 1) then 206 | buffer(dot_index:dot_index + 1) = "0." 207 | end if 208 | buffer(index:index) = '0' 209 | index = index + 1 210 | exit 211 | end if 212 | if (chr == '.') then 213 | dot_index = round_index 214 | cycle 215 | else if (chr == '9') then 216 | buffer(round_index:round_index) = '0' 217 | roundup = 1 218 | cycle 219 | else 220 | if (roundup == 2 .and. mod(ichar(chr), 2) == 0) exit 221 | buffer(round_index:round_index) = char(ichar(chr) + 1) 222 | exit 223 | end if 224 | end do 225 | end if 226 | else 227 | buffer(index:index + precision - 1) = repeat('0', precision) 228 | index = index + precision 229 | end if 230 | 231 | index = index - 1 232 | str = buffer(:index) 233 | 234 | end function d2fixed 235 | 236 | end module real64_to_fixed -------------------------------------------------------------------------------- /src/ryu.f90: -------------------------------------------------------------------------------- 1 | module ryu 2 | use real32_to_shortest, only: f2shortest 3 | use real64_to_shortest, only: d2shortest 4 | use real64_to_fixed, only: d2fixed 5 | use real64_to_exp, only: d2exp 6 | end module ryu -------------------------------------------------------------------------------- /src/ryu_utils.f90: -------------------------------------------------------------------------------- 1 | module ryu_utils 2 | use iso_fortran_env, only: int32, int64 3 | use ryu_lookup_table, only: DIGIT_TABLE 4 | implicit none 5 | private 6 | public :: FLOAT_MANTISSA_BITS, FLOAT_MANTISSA_MASK, FLOAT_EXPONENT_BITS 7 | public :: FLOAT_EXPONENT_MASK, FLOAT_EXPONENT_BIAS 8 | public :: DOUBLE_MANTISSA_BITS, DOUBLE_MANTISSA_MASK, DOUBLE_EXPONENT_BITS 9 | public :: DOUBLE_EXPONENT_MASK, DOUBLE_EXPONENT_BIAS 10 | public :: index_for_expn, pow10_bits_for_index, length_for_index, log10Pow2 11 | public :: mulShift_mod1e9, mod1e9, decimal_length9 12 | public :: multiple_of_power_of2, pow5Factor, multiple_of_power_of5 13 | public :: append_nine_digits, append_c_digits, append_d_digits, append_n_digits 14 | public :: accept_lower_bound, accept_upper_bound 15 | 16 | integer(kind=int32), parameter :: FLOAT_MANTISSA_BITS = 23_int32 17 | integer(kind=int32), parameter :: FLOAT_MANTISSA_MASK = ishft(1, FLOAT_MANTISSA_BITS) - 1 18 | integer(kind=int32), parameter :: FLOAT_EXPONENT_BITS = 8_int32 19 | integer(kind=int32), parameter :: FLOAT_EXPONENT_MASK = ishft(1, FLOAT_EXPONENT_BITS) - 1 20 | integer(kind=int32), parameter :: FLOAT_EXPONENT_BIAS = 127_int32 21 | 22 | integer(kind=int32), parameter :: DOUBLE_MANTISSA_BITS = 52_int32 23 | integer(kind=int64), parameter :: DOUBLE_MANTISSA_MASK = shiftl(1_int64, DOUBLE_MANTISSA_BITS) - 1_int64 24 | integer(kind=int32), parameter :: DOUBLE_EXPONENT_BITS = 11_int32 25 | integer(kind=int32), parameter :: DOUBLE_EXPONENT_MASK = shiftl(1_int32, DOUBLE_EXPONENT_BITS) - 1_int32 26 | integer(kind=int32), parameter :: DOUBLE_EXPONENT_BIAS = shiftl(1_int32, DOUBLE_EXPONENT_BITS - 1_int32) - 1_int32 27 | 28 | contains 29 | 30 | pure function index_for_expn(e) result(r) 31 | integer(kind=int32), intent(in) :: e 32 | integer(kind=int32) :: r 33 | 34 | r = (e + 15)/16 35 | 36 | end function index_for_expn 37 | 38 | pure function pow10_bits_for_index(idx) result(r) 39 | integer(kind=int32), intent(in) :: idx 40 | integer(kind=int32) :: r 41 | integer(kind=int32), parameter :: POW10_ADDITIONAL_BITS = 120 42 | 43 | r = 16*idx + POW10_ADDITIONAL_BITS 44 | 45 | end function pow10_bits_for_index 46 | 47 | pure function length_for_index(idx) result(r) 48 | integer(kind=int32), intent(in) :: idx 49 | integer(kind=int32) :: r 50 | 51 | r = (log10Pow2(16*idx) + 1 + 16 + 8)/9 52 | 53 | end function length_for_index 54 | 55 | pure function log10Pow2(e) result(r) 56 | integer(kind=int32), intent(in) :: e 57 | integer(kind=int32) :: r 58 | 59 | r = shiftr(e*78913, 18) 60 | 61 | end function log10Pow2 62 | 63 | function mulShift_mod1e9(m, mul, j) result(r) 64 | integer(kind=int64), intent(in) :: m 65 | integer(kind=int64), dimension(:), intent(in) :: mul 66 | integer(kind=int32), intent(in) :: j 67 | integer(kind=int32) :: r 68 | 69 | integer(kind=int64) :: high0 70 | integer(kind=int64) :: low0 71 | integer(kind=int64) :: high1 72 | integer(kind=int64) :: low1 73 | integer(kind=int64) :: high2 74 | integer(kind=int64) :: low2 75 | !integer(kind=int64) :: s0low 76 | integer(kind=int64) :: s0high 77 | integer(kind=int32) :: c1 78 | integer(kind=int32) :: c2 79 | integer(kind=int64) :: s1low 80 | integer(kind=int64) :: s1high 81 | integer(kind=int64) :: r0 82 | integer(kind=int64) :: r1 83 | integer(kind=int64) :: r2 84 | 85 | low0 = umul128(m, mul(1), high0) 86 | low1 = umul128(m, mul(2), high1) 87 | low2 = umul128(m, mul(3), high2) 88 | s0high = low1 + high0 89 | c1 = merge(1, 0, blt(s0high, low1)) 90 | s1low = low2 + high1 + c1 91 | c2 = merge(1, 0, blt(s1low, low2)) 92 | s1high = high2 + c2 93 | 94 | if (j < 160) then 95 | r0 = mod1e9(s1high) 96 | r1 = mod1e9(ior(shiftl(r0, 32), shiftr(s1low, 32))) 97 | r2 = ior(shiftl(r1, 32), iand(s1low, 4294967295_int64)) 98 | r = mod1e9(shiftr(r2, j - 128)) 99 | else 100 | r0 = mod1e9(s1high) 101 | r1 = ior(shiftl(r0, 32), shiftr(s1low, 32)) 102 | r = mod1e9(shiftr(r1, j - 160)) 103 | end if 104 | 105 | end function mulShift_mod1e9 106 | 107 | function umul128(a, b, productHi) result(productLo) 108 | integer(kind=int64), intent(in) :: a 109 | integer(kind=int64), intent(in) :: b 110 | integer(kind=int64), intent(out) :: productHi 111 | integer(kind=int64) :: productLo 112 | 113 | integer(kind=int64) :: aLo, aHi, bLo, bHi 114 | integer(kind=int64) :: b00, b01, b10, b11 115 | integer(kind=int64) :: b00Lo, b00Hi 116 | integer(kind=int64) :: mid1 117 | integer(kind=int64) :: mid1Lo, mid1Hi 118 | integer(kind=int64) :: mid2 119 | integer(kind=int64) :: mid2Lo, mid2Hi 120 | integer(kind=int64) :: pHi, pLo 121 | 122 | aLo = iand(a, 4294967295_int64) ! 4294967295 is 0xFFFFFFFF 123 | aHi = iand(shiftr(a, 32), 4294967295_int64) 124 | bLo = iand(b, 4294967295_int64) 125 | bHi = iand(shiftr(b, 32), 4294967295_int64) 126 | 127 | b00 = aLo*bLo 128 | b01 = aLo*bHi 129 | b10 = aHi*bLo 130 | b11 = aHi*bHi 131 | 132 | b00Lo = iand(b00, 4294967295_int64) 133 | b00Hi = iand(shiftr(b00, 32), 4294967295_int64) 134 | 135 | mid1 = b10 + b00Hi 136 | mid1Lo = iand(mid1, 4294967295_int64) 137 | mid1Hi = iand(shiftr(mid1, 32), 4294967295_int64) 138 | 139 | mid2 = b01 + mid1Lo 140 | mid2Lo = iand(mid2, 4294967295_int64) 141 | mid2Hi = iand(shiftr(mid2, 32), 4294967295_int64) 142 | 143 | pHi = b11 + mid1Hi + mid2Hi 144 | pLo = ior(shiftl(mid2Lo, 32), b00Lo) 145 | 146 | productHi = pHi 147 | productLo = pLo 148 | 149 | end function umul128 150 | 151 | pure function mod1e9(x) result(r) 152 | integer(kind=int64), intent(in) :: x 153 | integer(kind=int32) :: r 154 | 155 | r = int(x - 1000000000_int64*(x/1000000000_int64), int32) 156 | 157 | end function mod1e9 158 | 159 | subroutine append_nine_digits(digits_, result) 160 | integer(kind=int32), intent(in) :: digits_ 161 | character(len=*), intent(inout) :: result 162 | 163 | integer(kind=int32) :: digits 164 | integer :: i 165 | integer(kind=int32) :: c, c0, c1 166 | 167 | digits = digits_ 168 | 169 | if (digits == 0) then 170 | result = repeat('0', 9) 171 | return 172 | end if 173 | 174 | do i = 1, 5, 4 175 | c = mod(digits, 10000) 176 | digits = digits/10000 177 | c0 = shiftl(mod(c, 100), 1) 178 | c1 = shiftl(c/100, 1) 179 | result(9 - i:9 - i + 1) = DIGIT_TABLE(c0 + 1:c0 + 2) 180 | result(7 - i:7 - i + 1) = DIGIT_TABLE(c1 + 1:c1 + 2) 181 | end do 182 | 183 | result(1:1) = char(48 + digits) 184 | 185 | end subroutine append_nine_digits 186 | 187 | subroutine append_c_digits(count, digits_, result) 188 | integer(kind=int32), intent(in) :: count 189 | integer(kind=int32), intent(in) :: digits_ 190 | character(len=*), intent(inout) :: result 191 | 192 | integer(kind=int32) :: digits 193 | integer(kind=int32) :: i 194 | integer(kind=int32) :: c 195 | 196 | digits = digits_ 197 | do i = 0, count - 2, 2 198 | c = shiftl(mod(digits, 100), 1) 199 | digits = digits/100 200 | result(count - i - 1:count - i) = DIGIT_TABLE(c + 1:c + 2) 201 | end do 202 | if (i < count) result(count - i:count - i) = char(48 + mod(digits, 10)) 203 | 204 | end subroutine append_c_digits 205 | 206 | subroutine append_d_digits(olength, digits_, result) 207 | integer(kind=int32), intent(in) :: olength 208 | integer(kind=int32), intent(in) :: digits_ 209 | character(len=*), intent(inout) :: result 210 | 211 | integer(kind=int32) :: digits 212 | integer(kind=int32) :: i 213 | integer(kind=int32) :: c, c0, c1 214 | 215 | i = 0 216 | digits = digits_ 217 | do while (digits >= 10000) 218 | c = mod(digits, 10000) 219 | digits = digits/10000 220 | c0 = shiftl(mod(c, 100), 1) 221 | c1 = shiftl(c/100, 1) 222 | result(olength - i:olength - i + 1) = DIGIT_TABLE(c0 + 1:c0 + 2) 223 | result(olength - i - 2:olength - i - 1) = DIGIT_TABLE(c1 + 1:c1 + 2) 224 | i = i + 4 225 | end do 226 | if (digits >= 100) then 227 | c = shiftl(mod(digits, 100), 1) 228 | digits = digits/100 229 | result(olength - i:olength - i + 1) = DIGIT_TABLE(c + 1:c + 2) 230 | end if 231 | if (digits >= 10) then 232 | c = shiftl(digits, 1) 233 | result(3:3) = DIGIT_TABLE(c + 2:c + 2) 234 | result(2:2) = '.' 235 | result(1:1) = DIGIT_TABLE(c + 1:c + 1) 236 | else 237 | result(2:2) = '.' 238 | result(1:1) = char(48 + digits) 239 | end if 240 | 241 | end subroutine append_d_digits 242 | 243 | subroutine append_n_digits(olength, digits_, result) 244 | integer(kind=int32), intent(in) :: olength 245 | integer(kind=int32), intent(in) :: digits_ 246 | character(len=*), intent(inout) :: result 247 | 248 | integer(kind=int32) :: digits 249 | integer(kind=int32) :: i 250 | integer(kind=int32) :: c, c0, c1 251 | 252 | i = 0 253 | digits = digits_ 254 | do while (digits >= 10000) 255 | c = mod(digits, 10000) 256 | digits = digits/10000 257 | c0 = shiftl(mod(c, 100), 1) 258 | c1 = shiftl(c/100, 1) 259 | result(olength - i - 1:olength - i) = DIGIT_TABLE(c0 + 1:c0 + 2) 260 | result(olength - i - 3:olength - i - 2) = DIGIT_TABLE(c1 + 1:c1 + 2) 261 | i = i + 4 262 | end do 263 | if (digits >= 100) then 264 | c = shiftl(mod(digits, 100), 1) 265 | digits = digits/100 266 | result(olength - i - 1:olength - i) = DIGIT_TABLE(c + 1:c + 2) 267 | i = i + 2 268 | end if 269 | if (digits >= 10) then 270 | c = shiftl(digits, 1) 271 | result(olength - i - 1:olength - i) = DIGIT_TABLE(c + 1:c + 2) 272 | else 273 | result(1:1) = char(48 + digits) 274 | end if 275 | 276 | end subroutine append_n_digits 277 | 278 | pure function decimal_length9(v) result(r) 279 | integer(kind=int32), intent(in) :: v 280 | integer(kind=int32) :: r 281 | 282 | if (v >= 100000000) then 283 | r = 9; return 284 | else if (v >= 10000000) then 285 | r = 8; return 286 | else if (v >= 1000000) then 287 | r = 7; return 288 | else if (v >= 100000) then 289 | r = 6; return 290 | else if (v >= 10000) then 291 | r = 5; return 292 | else if (v >= 1000) then 293 | r = 4; return 294 | else if (v >= 100) then 295 | r = 3; return 296 | else if (v >= 10) then 297 | r = 2; return 298 | else 299 | r = 1; return 300 | end if 301 | 302 | end function decimal_length9 303 | 304 | pure function multiple_of_power_of2(value, p) result(r) 305 | integer(kind=int64), intent(in) :: value 306 | integer(kind=int32), intent(in) :: p 307 | logical(kind=int32) :: r 308 | 309 | r = iand(value, shiftl(1_int64, p) - 1) == 0 310 | 311 | end function multiple_of_power_of2 312 | 313 | pure function pow5Factor(v) result(count) 314 | integer(kind=int64), intent(in) :: v 315 | integer(kind=int32) :: count 316 | integer(kind=int64) :: v_ 317 | 318 | v_ = v 319 | if (mod(v_, 5) /= 0) then 320 | count = 0; return 321 | end if 322 | if (mod(v_, 25) /= 0) then 323 | count = 1; return 324 | end if 325 | if (mod(v_, 125) /= 0) then 326 | count = 2; return 327 | end if 328 | if (mod(v_, 625) /= 0) then 329 | count = 3; return 330 | end if 331 | 332 | count = 4 333 | v_ = v_/625 334 | 335 | do while (v_ > 0) 336 | if (mod(v_, 5) /= 0) return 337 | v_ = v_/5 338 | count = count + 1 339 | end do 340 | 341 | error stop "Illegal Argument" 342 | 343 | end function pow5Factor 344 | 345 | pure function multiple_of_power_of5(value, p) result(r) 346 | integer(kind=int64), intent(in) :: value 347 | integer(kind=int32), intent(in) :: p 348 | logical(kind=int32) :: r 349 | 350 | r = pow5Factor(value) >= p 351 | 352 | end function multiple_of_power_of5 353 | 354 | !! now we always round to even 355 | pure function accept_upper_bound(even) result(r) 356 | logical(kind=int32), intent(in) :: even 357 | logical(kind=int32) :: r 358 | 359 | r = even 360 | 361 | end function accept_upper_bound 362 | 363 | pure function accept_lower_bound(even) result(r) 364 | logical(kind=int32), intent(in) :: even 365 | logical(kind=int32) :: r 366 | 367 | r = even 368 | 369 | end function accept_lower_bound 370 | 371 | 372 | end module ryu_utils 373 | -------------------------------------------------------------------------------- /test/benchmark/bench_option.txt: -------------------------------------------------------------------------------- 1 | 2000 ! num_sample 2 | 20000 ! num_iter 3 | 10 ! precision -------------------------------------------------------------------------------- /test/benchmark/benchmark.f90: -------------------------------------------------------------------------------- 1 | module benchmark 2 | use ryu 3 | use random 4 | use iso_fortran_env, only: int32, int64, real32, real64 5 | implicit none 6 | 7 | contains 8 | 9 | subroutine bench_f2shortest(num_samples, num_iter) 10 | integer, intent(in) :: num_samples 11 | integer, intent(in) :: num_iter 12 | character(len=1000) :: buffer 13 | real(kind=real32) :: f 14 | integer(kind=int32) :: fi 15 | real(kind=real64) :: t1, t2 16 | real(kind=real64), dimension(:), allocatable :: delta1 17 | real(kind=real64), dimension(:), allocatable :: delta2 18 | real(kind=real64) :: mean1, mean2 19 | real(kind=real64) :: sigma1, sigma2 20 | integer :: i, j 21 | 22 | write (*, "('Benchmark for f2shortest')") 23 | 24 | allocate (delta1(num_samples)) 25 | allocate (delta2(num_samples)) 26 | 27 | do i = 1, num_samples 28 | fi = random_int32() 29 | f = transfer(fi, 1._real32) 30 | 31 | call cpu_time(t1) 32 | do j = 1, num_iter 33 | buffer = f2shortest(f) 34 | end do 35 | call cpu_time(t2) 36 | delta1(i) = (t2 - t1)*1000000/num_iter ! convert to us 37 | 38 | call cpu_time(t1) 39 | do j = 1, num_iter 40 | write (buffer, "(g0)") f 41 | end do 42 | call cpu_time(t2) 43 | delta2(i) = (t2 - t1)*1000000/num_iter ! convert to us 44 | end do 45 | 46 | mean1 = sum(delta1)/num_samples 47 | mean2 = sum(delta2)/num_samples 48 | sigma1 = sqrt(sum((delta1-mean1)**2)/num_samples) 49 | sigma2 = sqrt(sum((delta2-mean2)**2)/num_samples) 50 | 51 | write (*, "('f2shortest Time (us): ',F9.7,' Std Dev: ',F7.4)") mean1, sigma1 52 | write (*, "('internal IO Time (us): ',F9.7,' Std Dev: ',F7.4)") mean2, sigma2 53 | 54 | end subroutine bench_f2shortest 55 | 56 | subroutine bench_d2shortest(num_samples, num_iter) 57 | integer, intent(in) :: num_samples 58 | integer, intent(in) :: num_iter 59 | character(len=1000) :: buffer 60 | real(kind=real64) :: f 61 | integer(kind=int64) :: fi 62 | real(kind=real64) :: t1, t2 63 | real(kind=real64), dimension(:), allocatable :: delta1 64 | real(kind=real64), dimension(:), allocatable :: delta2 65 | real(kind=real64) :: mean1, mean2 66 | real(kind=real64) :: sigma1, sigma2 67 | integer :: i, j 68 | 69 | write (*, "('Benchmark for d2shortest')") 70 | 71 | allocate (delta1(num_samples)) 72 | allocate (delta2(num_samples)) 73 | 74 | do i = 1, num_samples 75 | fi = random_int64() 76 | f = transfer(fi, 1._real64) 77 | 78 | call cpu_time(t1) 79 | do j = 1, num_iter 80 | buffer = d2shortest(f) 81 | end do 82 | call cpu_time(t2) 83 | delta1(i) = (t2 - t1)*1000000/num_iter ! convert to us 84 | 85 | call cpu_time(t1) 86 | do j = 1, num_iter 87 | write (buffer, "(g0)") f 88 | end do 89 | call cpu_time(t2) 90 | delta2(i) = (t2 - t1)*1000000/num_iter ! convert to us 91 | end do 92 | 93 | mean1 = sum(delta1)/num_samples 94 | mean2 = sum(delta2)/num_samples 95 | sigma1 = sqrt(sum((delta1-mean1)**2)/num_samples) 96 | sigma2 = sqrt(sum((delta2-mean2)**2)/num_samples) 97 | 98 | write (*, "('d2shortest Time (us): ',F9.7,' Std Dev: ',F7.4)") mean1, sigma1 99 | write (*, "('internal IO Time (us): ',F9.7,' Std Dev: ',F7.4)") mean2, sigma2 100 | 101 | end subroutine bench_d2shortest 102 | 103 | subroutine bench_d2exp(num_samples, num_iter, precision) 104 | integer, intent(in) :: num_samples 105 | integer, intent(in) :: num_iter 106 | integer, intent(in) :: precision 107 | character(len=1000) :: buffer 108 | real(kind=real64) :: f 109 | integer(kind=int64) :: fi 110 | real(kind=real64) :: t1, t2 111 | real(kind=real64), dimension(:), allocatable :: delta1 112 | real(kind=real64), dimension(:), allocatable :: delta2 113 | real(kind=real64) :: mean1, mean2 114 | real(kind=real64) :: sigma1, sigma2 115 | integer :: i, j 116 | 117 | write (*, "('Benchmark for d2exp')") 118 | 119 | allocate (delta1(num_samples)) 120 | allocate (delta2(num_samples)) 121 | 122 | do i = 1, num_samples 123 | fi = random_int64() 124 | f = transfer(fi, 1._real64) 125 | 126 | call cpu_time(t1) 127 | do j = 1, num_iter 128 | buffer = d2exp(f, precision) 129 | end do 130 | call cpu_time(t2) 131 | delta1(i) = (t2 - t1)*1000000/num_iter ! convert to us 132 | 133 | call cpu_time(t1) 134 | do j = 1, num_iter 135 | write (buffer, "(ES20.10)") f 136 | end do 137 | call cpu_time(t2) 138 | delta2(i) = (t2 - t1)*1000000/num_iter ! convert to us 139 | end do 140 | 141 | mean1 = sum(delta1)/num_samples 142 | mean2 = sum(delta2)/num_samples 143 | sigma1 = sqrt(sum((delta1-mean1)**2)/num_samples) 144 | sigma2 = sqrt(sum((delta2-mean2)**2)/num_samples) 145 | 146 | write (*, "('d2exp Time (us): ',F9.7,' Std Dev: ',F7.4)") mean1, sigma1 147 | write (*, "('internal IO Time (us): ',F9.7,' Std Dev: ',F7.4)") mean2, sigma2 148 | 149 | end subroutine bench_d2exp 150 | 151 | subroutine bench_d2fixed(num_samples, num_iter, precision) 152 | integer, intent(in) :: num_samples 153 | integer, intent(in) :: num_iter 154 | integer, intent(in) :: precision 155 | character(len=1000) :: buffer 156 | real(kind=real64) :: f 157 | integer(kind=int64) :: fi 158 | real(kind=real64) :: t1, t2 159 | real(kind=real64), dimension(:), allocatable :: delta1 160 | real(kind=real64), dimension(:), allocatable :: delta2 161 | real(kind=real64) :: mean1, mean2 162 | real(kind=real64) :: sigma1, sigma2 163 | integer :: i, j 164 | 165 | write (*, "('Benchmark for d2fixed')") 166 | 167 | allocate (delta1(num_samples)) 168 | allocate (delta2(num_samples)) 169 | 170 | do i = 1, num_samples 171 | fi = random_int64() 172 | f = transfer(fi, 1._real64) 173 | 174 | call cpu_time(t1) 175 | do j = 1, num_iter 176 | buffer = d2fixed(f, precision) 177 | end do 178 | call cpu_time(t2) 179 | delta1(i) = (t2 - t1)*1000000/num_iter ! convert to us 180 | 181 | call cpu_time(t1) 182 | do j = 1, num_iter 183 | write (buffer, "(F1000.10)") f 184 | end do 185 | call cpu_time(t2) 186 | delta2(i) = (t2 - t1)*1000000/num_iter ! convert to us 187 | end do 188 | 189 | mean1 = sum(delta1)/num_samples 190 | mean2 = sum(delta2)/num_samples 191 | sigma1 = sqrt(sum((delta1-mean1)**2)/num_samples) 192 | sigma2 = sqrt(sum((delta2-mean2)**2)/num_samples) 193 | 194 | write (*, "('d2fixed Time (us): ',F9.7,' Std Dev: ',F7.4)") mean1, sigma1 195 | write (*, "('internal IO Time (us): ',F9.7,' Std Dev: ',F7.4)") mean2, sigma2 196 | 197 | end subroutine bench_d2fixed 198 | 199 | end module benchmark 200 | 201 | program main 202 | use benchmark 203 | use random 204 | implicit none 205 | integer :: num_sample 206 | integer :: num_iter 207 | integer :: precision 208 | integer :: u 209 | 210 | ! prevent from compiler optimization 211 | open (newunit=u, file="./test/benchmark/bench_option.txt", action="read") 212 | read (u, *) num_sample 213 | read (u, *) num_iter 214 | read (u, *) precision 215 | close (u) 216 | 217 | call random_init(12345) 218 | 219 | call bench_f2shortest(num_sample, num_iter) 220 | call bench_d2shortest(num_sample, num_iter) 221 | call bench_d2exp(num_sample, num_iter, precision) 222 | call bench_d2fixed(num_sample, num_iter, precision) 223 | 224 | end program main 225 | -------------------------------------------------------------------------------- /test/benchmark/random.f90: -------------------------------------------------------------------------------- 1 | module random 2 | use iso_fortran_env, only: int32, int64 3 | implicit none 4 | private 5 | public :: random_init, random_int32, random_int64 6 | 7 | integer(kind=int32), parameter :: N = 624_int32 8 | integer(kind=int32), parameter :: M = 397_int32 9 | integer(kind=int32), parameter :: R = 31_int32 10 | integer(kind=int32), parameter :: A = -1727483681_int32 ! 0x9908B0DF 11 | integer(kind=int32), parameter :: F = 1812433253_int32 12 | integer(kind=int32), parameter :: U = 11_int32 13 | integer(kind=int32), parameter :: S = 7_int32 14 | integer(kind=int32), parameter :: B = -1658038656_int32 ! 0x9D2C5680 15 | integer(kind=int32), parameter :: T = 15_int32 16 | integer(kind=int32), parameter :: C = -272236544_int32 ! 0xEFC60000 17 | integer(kind=int32), parameter :: L = 18_int32 18 | integer(kind=int32), parameter :: MASK_LOWER = huge(1_int32) 19 | integer(kind=int32), parameter :: MASK_UPPER = -huge(1_int32)-1 20 | 21 | integer(kind=int32), dimension(0:N - 1) :: mt 22 | integer(kind=int32) :: index 23 | 24 | contains 25 | 26 | subroutine random_init(seed) 27 | integer(kind=int32), intent(in) :: seed 28 | integer(kind=int32) :: i 29 | 30 | mt(0) = seed 31 | do i = 1, N - 1 32 | mt(i) = F*ieor(mt(i - 1), shiftr(mt(i - 1), 30)) + i 33 | end do 34 | index = N 35 | 36 | end subroutine random_init 37 | 38 | subroutine twist() 39 | integer(kind=int32) :: i, x, xA 40 | 41 | do i = 0, N - 1 42 | x = iand(mt(i), MASK_UPPER) + iand(mt(mod(i + 1, N)), MASK_LOWER) 43 | xA = shiftr(x, 1) 44 | if (iand(x, 1_int32) /= 0) xA = ieor(xA, A) 45 | mt(i) = ieor(mt(mod(i + M, N)), xA) 46 | end do 47 | 48 | index = 0 49 | 50 | end subroutine twist 51 | 52 | function random_int32() result(y) 53 | integer(kind=int32) :: y 54 | integer(kind=int32) :: i 55 | 56 | i = index 57 | if (index >= N) then 58 | call twist() 59 | i = index 60 | end if 61 | 62 | y = mt(i) 63 | index = i + 1 64 | 65 | y = ieor(y, shiftr(mt(i), U)) 66 | y = ieor(y, iand(shiftl(y, S), B)) 67 | y = ieor(y, iand(shiftl(y, T), C)) 68 | y = ieor(y, shiftr(y, L)) 69 | 70 | end function random_int32 71 | 72 | function random_int64() result(y) 73 | integer(kind=int64) :: y 74 | integer(kind=int64) :: high, low 75 | 76 | high = transfer([0_int32, random_int32()], 1_int64) 77 | low = transfer([random_int32(), 0_int32], 1_int64) 78 | y = ior(high, low) 79 | 80 | end function random_int64 81 | 82 | end module random 83 | -------------------------------------------------------------------------------- /test/test_d2exp/test_d2exp.f90: -------------------------------------------------------------------------------- 1 | module test_d2exp 2 | use testdrive, only: new_unittest, unittest_type, error_type, check 3 | use real64_to_exp 4 | use iso_fortran_env, only: int32, int64, real64 5 | implicit none 6 | private 7 | public :: collect_basic, collect_zeros, collect_max_and_min, collect_round_to_even 8 | public :: collect_round_to_even_integer, collect_non_round_to_even_scenarios 9 | public :: collect_varying_precision, collect_carrying, collect_exponents 10 | public :: collect_print_decimal_point 11 | 12 | real(kind=real64), parameter :: NaN = transfer(int(z'7FF0000000000001', int64), 1._real64) 13 | real(kind=real64), parameter :: plus_infinity = transfer(int(z'7FF0000000000000', int64), 1._real64) 14 | real(kind=real64), parameter :: minus_infinity = transfer(int(z'FFF0000000000000', int64), 1._real64) 15 | integer(kind=int64), parameter :: max_mantissa = shiftl(1_int64, 53) - 1 16 | 17 | contains 18 | 19 | function ieee_part_to_real64(sign, ieee_exponent, ieee_mantissa) result(d) 20 | logical(kind=int32), intent(in) :: sign 21 | integer(kind=int32), intent(in) :: ieee_exponent 22 | integer(kind=int64), intent(in) :: ieee_mantissa 23 | real(kind=real64) :: d 24 | integer(kind=int64) :: i 25 | 26 | if (sign) then 27 | i = ior(shiftl(1_int64, 63), ior(shiftl(int(ieee_exponent, int64), 52), ieee_mantissa)) 28 | else 29 | i = ior(shiftl(0_int64, 63), ior(shiftl(int(ieee_exponent, int64), 52), ieee_mantissa)) 30 | end if 31 | 32 | d = transfer(i, 1._real64) 33 | 34 | end function ieee_part_to_real64 35 | 36 | !> ============================================================================= 37 | 38 | subroutine collect_basic(testsuite) 39 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 40 | 41 | testsuite = [ & 42 | new_unittest("value1", test_basic_value1) & 43 | ] 44 | 45 | end subroutine collect_basic 46 | 47 | subroutine test_basic_value1(error) 48 | type(error_type), allocatable, intent(out) :: error 49 | 50 | call check(error, d2exp(ieee_part_to_real64(.false., 1234, 99999_int64), 62), & 51 | "3.29100911471548643542566484557342614975886952410844652587974656E+63") 52 | if (allocated(error)) return 53 | 54 | end subroutine test_basic_value1 55 | 56 | !> ============================================================================= 57 | 58 | subroutine collect_zeros(testsuite) 59 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 60 | 61 | testsuite = [ & 62 | new_unittest("value1", test_zeros_value1), & 63 | new_unittest("value2", test_zeros_value2), & 64 | new_unittest("value3", test_zeros_value3), & 65 | new_unittest("value4", test_zeros_value4), & 66 | new_unittest("value5", test_zeros_value5) & 67 | ] 68 | 69 | end subroutine collect_zeros 70 | 71 | subroutine test_zeros_value1(error) 72 | type(error_type), allocatable, intent(out) :: error 73 | 74 | call check(error, d2exp(0.0_real64, 4), "0.0000E+00") 75 | if (allocated(error)) return 76 | 77 | end subroutine test_zeros_value1 78 | 79 | subroutine test_zeros_value2(error) 80 | type(error_type), allocatable, intent(out) :: error 81 | 82 | call check(error, d2exp(0.0_real64, 3), "0.000E+00") 83 | if (allocated(error)) return 84 | 85 | end subroutine test_zeros_value2 86 | 87 | subroutine test_zeros_value3(error) 88 | type(error_type), allocatable, intent(out) :: error 89 | 90 | call check(error, d2exp(0.0_real64, 2), "0.00E+00") 91 | if (allocated(error)) return 92 | 93 | end subroutine test_zeros_value3 94 | 95 | subroutine test_zeros_value4(error) 96 | type(error_type), allocatable, intent(out) :: error 97 | 98 | call check(error, d2exp(0.0_real64, 1), "0.0E+00") 99 | if (allocated(error)) return 100 | 101 | end subroutine test_zeros_value4 102 | 103 | subroutine test_zeros_value5(error) 104 | type(error_type), allocatable, intent(out) :: error 105 | 106 | call check(error, d2exp(0.0_real64, 0), "0E+00") 107 | if (allocated(error)) return 108 | 109 | end subroutine test_zeros_value5 110 | 111 | !> ============================================================================= 112 | 113 | subroutine collect_max_and_min(testsuite) 114 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 115 | 116 | testsuite = [ & 117 | new_unittest("max", test_max), & 118 | new_unittest("min", test_min) & 119 | ] 120 | 121 | end subroutine collect_max_and_min 122 | 123 | subroutine test_max(error) 124 | type(error_type), allocatable, intent(out) :: error 125 | real(kind=real64), parameter :: max = transfer(int(z'7fefffffffffffff', int64), 1._real64) 126 | 127 | call check(error, d2exp(max, 308), & 128 | "1.7976931348623157081452742373170435679807056752584499659891747680315726078002853876058955"// & 129 | "863276687817154045895351438246423432132688946418276846754670353751698604991057655128207624"// & 130 | "549009038932894407586850845513394230458323690322294816580855933212334827479782620414472316"// & 131 | "8738177180919299881250404026184124858368E+308") 132 | if (allocated(error)) return 133 | 134 | end subroutine test_max 135 | 136 | subroutine test_min(error) 137 | type(error_type), allocatable, intent(out) :: error 138 | real(kind=real64), parameter :: min = transfer(1_int64, 1._real64) 139 | 140 | call check(error, d2exp(min, 750), & 141 | "4.9406564584124654417656879286822137236505980261432476442558568250067550727020875186529983"// & 142 | "636163599237979656469544571773092665671035593979639877479601078187812630071319031140452784"// & 143 | "581716784898210368871863605699873072305000638740915356498438731247339727316961514003171538"// & 144 | "539807412623856559117102665855668676818703956031062493194527159149245532930545654440112748"// & 145 | "012970999954193198940908041656332452475714786901472678015935523861155013480352649347201937"// & 146 | "902681071074917033322268447533357208324319360923828934583680601060115061698097530783422773"// & 147 | "183292479049825247307763759272478746560847782037344696995336470179726777175851256605511991"// & 148 | "315048911014510378627381672509558373897335989936648099411642057026370902792427675445652290"// & 149 | "87538682506419718265533447265625E-324") 150 | if (allocated(error)) return 151 | 152 | end subroutine test_min 153 | 154 | !> ============================================================================= 155 | 156 | subroutine collect_round_to_even(testsuite) 157 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 158 | 159 | testsuite = [ & 160 | new_unittest("value1", test_round_to_even_value1), & 161 | new_unittest("value2", test_round_to_even_value2), & 162 | new_unittest("value3", test_round_to_even_value3), & 163 | new_unittest("value4", test_round_to_even_value4) & 164 | ] 165 | 166 | end subroutine collect_round_to_even 167 | 168 | subroutine test_round_to_even_value1(error) 169 | type(error_type), allocatable, intent(out) :: error 170 | 171 | call check(error, d2exp(0.125_real64, 2), "1.25E-01") 172 | if (allocated(error)) return 173 | 174 | end subroutine test_round_to_even_value1 175 | 176 | subroutine test_round_to_even_value2(error) 177 | type(error_type), allocatable, intent(out) :: error 178 | 179 | call check(error, d2exp(0.125_real64, 1), "1.2E-01") 180 | if (allocated(error)) return 181 | 182 | end subroutine test_round_to_even_value2 183 | 184 | subroutine test_round_to_even_value3(error) 185 | type(error_type), allocatable, intent(out) :: error 186 | 187 | call check(error, d2exp(0.375_real64, 2), "3.75E-01") 188 | if (allocated(error)) return 189 | 190 | end subroutine test_round_to_even_value3 191 | 192 | subroutine test_round_to_even_value4(error) 193 | type(error_type), allocatable, intent(out) :: error 194 | 195 | call check(error, d2exp(0.375_real64, 1), "3.8E-01") 196 | if (allocated(error)) return 197 | 198 | end subroutine test_round_to_even_value4 199 | 200 | !> ============================================================================= 201 | 202 | subroutine collect_round_to_even_integer(testsuite) 203 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 204 | 205 | testsuite = [ & 206 | new_unittest("value1", test_round_to_even_integer_value1), & 207 | new_unittest("value2", test_round_to_even_integer_value2), & 208 | new_unittest("value3", test_round_to_even_integer_value3), & 209 | new_unittest("value4", test_round_to_even_integer_value4) & 210 | ] 211 | 212 | end subroutine collect_round_to_even_integer 213 | 214 | subroutine test_round_to_even_integer_value1(error) 215 | type(error_type), allocatable, intent(out) :: error 216 | 217 | call check(error, d2exp(2.5_real64, 1), "2.5E+00") 218 | if (allocated(error)) return 219 | 220 | end subroutine test_round_to_even_integer_value1 221 | 222 | subroutine test_round_to_even_integer_value2(error) 223 | type(error_type), allocatable, intent(out) :: error 224 | 225 | call check(error, d2exp(2.5_real64, 0), "2E+00") 226 | if (allocated(error)) return 227 | 228 | end subroutine test_round_to_even_integer_value2 229 | 230 | subroutine test_round_to_even_integer_value3(error) 231 | type(error_type), allocatable, intent(out) :: error 232 | 233 | call check(error, d2exp(3.5_real64, 1), "3.5E+00") 234 | if (allocated(error)) return 235 | 236 | end subroutine test_round_to_even_integer_value3 237 | 238 | subroutine test_round_to_even_integer_value4(error) 239 | type(error_type), allocatable, intent(out) :: error 240 | 241 | call check(error, d2exp(3.5_real64, 0), "4E+00") 242 | if (allocated(error)) return 243 | 244 | end subroutine test_round_to_even_integer_value4 245 | 246 | !> ============================================================================= 247 | 248 | subroutine collect_non_round_to_even_scenarios(testsuite) 249 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 250 | 251 | testsuite = [ & 252 | new_unittest("value1", test_non_round_to_even_scenarios_value1), & 253 | new_unittest("value2", test_non_round_to_even_scenarios_value2), & 254 | new_unittest("value3", test_non_round_to_even_scenarios_value3), & 255 | new_unittest("value4", test_non_round_to_even_scenarios_value4), & 256 | new_unittest("value5", test_non_round_to_even_scenarios_value5), & 257 | new_unittest("value6", test_non_round_to_even_scenarios_value6), & 258 | new_unittest("value7", test_non_round_to_even_scenarios_value7), & 259 | new_unittest("value8", test_non_round_to_even_scenarios_value8), & 260 | new_unittest("value9", test_non_round_to_even_scenarios_value9), & 261 | new_unittest("value10", test_non_round_to_even_scenarios_value10) & 262 | ] 263 | 264 | end subroutine collect_non_round_to_even_scenarios 265 | 266 | subroutine test_non_round_to_even_scenarios_value1(error) 267 | type(error_type), allocatable, intent(out) :: error 268 | 269 | call check(error, d2exp(0.748046875_real64, 2), "7.48E-01") 270 | if (allocated(error)) return 271 | 272 | end subroutine test_non_round_to_even_scenarios_value1 273 | 274 | subroutine test_non_round_to_even_scenarios_value2(error) 275 | type(error_type), allocatable, intent(out) :: error 276 | 277 | call check(error, d2exp(0.748046875_real64, 1), "7.5E-01") 278 | if (allocated(error)) return 279 | 280 | end subroutine test_non_round_to_even_scenarios_value2 281 | 282 | subroutine test_non_round_to_even_scenarios_value3(error) 283 | type(error_type), allocatable, intent(out) :: error 284 | 285 | call check(error, d2exp(0.748046875_real64, 0), "7E-01") 286 | if (allocated(error)) return 287 | 288 | end subroutine test_non_round_to_even_scenarios_value3 289 | 290 | subroutine test_non_round_to_even_scenarios_value4(error) 291 | type(error_type), allocatable, intent(out) :: error 292 | 293 | call check(error, d2exp(0.2509765625_real64, 2), "2.51E-01") 294 | if (allocated(error)) return 295 | 296 | end subroutine test_non_round_to_even_scenarios_value4 297 | 298 | subroutine test_non_round_to_even_scenarios_value5(error) 299 | type(error_type), allocatable, intent(out) :: error 300 | 301 | call check(error, d2exp(0.2509765625_real64, 1), "2.5E-01") 302 | if (allocated(error)) return 303 | 304 | end subroutine test_non_round_to_even_scenarios_value5 305 | 306 | subroutine test_non_round_to_even_scenarios_value6(error) 307 | type(error_type), allocatable, intent(out) :: error 308 | 309 | call check(error, d2exp(0.2509765625_real64, 0), "3E-01") 310 | if (allocated(error)) return 311 | 312 | end subroutine test_non_round_to_even_scenarios_value6 313 | 314 | subroutine test_non_round_to_even_scenarios_value7(error) 315 | type(error_type), allocatable, intent(out) :: error 316 | 317 | call check(error, d2exp(ieee_part_to_real64(.false., 1021, 1_int64), 53), & 318 | "2.50000000000000055511151231257827021181583404541015625E-01") 319 | if (allocated(error)) return 320 | 321 | end subroutine test_non_round_to_even_scenarios_value7 322 | 323 | subroutine test_non_round_to_even_scenarios_value8(error) 324 | type(error_type), allocatable, intent(out) :: error 325 | 326 | call check(error, d2exp(ieee_part_to_real64(.false., 1021, 1_int64), 2), "2.50E-01") 327 | if (allocated(error)) return 328 | 329 | end subroutine test_non_round_to_even_scenarios_value8 330 | 331 | subroutine test_non_round_to_even_scenarios_value9(error) 332 | type(error_type), allocatable, intent(out) :: error 333 | 334 | call check(error, d2exp(ieee_part_to_real64(.false., 1021, 1_int64), 1), "2.5E-01") 335 | if (allocated(error)) return 336 | 337 | end subroutine test_non_round_to_even_scenarios_value9 338 | 339 | subroutine test_non_round_to_even_scenarios_value10(error) 340 | type(error_type), allocatable, intent(out) :: error 341 | 342 | call check(error, d2exp(ieee_part_to_real64(.false., 1021, 1_int64), 0), "3E-01") 343 | if (allocated(error)) return 344 | 345 | end subroutine test_non_round_to_even_scenarios_value10 346 | 347 | !> ============================================================================= 348 | 349 | subroutine collect_varying_precision(testsuite) 350 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 351 | 352 | testsuite = [ & 353 | new_unittest("value1", test_varying_precision_value1), & 354 | new_unittest("value2", test_varying_precision_value2), & 355 | new_unittest("value3", test_varying_precision_value3), & 356 | new_unittest("value4", test_varying_precision_value4), & 357 | new_unittest("value5", test_varying_precision_value5), & 358 | new_unittest("value6", test_varying_precision_value6), & 359 | new_unittest("value7", test_varying_precision_value7), & 360 | new_unittest("value8", test_varying_precision_value8), & 361 | new_unittest("value9", test_varying_precision_value9), & 362 | new_unittest("value10", test_varying_precision_value10), & 363 | new_unittest("value11", test_varying_precision_value11), & 364 | new_unittest("value12", test_varying_precision_value12), & 365 | new_unittest("value13", test_varying_precision_value13), & 366 | new_unittest("value14", test_varying_precision_value14), & 367 | new_unittest("value15", test_varying_precision_value15), & 368 | new_unittest("value16", test_varying_precision_value16), & 369 | new_unittest("value17", test_varying_precision_value17), & 370 | new_unittest("value18", test_varying_precision_value18), & 371 | new_unittest("value19", test_varying_precision_value19), & 372 | new_unittest("value20", test_varying_precision_value20), & 373 | new_unittest("value21", test_varying_precision_value21), & 374 | new_unittest("value22", test_varying_precision_value22), & 375 | new_unittest("value23", test_varying_precision_value23), & 376 | new_unittest("value24", test_varying_precision_value24), & 377 | new_unittest("value25", test_varying_precision_value25), & 378 | new_unittest("value26", test_varying_precision_value26), & 379 | new_unittest("value27", test_varying_precision_value27), & 380 | new_unittest("value28", test_varying_precision_value28), & 381 | new_unittest("value29", test_varying_precision_value29), & 382 | new_unittest("value30", test_varying_precision_value30), & 383 | new_unittest("value31", test_varying_precision_value31), & 384 | new_unittest("value32", test_varying_precision_value32), & 385 | new_unittest("value33", test_varying_precision_value33), & 386 | new_unittest("value34", test_varying_precision_value34), & 387 | new_unittest("value35", test_varying_precision_value35), & 388 | new_unittest("value36", test_varying_precision_value36), & 389 | new_unittest("value37", test_varying_precision_value37), & 390 | new_unittest("value38", test_varying_precision_value38), & 391 | new_unittest("value39", test_varying_precision_value39), & 392 | new_unittest("value40", test_varying_precision_value40), & 393 | new_unittest("value41", test_varying_precision_value41), & 394 | new_unittest("value42", test_varying_precision_value42), & 395 | new_unittest("value43", test_varying_precision_value43), & 396 | new_unittest("value44", test_varying_precision_value44), & 397 | new_unittest("value45", test_varying_precision_value45), & 398 | new_unittest("value46", test_varying_precision_value46), & 399 | new_unittest("value47", test_varying_precision_value47), & 400 | new_unittest("value48", test_varying_precision_value48), & 401 | new_unittest("value49", test_varying_precision_value49), & 402 | new_unittest("value50", test_varying_precision_value50), & 403 | new_unittest("value51", test_varying_precision_value51) & 404 | ] 405 | 406 | end subroutine collect_varying_precision 407 | 408 | subroutine test_varying_precision_value1(error) 409 | type(error_type), allocatable, intent(out) :: error 410 | call check(error, d2exp(1729.142857142857_real64, 50), & 411 | "1.72914285714285711037518922239542007446289062500000E+03") 412 | if (allocated(error)) return 413 | end subroutine test_varying_precision_value1 414 | 415 | subroutine test_varying_precision_value2(error) 416 | type(error_type), allocatable, intent(out) :: error 417 | call check(error, d2exp(1729.142857142857_real64, 49), & 418 | "1.7291428571428571103751892223954200744628906250000E+03") 419 | if (allocated(error)) return 420 | end subroutine test_varying_precision_value2 421 | 422 | subroutine test_varying_precision_value3(error) 423 | type(error_type), allocatable, intent(out) :: error 424 | call check(error, d2exp(1729.142857142857_real64, 48), & 425 | "1.729142857142857110375189222395420074462890625000E+03") 426 | if (allocated(error)) return 427 | end subroutine test_varying_precision_value3 428 | 429 | subroutine test_varying_precision_value4(error) 430 | type(error_type), allocatable, intent(out) :: error 431 | call check(error, d2exp(1729.142857142857_real64, 47), "1.72914285714285711037518922239542007446289062500E+03") 432 | if (allocated(error)) return 433 | end subroutine test_varying_precision_value4 434 | 435 | subroutine test_varying_precision_value5(error) 436 | type(error_type), allocatable, intent(out) :: error 437 | call check(error, d2exp(1729.142857142857_real64, 46), "1.7291428571428571103751892223954200744628906250E+03") 438 | if (allocated(error)) return 439 | end subroutine test_varying_precision_value5 440 | 441 | subroutine test_varying_precision_value6(error) 442 | type(error_type), allocatable, intent(out) :: error 443 | call check(error, d2exp(1729.142857142857_real64, 45), "1.729142857142857110375189222395420074462890625E+03") 444 | if (allocated(error)) return 445 | end subroutine test_varying_precision_value6 446 | 447 | subroutine test_varying_precision_value7(error) 448 | type(error_type), allocatable, intent(out) :: error 449 | call check(error, d2exp(1729.142857142857_real64, 44), "1.72914285714285711037518922239542007446289062E+03") 450 | if (allocated(error)) return 451 | end subroutine test_varying_precision_value7 452 | 453 | subroutine test_varying_precision_value8(error) 454 | type(error_type), allocatable, intent(out) :: error 455 | call check(error, d2exp(1729.142857142857_real64, 43), "1.7291428571428571103751892223954200744628906E+03") 456 | if (allocated(error)) return 457 | end subroutine test_varying_precision_value8 458 | 459 | subroutine test_varying_precision_value9(error) 460 | type(error_type), allocatable, intent(out) :: error 461 | call check(error, d2exp(1729.142857142857_real64, 42), "1.729142857142857110375189222395420074462891E+03") 462 | if (allocated(error)) return 463 | end subroutine test_varying_precision_value9 464 | 465 | subroutine test_varying_precision_value10(error) 466 | type(error_type), allocatable, intent(out) :: error 467 | call check(error, d2exp(1729.142857142857_real64, 41), "1.72914285714285711037518922239542007446289E+03") 468 | if (allocated(error)) return 469 | end subroutine test_varying_precision_value10 470 | 471 | subroutine test_varying_precision_value11(error) 472 | type(error_type), allocatable, intent(out) :: error 473 | call check(error, d2exp(1729.142857142857_real64, 40), "1.7291428571428571103751892223954200744629E+03") 474 | if (allocated(error)) return 475 | end subroutine test_varying_precision_value11 476 | 477 | subroutine test_varying_precision_value12(error) 478 | type(error_type), allocatable, intent(out) :: error 479 | call check(error, d2exp(1729.142857142857_real64, 39), "1.729142857142857110375189222395420074463E+03") 480 | if (allocated(error)) return 481 | end subroutine test_varying_precision_value12 482 | 483 | subroutine test_varying_precision_value13(error) 484 | type(error_type), allocatable, intent(out) :: error 485 | call check(error, d2exp(1729.142857142857_real64, 38), "1.72914285714285711037518922239542007446E+03") 486 | if (allocated(error)) return 487 | end subroutine test_varying_precision_value13 488 | 489 | subroutine test_varying_precision_value14(error) 490 | type(error_type), allocatable, intent(out) :: error 491 | call check(error, d2exp(1729.142857142857_real64, 37), "1.7291428571428571103751892223954200745E+03") 492 | if (allocated(error)) return 493 | end subroutine test_varying_precision_value14 494 | 495 | subroutine test_varying_precision_value15(error) 496 | type(error_type), allocatable, intent(out) :: error 497 | call check(error, d2exp(1729.142857142857_real64, 36), "1.729142857142857110375189222395420074E+03") 498 | if (allocated(error)) return 499 | end subroutine test_varying_precision_value15 500 | 501 | subroutine test_varying_precision_value16(error) 502 | type(error_type), allocatable, intent(out) :: error 503 | call check(error, d2exp(1729.142857142857_real64, 35), "1.72914285714285711037518922239542007E+03") 504 | if (allocated(error)) return 505 | end subroutine test_varying_precision_value16 506 | 507 | subroutine test_varying_precision_value17(error) 508 | type(error_type), allocatable, intent(out) :: error 509 | call check(error, d2exp(1729.142857142857_real64, 34), "1.7291428571428571103751892223954201E+03") 510 | if (allocated(error)) return 511 | end subroutine test_varying_precision_value17 512 | 513 | subroutine test_varying_precision_value18(error) 514 | type(error_type), allocatable, intent(out) :: error 515 | call check(error, d2exp(1729.142857142857_real64, 33), "1.729142857142857110375189222395420E+03") 516 | if (allocated(error)) return 517 | end subroutine test_varying_precision_value18 518 | 519 | subroutine test_varying_precision_value19(error) 520 | type(error_type), allocatable, intent(out) :: error 521 | call check(error, d2exp(1729.142857142857_real64, 32), "1.72914285714285711037518922239542E+03") 522 | if (allocated(error)) return 523 | end subroutine test_varying_precision_value19 524 | 525 | subroutine test_varying_precision_value20(error) 526 | type(error_type), allocatable, intent(out) :: error 527 | call check(error, d2exp(1729.142857142857_real64, 31), "1.7291428571428571103751892223954E+03") 528 | if (allocated(error)) return 529 | end subroutine test_varying_precision_value20 530 | 531 | subroutine test_varying_precision_value21(error) 532 | type(error_type), allocatable, intent(out) :: error 533 | call check(error, d2exp(1729.142857142857_real64, 30), "1.729142857142857110375189222395E+03") 534 | if (allocated(error)) return 535 | end subroutine test_varying_precision_value21 536 | 537 | subroutine test_varying_precision_value22(error) 538 | type(error_type), allocatable, intent(out) :: error 539 | call check(error, d2exp(1729.142857142857_real64, 29), "1.72914285714285711037518922240E+03") 540 | if (allocated(error)) return 541 | end subroutine test_varying_precision_value22 542 | 543 | subroutine test_varying_precision_value23(error) 544 | type(error_type), allocatable, intent(out) :: error 545 | call check(error, d2exp(1729.142857142857_real64, 28), "1.7291428571428571103751892224E+03") 546 | if (allocated(error)) return 547 | end subroutine test_varying_precision_value23 548 | 549 | subroutine test_varying_precision_value24(error) 550 | type(error_type), allocatable, intent(out) :: error 551 | call check(error, d2exp(1729.142857142857_real64, 27), "1.729142857142857110375189222E+03") 552 | if (allocated(error)) return 553 | end subroutine test_varying_precision_value24 554 | 555 | subroutine test_varying_precision_value25(error) 556 | type(error_type), allocatable, intent(out) :: error 557 | call check(error, d2exp(1729.142857142857_real64, 26), "1.72914285714285711037518922E+03") 558 | if (allocated(error)) return 559 | end subroutine test_varying_precision_value25 560 | 561 | subroutine test_varying_precision_value26(error) 562 | type(error_type), allocatable, intent(out) :: error 563 | call check(error, d2exp(1729.142857142857_real64, 25), "1.7291428571428571103751892E+03") 564 | if (allocated(error)) return 565 | end subroutine test_varying_precision_value26 566 | 567 | subroutine test_varying_precision_value27(error) 568 | type(error_type), allocatable, intent(out) :: error 569 | call check(error, d2exp(1729.142857142857_real64, 24), "1.729142857142857110375189E+03") 570 | if (allocated(error)) return 571 | end subroutine test_varying_precision_value27 572 | 573 | subroutine test_varying_precision_value28(error) 574 | type(error_type), allocatable, intent(out) :: error 575 | call check(error, d2exp(1729.142857142857_real64, 23), "1.72914285714285711037519E+03") 576 | if (allocated(error)) return 577 | end subroutine test_varying_precision_value28 578 | 579 | subroutine test_varying_precision_value29(error) 580 | type(error_type), allocatable, intent(out) :: error 581 | call check(error, d2exp(1729.142857142857_real64, 22), "1.7291428571428571103752E+03") 582 | if (allocated(error)) return 583 | end subroutine test_varying_precision_value29 584 | 585 | subroutine test_varying_precision_value30(error) 586 | type(error_type), allocatable, intent(out) :: error 587 | call check(error, d2exp(1729.142857142857_real64, 21), "1.729142857142857110375E+03") 588 | if (allocated(error)) return 589 | end subroutine test_varying_precision_value30 590 | 591 | subroutine test_varying_precision_value31(error) 592 | type(error_type), allocatable, intent(out) :: error 593 | call check(error, d2exp(1729.142857142857_real64, 20), "1.72914285714285711038E+03") 594 | if (allocated(error)) return 595 | end subroutine test_varying_precision_value31 596 | 597 | subroutine test_varying_precision_value32(error) 598 | type(error_type), allocatable, intent(out) :: error 599 | call check(error, d2exp(1729.142857142857_real64, 19), "1.7291428571428571104E+03") 600 | if (allocated(error)) return 601 | end subroutine test_varying_precision_value32 602 | 603 | subroutine test_varying_precision_value33(error) 604 | type(error_type), allocatable, intent(out) :: error 605 | call check(error, d2exp(1729.142857142857_real64, 18), "1.729142857142857110E+03") 606 | if (allocated(error)) return 607 | end subroutine test_varying_precision_value33 608 | 609 | subroutine test_varying_precision_value34(error) 610 | type(error_type), allocatable, intent(out) :: error 611 | call check(error, d2exp(1729.142857142857_real64, 17), "1.72914285714285711E+03") 612 | if (allocated(error)) return 613 | end subroutine test_varying_precision_value34 614 | 615 | subroutine test_varying_precision_value35(error) 616 | type(error_type), allocatable, intent(out) :: error 617 | call check(error, d2exp(1729.142857142857_real64, 16), "1.7291428571428571E+03") 618 | if (allocated(error)) return 619 | end subroutine test_varying_precision_value35 620 | 621 | subroutine test_varying_precision_value36(error) 622 | type(error_type), allocatable, intent(out) :: error 623 | call check(error, d2exp(1729.142857142857_real64, 15), "1.729142857142857E+03") 624 | if (allocated(error)) return 625 | end subroutine test_varying_precision_value36 626 | 627 | subroutine test_varying_precision_value37(error) 628 | type(error_type), allocatable, intent(out) :: error 629 | call check(error, d2exp(1729.142857142857_real64, 14), "1.72914285714286E+03") 630 | if (allocated(error)) return 631 | end subroutine test_varying_precision_value37 632 | 633 | subroutine test_varying_precision_value38(error) 634 | type(error_type), allocatable, intent(out) :: error 635 | call check(error, d2exp(1729.142857142857_real64, 13), "1.7291428571429E+03") 636 | if (allocated(error)) return 637 | end subroutine test_varying_precision_value38 638 | 639 | subroutine test_varying_precision_value39(error) 640 | type(error_type), allocatable, intent(out) :: error 641 | call check(error, d2exp(1729.142857142857_real64, 12), "1.729142857143E+03") 642 | if (allocated(error)) return 643 | end subroutine test_varying_precision_value39 644 | 645 | subroutine test_varying_precision_value40(error) 646 | type(error_type), allocatable, intent(out) :: error 647 | call check(error, d2exp(1729.142857142857_real64, 11), "1.72914285714E+03") 648 | if (allocated(error)) return 649 | end subroutine test_varying_precision_value40 650 | 651 | subroutine test_varying_precision_value41(error) 652 | type(error_type), allocatable, intent(out) :: error 653 | call check(error, d2exp(1729.142857142857_real64, 10), "1.7291428571E+03") 654 | if (allocated(error)) return 655 | end subroutine test_varying_precision_value41 656 | 657 | subroutine test_varying_precision_value42(error) 658 | type(error_type), allocatable, intent(out) :: error 659 | call check(error, d2exp(1729.142857142857_real64, 9), "1.729142857E+03") 660 | if (allocated(error)) return 661 | end subroutine test_varying_precision_value42 662 | 663 | subroutine test_varying_precision_value43(error) 664 | type(error_type), allocatable, intent(out) :: error 665 | call check(error, d2exp(1729.142857142857_real64, 8), "1.72914286E+03") 666 | if (allocated(error)) return 667 | end subroutine test_varying_precision_value43 668 | 669 | subroutine test_varying_precision_value44(error) 670 | type(error_type), allocatable, intent(out) :: error 671 | call check(error, d2exp(1729.142857142857_real64, 7), "1.7291429E+03") 672 | if (allocated(error)) return 673 | end subroutine test_varying_precision_value44 674 | 675 | subroutine test_varying_precision_value45(error) 676 | type(error_type), allocatable, intent(out) :: error 677 | call check(error, d2exp(1729.142857142857_real64, 6), "1.729143E+03") 678 | if (allocated(error)) return 679 | end subroutine test_varying_precision_value45 680 | 681 | subroutine test_varying_precision_value46(error) 682 | type(error_type), allocatable, intent(out) :: error 683 | call check(error, d2exp(1729.142857142857_real64, 5), "1.72914E+03") 684 | if (allocated(error)) return 685 | end subroutine test_varying_precision_value46 686 | 687 | subroutine test_varying_precision_value47(error) 688 | type(error_type), allocatable, intent(out) :: error 689 | call check(error, d2exp(1729.142857142857_real64, 4), "1.7291E+03") 690 | if (allocated(error)) return 691 | end subroutine test_varying_precision_value47 692 | 693 | subroutine test_varying_precision_value48(error) 694 | type(error_type), allocatable, intent(out) :: error 695 | call check(error, d2exp(1729.142857142857_real64, 3), "1.729E+03") 696 | if (allocated(error)) return 697 | end subroutine test_varying_precision_value48 698 | 699 | subroutine test_varying_precision_value49(error) 700 | type(error_type), allocatable, intent(out) :: error 701 | call check(error, d2exp(1729.142857142857_real64, 2), "1.73E+03") 702 | if (allocated(error)) return 703 | end subroutine test_varying_precision_value49 704 | 705 | subroutine test_varying_precision_value50(error) 706 | type(error_type), allocatable, intent(out) :: error 707 | call check(error, d2exp(1729.142857142857_real64, 1), "1.7E+03") 708 | if (allocated(error)) return 709 | end subroutine test_varying_precision_value50 710 | 711 | subroutine test_varying_precision_value51(error) 712 | type(error_type), allocatable, intent(out) :: error 713 | call check(error, d2exp(1729.142857142857_real64, 0), "2E+03") 714 | if (allocated(error)) return 715 | end subroutine test_varying_precision_value51 716 | 717 | !> ============================================================================= 718 | 719 | subroutine collect_carrying(testsuite) 720 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 721 | 722 | testsuite = [ & 723 | new_unittest("value1", test_carrying_value1), & 724 | new_unittest("value2", test_carrying_value2), & 725 | new_unittest("value3", test_carrying_value3), & 726 | new_unittest("value4", test_carrying_value4), & 727 | new_unittest("value5", test_carrying_value5), & 728 | new_unittest("value6", test_carrying_value6), & 729 | new_unittest("value7", test_carrying_value7), & 730 | new_unittest("value8", test_carrying_value8), & 731 | new_unittest("value9", test_carrying_value9), & 732 | new_unittest("value10", test_carrying_value10), & 733 | new_unittest("value11", test_carrying_value11), & 734 | new_unittest("value12", test_carrying_value12), & 735 | new_unittest("value13", test_carrying_value13), & 736 | new_unittest("value14", test_carrying_value14), & 737 | new_unittest("value15", test_carrying_value15), & 738 | new_unittest("value16", test_carrying_value16), & 739 | new_unittest("value17", test_carrying_value17), & 740 | new_unittest("value18", test_carrying_value18), & 741 | new_unittest("value19", test_carrying_value19), & 742 | new_unittest("value20", test_carrying_value20), & 743 | new_unittest("value21", test_carrying_value21), & 744 | new_unittest("value22", test_carrying_value22), & 745 | new_unittest("value23", test_carrying_value23), & 746 | new_unittest("value24", test_carrying_value24), & 747 | new_unittest("value25", test_carrying_value25), & 748 | new_unittest("value26", test_carrying_value26), & 749 | new_unittest("value27", test_carrying_value27), & 750 | new_unittest("value28", test_carrying_value28) & 751 | ] 752 | 753 | end subroutine collect_carrying 754 | 755 | subroutine test_carrying_value1(error) 756 | type(error_type), allocatable, intent(out) :: error 757 | call check(error, d2exp(2.0009_real64, 4), "2.0009E+00") 758 | if (allocated(error)) return 759 | end subroutine test_carrying_value1 760 | 761 | subroutine test_carrying_value2(error) 762 | type(error_type), allocatable, intent(out) :: error 763 | call check(error, d2exp(2.0009_real64, 3), "2.001E+00") 764 | if (allocated(error)) return 765 | end subroutine test_carrying_value2 766 | 767 | subroutine test_carrying_value3(error) 768 | type(error_type), allocatable, intent(out) :: error 769 | call check(error, d2exp(2.0029_real64, 4), "2.0029E+00") 770 | if (allocated(error)) return 771 | end subroutine test_carrying_value3 772 | 773 | subroutine test_carrying_value4(error) 774 | type(error_type), allocatable, intent(out) :: error 775 | call check(error, d2exp(2.0029_real64, 3), "2.003E+00") 776 | if (allocated(error)) return 777 | end subroutine test_carrying_value4 778 | 779 | subroutine test_carrying_value5(error) 780 | type(error_type), allocatable, intent(out) :: error 781 | call check(error, d2exp(2.0099_real64, 4), "2.0099E+00") 782 | if (allocated(error)) return 783 | end subroutine test_carrying_value5 784 | 785 | subroutine test_carrying_value6(error) 786 | type(error_type), allocatable, intent(out) :: error 787 | call check(error, d2exp(2.0099_real64, 3), "2.010E+00") 788 | if (allocated(error)) return 789 | end subroutine test_carrying_value6 790 | 791 | subroutine test_carrying_value7(error) 792 | type(error_type), allocatable, intent(out) :: error 793 | call check(error, d2exp(2.0299_real64, 4), "2.0299E+00") 794 | if (allocated(error)) return 795 | end subroutine test_carrying_value7 796 | 797 | subroutine test_carrying_value8(error) 798 | type(error_type), allocatable, intent(out) :: error 799 | call check(error, d2exp(2.0299_real64, 3), "2.030E+00") 800 | if (allocated(error)) return 801 | end subroutine test_carrying_value8 802 | 803 | subroutine test_carrying_value9(error) 804 | type(error_type), allocatable, intent(out) :: error 805 | call check(error, d2exp(2.0999_real64, 4), "2.0999E+00") 806 | if (allocated(error)) return 807 | end subroutine test_carrying_value9 808 | 809 | subroutine test_carrying_value10(error) 810 | type(error_type), allocatable, intent(out) :: error 811 | call check(error, d2exp(2.0999_real64, 3), "2.100E+00") 812 | if (allocated(error)) return 813 | end subroutine test_carrying_value10 814 | 815 | subroutine test_carrying_value11(error) 816 | type(error_type), allocatable, intent(out) :: error 817 | call check(error, d2exp(2.2999_real64, 4), "2.2999E+00") 818 | if (allocated(error)) return 819 | end subroutine test_carrying_value11 820 | 821 | subroutine test_carrying_value12(error) 822 | type(error_type), allocatable, intent(out) :: error 823 | call check(error, d2exp(2.2999_real64, 3), "2.300E+00") 824 | if (allocated(error)) return 825 | end subroutine test_carrying_value12 826 | 827 | subroutine test_carrying_value13(error) 828 | type(error_type), allocatable, intent(out) :: error 829 | call check(error, d2exp(2.9999_real64, 4), "2.9999E+00") 830 | if (allocated(error)) return 831 | end subroutine test_carrying_value13 832 | 833 | subroutine test_carrying_value14(error) 834 | type(error_type), allocatable, intent(out) :: error 835 | call check(error, d2exp(2.9999_real64, 3), "3.000E+00") 836 | if (allocated(error)) return 837 | end subroutine test_carrying_value14 838 | 839 | subroutine test_carrying_value15(error) 840 | type(error_type), allocatable, intent(out) :: error 841 | call check(error, d2exp(9.9999_real64, 4), "9.9999E+00") 842 | if (allocated(error)) return 843 | end subroutine test_carrying_value15 844 | 845 | subroutine test_carrying_value16(error) 846 | type(error_type), allocatable, intent(out) :: error 847 | call check(error, d2exp(9.9999_real64, 3), "1.000E+01") 848 | if (allocated(error)) return 849 | end subroutine test_carrying_value16 850 | 851 | subroutine test_carrying_value17(error) 852 | type(error_type), allocatable, intent(out) :: error 853 | call check(error, d2exp(2.09_real64, 2), "2.09E+00") 854 | if (allocated(error)) return 855 | end subroutine test_carrying_value17 856 | 857 | subroutine test_carrying_value18(error) 858 | type(error_type), allocatable, intent(out) :: error 859 | call check(error, d2exp(2.09_real64, 1), "2.1E+00") 860 | if (allocated(error)) return 861 | end subroutine test_carrying_value18 862 | 863 | subroutine test_carrying_value19(error) 864 | type(error_type), allocatable, intent(out) :: error 865 | call check(error, d2exp(2.29_real64, 2), "2.29E+00") 866 | if (allocated(error)) return 867 | end subroutine test_carrying_value19 868 | 869 | subroutine test_carrying_value20(error) 870 | type(error_type), allocatable, intent(out) :: error 871 | call check(error, d2exp(2.29_real64, 1), "2.3E+00") 872 | if (allocated(error)) return 873 | end subroutine test_carrying_value20 874 | 875 | subroutine test_carrying_value21(error) 876 | type(error_type), allocatable, intent(out) :: error 877 | call check(error, d2exp(2.99_real64, 2), "2.99E+00") 878 | if (allocated(error)) return 879 | end subroutine test_carrying_value21 880 | 881 | subroutine test_carrying_value22(error) 882 | type(error_type), allocatable, intent(out) :: error 883 | call check(error, d2exp(2.99_real64, 1), "3.0E+00") 884 | if (allocated(error)) return 885 | end subroutine test_carrying_value22 886 | 887 | subroutine test_carrying_value23(error) 888 | type(error_type), allocatable, intent(out) :: error 889 | call check(error, d2exp(9.99_real64, 2), "9.99E+00") 890 | if (allocated(error)) return 891 | end subroutine test_carrying_value23 892 | 893 | subroutine test_carrying_value24(error) 894 | type(error_type), allocatable, intent(out) :: error 895 | call check(error, d2exp(9.99_real64, 1), "1.0E+01") 896 | if (allocated(error)) return 897 | end subroutine test_carrying_value24 898 | 899 | subroutine test_carrying_value25(error) 900 | type(error_type), allocatable, intent(out) :: error 901 | call check(error, d2exp(2.9_real64, 1), "2.9E+00") 902 | if (allocated(error)) return 903 | end subroutine test_carrying_value25 904 | 905 | subroutine test_carrying_value26(error) 906 | type(error_type), allocatable, intent(out) :: error 907 | call check(error, d2exp(2.9_real64, 0), "3E+00") 908 | if (allocated(error)) return 909 | end subroutine test_carrying_value26 910 | 911 | subroutine test_carrying_value27(error) 912 | type(error_type), allocatable, intent(out) :: error 913 | call check(error, d2exp(9.9_real64, 1), "9.9E+00") 914 | if (allocated(error)) return 915 | end subroutine test_carrying_value27 916 | 917 | subroutine test_carrying_value28(error) 918 | type(error_type), allocatable, intent(out) :: error 919 | call check(error, d2exp(9.9_real64, 0), "1E+01") 920 | if (allocated(error)) return 921 | end subroutine test_carrying_value28 922 | 923 | !> ============================================================================= 924 | 925 | subroutine collect_exponents(testsuite) 926 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 927 | 928 | testsuite = [ & 929 | new_unittest("value1", test_exponents_value1), & 930 | new_unittest("value2", test_exponents_value2), & 931 | new_unittest("value3", test_exponents_value3), & 932 | new_unittest("value4", test_exponents_value4), & 933 | new_unittest("value5", test_exponents_value5), & 934 | new_unittest("value6", test_exponents_value6), & 935 | new_unittest("value7", test_exponents_value7), & 936 | new_unittest("value8", test_exponents_value8), & 937 | new_unittest("value9", test_exponents_value9), & 938 | new_unittest("value10", test_exponents_value10), & 939 | new_unittest("value11", test_exponents_value11), & 940 | new_unittest("value12", test_exponents_value12), & 941 | new_unittest("value13", test_exponents_value13), & 942 | new_unittest("value14", test_exponents_value14), & 943 | new_unittest("value15", test_exponents_value15), & 944 | new_unittest("value16", test_exponents_value16), & 945 | new_unittest("value17", test_exponents_value17), & 946 | new_unittest("value18", test_exponents_value18), & 947 | new_unittest("value19", test_exponents_value19), & 948 | new_unittest("value20", test_exponents_value20), & 949 | new_unittest("value21", test_exponents_value21), & 950 | new_unittest("value22", test_exponents_value22) & 951 | ] 952 | 953 | end subroutine collect_exponents 954 | 955 | subroutine test_exponents_value1(error) 956 | type(error_type), allocatable, intent(out) :: error 957 | call check(error, d2exp(9.99E-100_real64, 2), "9.99E-100") 958 | if (allocated(error)) return 959 | end subroutine test_exponents_value1 960 | 961 | subroutine test_exponents_value2(error) 962 | type(error_type), allocatable, intent(out) :: error 963 | call check(error, d2exp(9.99E-99_real64, 2), "9.99E-99") 964 | if (allocated(error)) return 965 | end subroutine test_exponents_value2 966 | 967 | subroutine test_exponents_value3(error) 968 | type(error_type), allocatable, intent(out) :: error 969 | call check(error, d2exp(9.99E-10_real64, 2), "9.99E-10") 970 | if (allocated(error)) return 971 | end subroutine test_exponents_value3 972 | 973 | subroutine test_exponents_value4(error) 974 | type(error_type), allocatable, intent(out) :: error 975 | call check(error, d2exp(9.99E-09_real64, 2), "9.99E-09") 976 | if (allocated(error)) return 977 | end subroutine test_exponents_value4 978 | 979 | subroutine test_exponents_value5(error) 980 | type(error_type), allocatable, intent(out) :: error 981 | call check(error, d2exp(9.99E-01_real64, 2), "9.99E-01") 982 | if (allocated(error)) return 983 | end subroutine test_exponents_value5 984 | 985 | subroutine test_exponents_value6(error) 986 | type(error_type), allocatable, intent(out) :: error 987 | call check(error, d2exp(9.99E+00_real64, 2), "9.99E+00") 988 | if (allocated(error)) return 989 | end subroutine test_exponents_value6 990 | 991 | subroutine test_exponents_value7(error) 992 | type(error_type), allocatable, intent(out) :: error 993 | call check(error, d2exp(9.99E+01_real64, 2), "9.99E+01") 994 | if (allocated(error)) return 995 | end subroutine test_exponents_value7 996 | 997 | subroutine test_exponents_value8(error) 998 | type(error_type), allocatable, intent(out) :: error 999 | call check(error, d2exp(9.99E+09_real64, 2), "9.99E+09") 1000 | if (allocated(error)) return 1001 | end subroutine test_exponents_value8 1002 | 1003 | subroutine test_exponents_value9(error) 1004 | type(error_type), allocatable, intent(out) :: error 1005 | call check(error, d2exp(9.99E+10_real64, 2), "9.99E+10") 1006 | if (allocated(error)) return 1007 | end subroutine test_exponents_value9 1008 | 1009 | subroutine test_exponents_value10(error) 1010 | type(error_type), allocatable, intent(out) :: error 1011 | call check(error, d2exp(9.99E+99_real64, 2), "9.99E+99") 1012 | if (allocated(error)) return 1013 | end subroutine test_exponents_value10 1014 | 1015 | subroutine test_exponents_value11(error) 1016 | type(error_type), allocatable, intent(out) :: error 1017 | call check(error, d2exp(9.99E+100_real64, 2), "9.99E+100") 1018 | if (allocated(error)) return 1019 | end subroutine test_exponents_value11 1020 | 1021 | subroutine test_exponents_value12(error) 1022 | type(error_type), allocatable, intent(out) :: error 1023 | call check(error, d2exp(9.99E-100_real64, 1), "1.0E-99") 1024 | if (allocated(error)) return 1025 | end subroutine test_exponents_value12 1026 | 1027 | subroutine test_exponents_value13(error) 1028 | type(error_type), allocatable, intent(out) :: error 1029 | call check(error, d2exp(9.99E-99_real64, 1), "1.0E-98") 1030 | if (allocated(error)) return 1031 | end subroutine test_exponents_value13 1032 | 1033 | subroutine test_exponents_value14(error) 1034 | type(error_type), allocatable, intent(out) :: error 1035 | call check(error, d2exp(9.99E-10_real64, 1), "1.0E-09") 1036 | if (allocated(error)) return 1037 | end subroutine test_exponents_value14 1038 | 1039 | subroutine test_exponents_value15(error) 1040 | type(error_type), allocatable, intent(out) :: error 1041 | call check(error, d2exp(9.99E-09_real64, 1), "1.0E-08") 1042 | if (allocated(error)) return 1043 | end subroutine test_exponents_value15 1044 | 1045 | subroutine test_exponents_value16(error) 1046 | type(error_type), allocatable, intent(out) :: error 1047 | call check(error, d2exp(9.99E-01_real64, 1), "1.0E+00") 1048 | if (allocated(error)) return 1049 | end subroutine test_exponents_value16 1050 | 1051 | subroutine test_exponents_value17(error) 1052 | type(error_type), allocatable, intent(out) :: error 1053 | call check(error, d2exp(9.99E+00_real64, 1), "1.0E+01") 1054 | if (allocated(error)) return 1055 | end subroutine test_exponents_value17 1056 | 1057 | subroutine test_exponents_value18(error) 1058 | type(error_type), allocatable, intent(out) :: error 1059 | call check(error, d2exp(9.99E+01_real64, 1), "1.0E+02") 1060 | if (allocated(error)) return 1061 | end subroutine test_exponents_value18 1062 | 1063 | subroutine test_exponents_value19(error) 1064 | type(error_type), allocatable, intent(out) :: error 1065 | call check(error, d2exp(9.99E+09_real64, 1), "1.0E+10") 1066 | if (allocated(error)) return 1067 | end subroutine test_exponents_value19 1068 | 1069 | subroutine test_exponents_value20(error) 1070 | type(error_type), allocatable, intent(out) :: error 1071 | call check(error, d2exp(9.99E+10_real64, 1), "1.0E+11") 1072 | if (allocated(error)) return 1073 | end subroutine test_exponents_value20 1074 | 1075 | subroutine test_exponents_value21(error) 1076 | type(error_type), allocatable, intent(out) :: error 1077 | call check(error, d2exp(9.99E+99_real64, 1), "1.0E+100") 1078 | if (allocated(error)) return 1079 | end subroutine test_exponents_value21 1080 | 1081 | subroutine test_exponents_value22(error) 1082 | type(error_type), allocatable, intent(out) :: error 1083 | call check(error, d2exp(9.99E+100_real64, 1), "1.0E+101") 1084 | if (allocated(error)) return 1085 | end subroutine test_exponents_value22 1086 | 1087 | !> ============================================================================= 1088 | 1089 | subroutine collect_print_decimal_point(testsuite) 1090 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 1091 | 1092 | testsuite = [ & 1093 | new_unittest("value1", test_print_decimal_point_value1), & 1094 | new_unittest("value2", test_print_decimal_point_value2), & 1095 | new_unittest("value3", test_print_decimal_point_value3), & 1096 | new_unittest("value4", test_print_decimal_point_value4), & 1097 | new_unittest("value5", test_print_decimal_point_value5), & 1098 | new_unittest("value6", test_print_decimal_point_value6) & 1099 | ] 1100 | 1101 | end subroutine collect_print_decimal_point 1102 | 1103 | subroutine test_print_decimal_point_value1(error) 1104 | type(error_type), allocatable, intent(out) :: error 1105 | call check(error, d2exp(1e+54_real64, 0), "1E+54") 1106 | if (allocated(error)) return 1107 | end subroutine test_print_decimal_point_value1 1108 | 1109 | subroutine test_print_decimal_point_value2(error) 1110 | type(error_type), allocatable, intent(out) :: error 1111 | call check(error, d2exp(1e+54_real64, 1), "1.0E+54") 1112 | if (allocated(error)) return 1113 | end subroutine test_print_decimal_point_value2 1114 | 1115 | subroutine test_print_decimal_point_value3(error) 1116 | type(error_type), allocatable, intent(out) :: error 1117 | call check(error, d2exp(1e-63_real64, 0), "1E-63") 1118 | if (allocated(error)) return 1119 | end subroutine test_print_decimal_point_value3 1120 | 1121 | subroutine test_print_decimal_point_value4(error) 1122 | type(error_type), allocatable, intent(out) :: error 1123 | call check(error, d2exp(1e-63_real64, 1), "1.0E-63") 1124 | if (allocated(error)) return 1125 | end subroutine test_print_decimal_point_value4 1126 | 1127 | subroutine test_print_decimal_point_value5(error) 1128 | type(error_type), allocatable, intent(out) :: error 1129 | call check(error, d2exp(1e+83_real64, 0), "1E+83") 1130 | if (allocated(error)) return 1131 | end subroutine test_print_decimal_point_value5 1132 | 1133 | subroutine test_print_decimal_point_value6(error) 1134 | type(error_type), allocatable, intent(out) :: error 1135 | call check(error, d2exp(1e+83_real64, 1), "1.0E+83") 1136 | if (allocated(error)) return 1137 | end subroutine test_print_decimal_point_value6 1138 | end module test_d2exp 1139 | -------------------------------------------------------------------------------- /test/test_d2exp/tester.f90: -------------------------------------------------------------------------------- 1 | program main 2 | use testdrive 3 | use iso_fortran_env 4 | use test_d2exp 5 | implicit none 6 | integer :: stat, is 7 | type(testsuite_type), dimension(:), allocatable :: testsuites 8 | character(len=*), parameter :: fmt = '("#", *(1x, a))' 9 | 10 | stat = 0 11 | 12 | testsuites = [ & 13 | new_testsuite("test_basic", collect_basic), & 14 | new_testsuite("test_zeros", collect_zeros), & 15 | new_testsuite("test_max_and_min", collect_max_and_min), & 16 | new_testsuite("test_round_to_even", collect_round_to_even), & 17 | new_testsuite("test_round_to_even_integer", collect_round_to_even_integer), & 18 | new_testsuite("test_non_round_to_even_scenarios", collect_non_round_to_even_scenarios), & 19 | new_testsuite("test_varying_precision", collect_varying_precision), & 20 | new_testsuite("test_carrying", collect_carrying), & 21 | new_testsuite("test_exponents", collect_exponents), & 22 | new_testsuite("test_print_decimal_point", collect_print_decimal_point) & 23 | ] 24 | 25 | do is = 1, size(testsuites) 26 | write (error_unit, fmt) "Testing:", testsuites(is)%name 27 | call run_testsuite(testsuites(is)%collect, error_unit, stat) 28 | end do 29 | 30 | if (stat > 0) then 31 | write (error_unit, '(i0, 1x, a)') stat, "test(s) failed!" 32 | error stop 33 | end if 34 | 35 | end program main -------------------------------------------------------------------------------- /test/test_d2fixed/test_d2fixed.f90: -------------------------------------------------------------------------------- 1 | module test_d2fixed 2 | use testdrive, only: new_unittest, unittest_type, error_type, check 3 | use real64_to_fixed 4 | use iso_fortran_env, only: int32, int64, real64 5 | implicit none 6 | private 7 | public :: collect_basic, collect_zeros, collect_max_and_min, collect_round_to_even 8 | public :: collect_round_to_even_integer, collect_non_round_to_even_scenarios 9 | public :: collect_varying_precision, collect_carrying, collect_regression 10 | public :: collect_rounding_result_zero 11 | 12 | real(kind=real64), parameter :: NaN = transfer(int(z'7FF0000000000001', int64), 1._real64) 13 | real(kind=real64), parameter :: plus_infinity = transfer(int(z'7FF0000000000000', int64), 1._real64) 14 | real(kind=real64), parameter :: minus_infinity = transfer(int(z'FFF0000000000000', int64), 1._real64) 15 | integer(kind=int64), parameter :: max_mantissa = shiftl(1_int64, 53) - 1 16 | 17 | contains 18 | 19 | function ieee_part_to_real64(sign, ieee_exponent, ieee_mantissa) result(d) 20 | logical(kind=int32), intent(in) :: sign 21 | integer(kind=int32), intent(in) :: ieee_exponent 22 | integer(kind=int64), intent(in) :: ieee_mantissa 23 | real(kind=real64) :: d 24 | integer(kind=int64) :: i 25 | 26 | if (sign) then 27 | i = ior(shiftl(1_int64, 63), ior(shiftl(int(ieee_exponent, int64), 52), ieee_mantissa)) 28 | else 29 | i = ior(shiftl(0_int64, 63), ior(shiftl(int(ieee_exponent, int64), 52), ieee_mantissa)) 30 | end if 31 | 32 | d = transfer(i, 1._real64) 33 | 34 | end function ieee_part_to_real64 35 | 36 | !> ============================================================================= 37 | 38 | subroutine collect_basic(testsuite) 39 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 40 | 41 | testsuite = [ & 42 | new_unittest("value1", test_basic_value1) & 43 | ] 44 | 45 | end subroutine collect_basic 46 | 47 | subroutine test_basic_value1(error) 48 | type(error_type), allocatable, intent(out) :: error 49 | 50 | call check(error, d2fixed(ieee_part_to_real64(.false., 1234, 99999_int64), 0), & 51 | "3291009114715486435425664845573426149758869524108446525879746560") 52 | if (allocated(error)) return 53 | 54 | end subroutine test_basic_value1 55 | 56 | !> ============================================================================= 57 | 58 | subroutine collect_zeros(testsuite) 59 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 60 | 61 | testsuite = [ & 62 | new_unittest("value1", test_zeros_value1), & 63 | new_unittest("value2", test_zeros_value2), & 64 | new_unittest("value3", test_zeros_value3), & 65 | new_unittest("value4", test_zeros_value4), & 66 | new_unittest("value5", test_zeros_value5) & 67 | ] 68 | 69 | end subroutine collect_zeros 70 | 71 | subroutine test_zeros_value1(error) 72 | type(error_type), allocatable, intent(out) :: error 73 | 74 | call check(error, d2fixed(0.0_real64, 4), "0.0000") 75 | if (allocated(error)) return 76 | 77 | end subroutine test_zeros_value1 78 | 79 | subroutine test_zeros_value2(error) 80 | type(error_type), allocatable, intent(out) :: error 81 | 82 | call check(error, d2fixed(0.0_real64, 3), "0.000") 83 | if (allocated(error)) return 84 | 85 | end subroutine test_zeros_value2 86 | 87 | subroutine test_zeros_value3(error) 88 | type(error_type), allocatable, intent(out) :: error 89 | 90 | call check(error, d2fixed(0.0_real64, 2), "0.00") 91 | if (allocated(error)) return 92 | 93 | end subroutine test_zeros_value3 94 | 95 | subroutine test_zeros_value4(error) 96 | type(error_type), allocatable, intent(out) :: error 97 | 98 | call check(error, d2fixed(0.0_real64, 1), "0.0") 99 | if (allocated(error)) return 100 | 101 | end subroutine test_zeros_value4 102 | 103 | subroutine test_zeros_value5(error) 104 | type(error_type), allocatable, intent(out) :: error 105 | 106 | call check(error, d2fixed(0.0_real64, 0), "0") 107 | if (allocated(error)) return 108 | 109 | end subroutine test_zeros_value5 110 | 111 | !> ============================================================================= 112 | 113 | subroutine collect_max_and_min(testsuite) 114 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 115 | 116 | testsuite = [ & 117 | new_unittest("max", test_max), & 118 | new_unittest("min", test_min) & 119 | ] 120 | 121 | end subroutine collect_max_and_min 122 | 123 | subroutine test_max(error) 124 | type(error_type), allocatable, intent(out) :: error 125 | real(kind=real64), parameter :: max = transfer(int(z'7fefffffffffffff', int64), 1._real64) 126 | 127 | call check(error, d2fixed(max, 0), & 128 | "179769313486231570814527423731704356798070567525844996598917476803157260780028538760589558"// & 129 | "632766878171540458953514382464234321326889464182768467546703537516986049910576551282076245"// & 130 | "490090389328944075868508455133942304583236903222948165808559332123348274797826204144723168"// & 131 | "738177180919299881250404026184124858368") 132 | if (allocated(error)) return 133 | 134 | end subroutine test_max 135 | 136 | subroutine test_min(error) 137 | type(error_type), allocatable, intent(out) :: error 138 | real(kind=real64), parameter :: min = transfer(1_int64, 1._real64) 139 | 140 | call check(error, d2fixed(min, 1074), & 141 | "0.0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"// & 142 | "000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"// & 143 | "000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"// & 144 | "000000000000000000000000000000000000000000000000000000049406564584124654417656879286822137"// & 145 | "236505980261432476442558568250067550727020875186529983636163599237979656469544571773092665"// & 146 | "671035593979639877479601078187812630071319031140452784581716784898210368871863605699873072"// & 147 | "305000638740915356498438731247339727316961514003171538539807412623856559117102665855668676"// & 148 | "818703956031062493194527159149245532930545654440112748012970999954193198940908041656332452"// & 149 | "475714786901472678015935523861155013480352649347201937902681071074917033322268447533357208"// & 150 | "324319360923828934583680601060115061698097530783422773183292479049825247307763759272478746"// & 151 | "560847782037344696995336470179726777175851256605511991315048911014510378627381672509558373"// & 152 | "89733598993664809941164205702637090279242767544565229087538682506419718265533447265625") 153 | if (allocated(error)) return 154 | 155 | end subroutine test_min 156 | 157 | !> ============================================================================= 158 | 159 | subroutine collect_round_to_even(testsuite) 160 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 161 | 162 | testsuite = [ & 163 | new_unittest("value1", test_round_to_even_value1), & 164 | new_unittest("value2", test_round_to_even_value2), & 165 | new_unittest("value3", test_round_to_even_value3), & 166 | new_unittest("value4", test_round_to_even_value4) & 167 | ] 168 | 169 | end subroutine collect_round_to_even 170 | 171 | subroutine test_round_to_even_value1(error) 172 | type(error_type), allocatable, intent(out) :: error 173 | 174 | call check(error, d2fixed(0.125_real64, 3), "0.125") 175 | if (allocated(error)) return 176 | 177 | end subroutine test_round_to_even_value1 178 | 179 | subroutine test_round_to_even_value2(error) 180 | type(error_type), allocatable, intent(out) :: error 181 | 182 | call check(error, d2fixed(0.125_real64, 2), "0.12") 183 | if (allocated(error)) return 184 | 185 | end subroutine test_round_to_even_value2 186 | 187 | subroutine test_round_to_even_value3(error) 188 | type(error_type), allocatable, intent(out) :: error 189 | 190 | call check(error, d2fixed(0.375_real64, 3), "0.375") 191 | if (allocated(error)) return 192 | 193 | end subroutine test_round_to_even_value3 194 | 195 | subroutine test_round_to_even_value4(error) 196 | type(error_type), allocatable, intent(out) :: error 197 | 198 | call check(error, d2fixed(0.375_real64, 2), "0.38") 199 | if (allocated(error)) return 200 | 201 | end subroutine test_round_to_even_value4 202 | 203 | !> ============================================================================= 204 | 205 | subroutine collect_round_to_even_integer(testsuite) 206 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 207 | 208 | testsuite = [ & 209 | new_unittest("value1", test_round_to_even_integer_value1), & 210 | new_unittest("value2", test_round_to_even_integer_value2), & 211 | new_unittest("value3", test_round_to_even_integer_value3), & 212 | new_unittest("value4", test_round_to_even_integer_value4) & 213 | ] 214 | 215 | end subroutine collect_round_to_even_integer 216 | 217 | subroutine test_round_to_even_integer_value1(error) 218 | type(error_type), allocatable, intent(out) :: error 219 | 220 | call check(error, d2fixed(2.5_real64, 1), "2.5") 221 | if (allocated(error)) return 222 | 223 | end subroutine test_round_to_even_integer_value1 224 | 225 | subroutine test_round_to_even_integer_value2(error) 226 | type(error_type), allocatable, intent(out) :: error 227 | 228 | call check(error, d2fixed(2.5_real64, 0), "2") 229 | if (allocated(error)) return 230 | 231 | end subroutine test_round_to_even_integer_value2 232 | 233 | subroutine test_round_to_even_integer_value3(error) 234 | type(error_type), allocatable, intent(out) :: error 235 | 236 | call check(error, d2fixed(3.5_real64, 1), "3.5") 237 | if (allocated(error)) return 238 | 239 | end subroutine test_round_to_even_integer_value3 240 | 241 | subroutine test_round_to_even_integer_value4(error) 242 | type(error_type), allocatable, intent(out) :: error 243 | 244 | call check(error, d2fixed(3.5_real64, 0), "4") 245 | if (allocated(error)) return 246 | 247 | end subroutine test_round_to_even_integer_value4 248 | 249 | !> ============================================================================= 250 | 251 | subroutine collect_non_round_to_even_scenarios(testsuite) 252 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 253 | 254 | testsuite = [ & 255 | new_unittest("value1", test_non_round_to_even_scenarios_value1), & 256 | new_unittest("value2", test_non_round_to_even_scenarios_value2), & 257 | new_unittest("value3", test_non_round_to_even_scenarios_value3), & 258 | new_unittest("value4", test_non_round_to_even_scenarios_value4), & 259 | new_unittest("value5", test_non_round_to_even_scenarios_value5), & 260 | new_unittest("value6", test_non_round_to_even_scenarios_value6), & 261 | new_unittest("value7", test_non_round_to_even_scenarios_value7), & 262 | new_unittest("value8", test_non_round_to_even_scenarios_value8), & 263 | new_unittest("value9", test_non_round_to_even_scenarios_value9), & 264 | new_unittest("value10", test_non_round_to_even_scenarios_value10) & 265 | ] 266 | 267 | end subroutine collect_non_round_to_even_scenarios 268 | 269 | subroutine test_non_round_to_even_scenarios_value1(error) 270 | type(error_type), allocatable, intent(out) :: error 271 | 272 | call check(error, d2fixed(0.748046875_real64, 3), "0.748") 273 | if (allocated(error)) return 274 | 275 | end subroutine test_non_round_to_even_scenarios_value1 276 | 277 | subroutine test_non_round_to_even_scenarios_value2(error) 278 | type(error_type), allocatable, intent(out) :: error 279 | 280 | call check(error, d2fixed(0.748046875_real64, 2), "0.75") 281 | if (allocated(error)) return 282 | 283 | end subroutine test_non_round_to_even_scenarios_value2 284 | 285 | subroutine test_non_round_to_even_scenarios_value3(error) 286 | type(error_type), allocatable, intent(out) :: error 287 | 288 | call check(error, d2fixed(0.748046875_real64, 1), "0.7") 289 | if (allocated(error)) return 290 | 291 | end subroutine test_non_round_to_even_scenarios_value3 292 | 293 | subroutine test_non_round_to_even_scenarios_value4(error) 294 | type(error_type), allocatable, intent(out) :: error 295 | 296 | call check(error, d2fixed(0.2509765625_real64, 3), "0.251") 297 | if (allocated(error)) return 298 | 299 | end subroutine test_non_round_to_even_scenarios_value4 300 | 301 | subroutine test_non_round_to_even_scenarios_value5(error) 302 | type(error_type), allocatable, intent(out) :: error 303 | 304 | call check(error, d2fixed(0.2509765625_real64, 2), "0.25") 305 | if (allocated(error)) return 306 | 307 | end subroutine test_non_round_to_even_scenarios_value5 308 | 309 | subroutine test_non_round_to_even_scenarios_value6(error) 310 | type(error_type), allocatable, intent(out) :: error 311 | 312 | call check(error, d2fixed(0.2509765625_real64, 1), "0.3") 313 | if (allocated(error)) return 314 | 315 | end subroutine test_non_round_to_even_scenarios_value6 316 | 317 | subroutine test_non_round_to_even_scenarios_value7(error) 318 | type(error_type), allocatable, intent(out) :: error 319 | 320 | call check(error, d2fixed(ieee_part_to_real64(.false., 1021, 1_int64), 54), & 321 | "0.250000000000000055511151231257827021181583404541015625") 322 | if (allocated(error)) return 323 | 324 | end subroutine test_non_round_to_even_scenarios_value7 325 | 326 | subroutine test_non_round_to_even_scenarios_value8(error) 327 | type(error_type), allocatable, intent(out) :: error 328 | 329 | call check(error, d2fixed(ieee_part_to_real64(.false., 1021, 1_int64), 3), "0.250") 330 | if (allocated(error)) return 331 | 332 | end subroutine test_non_round_to_even_scenarios_value8 333 | 334 | subroutine test_non_round_to_even_scenarios_value9(error) 335 | type(error_type), allocatable, intent(out) :: error 336 | 337 | call check(error, d2fixed(ieee_part_to_real64(.false., 1021, 1_int64), 2), "0.25") 338 | if (allocated(error)) return 339 | 340 | end subroutine test_non_round_to_even_scenarios_value9 341 | 342 | subroutine test_non_round_to_even_scenarios_value10(error) 343 | type(error_type), allocatable, intent(out) :: error 344 | 345 | call check(error, d2fixed(ieee_part_to_real64(.false., 1021, 1_int64), 1), "0.3") 346 | if (allocated(error)) return 347 | 348 | end subroutine test_non_round_to_even_scenarios_value10 349 | 350 | !> ============================================================================= 351 | 352 | subroutine collect_varying_precision(testsuite) 353 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 354 | 355 | testsuite = [ & 356 | new_unittest("value1", test_varying_precision_value1), & 357 | new_unittest("value2", test_varying_precision_value2), & 358 | new_unittest("value3", test_varying_precision_value3), & 359 | new_unittest("value4", test_varying_precision_value4), & 360 | new_unittest("value5", test_varying_precision_value5), & 361 | new_unittest("value6", test_varying_precision_value6), & 362 | new_unittest("value7", test_varying_precision_value7), & 363 | new_unittest("value8", test_varying_precision_value8), & 364 | new_unittest("value9", test_varying_precision_value9), & 365 | new_unittest("value10", test_varying_precision_value10), & 366 | new_unittest("value11", test_varying_precision_value11), & 367 | new_unittest("value12", test_varying_precision_value12), & 368 | new_unittest("value13", test_varying_precision_value13), & 369 | new_unittest("value14", test_varying_precision_value14), & 370 | new_unittest("value15", test_varying_precision_value15), & 371 | new_unittest("value16", test_varying_precision_value16), & 372 | new_unittest("value17", test_varying_precision_value17), & 373 | new_unittest("value18", test_varying_precision_value18), & 374 | new_unittest("value19", test_varying_precision_value19), & 375 | new_unittest("value20", test_varying_precision_value20), & 376 | new_unittest("value21", test_varying_precision_value21), & 377 | new_unittest("value22", test_varying_precision_value22), & 378 | new_unittest("value23", test_varying_precision_value23), & 379 | new_unittest("value24", test_varying_precision_value24), & 380 | new_unittest("value25", test_varying_precision_value25), & 381 | new_unittest("value26", test_varying_precision_value26), & 382 | new_unittest("value27", test_varying_precision_value27), & 383 | new_unittest("value28", test_varying_precision_value28), & 384 | new_unittest("value29", test_varying_precision_value29), & 385 | new_unittest("value30", test_varying_precision_value30), & 386 | new_unittest("value31", test_varying_precision_value31), & 387 | new_unittest("value32", test_varying_precision_value32), & 388 | new_unittest("value33", test_varying_precision_value33), & 389 | new_unittest("value34", test_varying_precision_value34), & 390 | new_unittest("value35", test_varying_precision_value35), & 391 | new_unittest("value36", test_varying_precision_value36), & 392 | new_unittest("value37", test_varying_precision_value37), & 393 | new_unittest("value38", test_varying_precision_value38), & 394 | new_unittest("value39", test_varying_precision_value39), & 395 | new_unittest("value40", test_varying_precision_value40), & 396 | new_unittest("value41", test_varying_precision_value41), & 397 | new_unittest("value42", test_varying_precision_value42), & 398 | new_unittest("value43", test_varying_precision_value43), & 399 | new_unittest("value44", test_varying_precision_value44), & 400 | new_unittest("value45", test_varying_precision_value45), & 401 | new_unittest("value46", test_varying_precision_value46), & 402 | new_unittest("value47", test_varying_precision_value47), & 403 | new_unittest("value48", test_varying_precision_value48) & 404 | ] 405 | 406 | end subroutine collect_varying_precision 407 | 408 | subroutine test_varying_precision_value1(error) 409 | type(error_type), allocatable, intent(out) :: error 410 | call check(error, d2fixed(1729.142857142857_real64, 47), & 411 | "1729.14285714285711037518922239542007446289062500000") 412 | if (allocated(error)) return 413 | end subroutine test_varying_precision_value1 414 | 415 | subroutine test_varying_precision_value2(error) 416 | type(error_type), allocatable, intent(out) :: error 417 | call check(error, d2fixed(1729.142857142857_real64, 46), & 418 | "1729.1428571428571103751892223954200744628906250000") 419 | if (allocated(error)) return 420 | end subroutine test_varying_precision_value2 421 | 422 | subroutine test_varying_precision_value3(error) 423 | type(error_type), allocatable, intent(out) :: error 424 | call check(error, d2fixed(1729.142857142857_real64, 45), & 425 | "1729.142857142857110375189222395420074462890625000") 426 | if (allocated(error)) return 427 | end subroutine test_varying_precision_value3 428 | 429 | subroutine test_varying_precision_value4(error) 430 | type(error_type), allocatable, intent(out) :: error 431 | call check(error, d2fixed(1729.142857142857_real64, 44), & 432 | "1729.14285714285711037518922239542007446289062500") 433 | if (allocated(error)) return 434 | end subroutine test_varying_precision_value4 435 | 436 | subroutine test_varying_precision_value5(error) 437 | type(error_type), allocatable, intent(out) :: error 438 | call check(error, d2fixed(1729.142857142857_real64, 43), & 439 | "1729.1428571428571103751892223954200744628906250") 440 | if (allocated(error)) return 441 | end subroutine test_varying_precision_value5 442 | 443 | subroutine test_varying_precision_value6(error) 444 | type(error_type), allocatable, intent(out) :: error 445 | call check(error, d2fixed(1729.142857142857_real64, 42), & 446 | "1729.142857142857110375189222395420074462890625") 447 | if (allocated(error)) return 448 | end subroutine test_varying_precision_value6 449 | 450 | subroutine test_varying_precision_value7(error) 451 | type(error_type), allocatable, intent(out) :: error 452 | call check(error, d2fixed(1729.142857142857_real64, 41), "1729.14285714285711037518922239542007446289062") 453 | if (allocated(error)) return 454 | end subroutine test_varying_precision_value7 455 | 456 | subroutine test_varying_precision_value8(error) 457 | type(error_type), allocatable, intent(out) :: error 458 | call check(error, d2fixed(1729.142857142857_real64, 40), "1729.1428571428571103751892223954200744628906") 459 | if (allocated(error)) return 460 | end subroutine test_varying_precision_value8 461 | 462 | subroutine test_varying_precision_value9(error) 463 | type(error_type), allocatable, intent(out) :: error 464 | call check(error, d2fixed(1729.142857142857_real64, 39), "1729.142857142857110375189222395420074462891") 465 | if (allocated(error)) return 466 | end subroutine test_varying_precision_value9 467 | 468 | subroutine test_varying_precision_value10(error) 469 | type(error_type), allocatable, intent(out) :: error 470 | call check(error, d2fixed(1729.142857142857_real64, 38), "1729.14285714285711037518922239542007446289") 471 | if (allocated(error)) return 472 | end subroutine test_varying_precision_value10 473 | 474 | subroutine test_varying_precision_value11(error) 475 | type(error_type), allocatable, intent(out) :: error 476 | call check(error, d2fixed(1729.142857142857_real64, 37), "1729.1428571428571103751892223954200744629") 477 | if (allocated(error)) return 478 | end subroutine test_varying_precision_value11 479 | 480 | subroutine test_varying_precision_value12(error) 481 | type(error_type), allocatable, intent(out) :: error 482 | call check(error, d2fixed(1729.142857142857_real64, 36), "1729.142857142857110375189222395420074463") 483 | if (allocated(error)) return 484 | end subroutine test_varying_precision_value12 485 | 486 | subroutine test_varying_precision_value13(error) 487 | type(error_type), allocatable, intent(out) :: error 488 | call check(error, d2fixed(1729.142857142857_real64, 35), "1729.14285714285711037518922239542007446") 489 | if (allocated(error)) return 490 | end subroutine test_varying_precision_value13 491 | 492 | subroutine test_varying_precision_value14(error) 493 | type(error_type), allocatable, intent(out) :: error 494 | call check(error, d2fixed(1729.142857142857_real64, 34), "1729.1428571428571103751892223954200745") 495 | if (allocated(error)) return 496 | end subroutine test_varying_precision_value14 497 | 498 | subroutine test_varying_precision_value15(error) 499 | type(error_type), allocatable, intent(out) :: error 500 | call check(error, d2fixed(1729.142857142857_real64, 33), "1729.142857142857110375189222395420074") 501 | if (allocated(error)) return 502 | end subroutine test_varying_precision_value15 503 | 504 | subroutine test_varying_precision_value16(error) 505 | type(error_type), allocatable, intent(out) :: error 506 | call check(error, d2fixed(1729.142857142857_real64, 32), "1729.14285714285711037518922239542007") 507 | if (allocated(error)) return 508 | end subroutine test_varying_precision_value16 509 | 510 | subroutine test_varying_precision_value17(error) 511 | type(error_type), allocatable, intent(out) :: error 512 | call check(error, d2fixed(1729.142857142857_real64, 31), "1729.1428571428571103751892223954201") 513 | if (allocated(error)) return 514 | end subroutine test_varying_precision_value17 515 | 516 | subroutine test_varying_precision_value18(error) 517 | type(error_type), allocatable, intent(out) :: error 518 | call check(error, d2fixed(1729.142857142857_real64, 30), "1729.142857142857110375189222395420") 519 | if (allocated(error)) return 520 | end subroutine test_varying_precision_value18 521 | 522 | subroutine test_varying_precision_value19(error) 523 | type(error_type), allocatable, intent(out) :: error 524 | call check(error, d2fixed(1729.142857142857_real64, 29), "1729.14285714285711037518922239542") 525 | if (allocated(error)) return 526 | end subroutine test_varying_precision_value19 527 | 528 | subroutine test_varying_precision_value20(error) 529 | type(error_type), allocatable, intent(out) :: error 530 | call check(error, d2fixed(1729.142857142857_real64, 28), "1729.1428571428571103751892223954") 531 | if (allocated(error)) return 532 | end subroutine test_varying_precision_value20 533 | 534 | subroutine test_varying_precision_value21(error) 535 | type(error_type), allocatable, intent(out) :: error 536 | call check(error, d2fixed(1729.142857142857_real64, 27), "1729.142857142857110375189222395") 537 | if (allocated(error)) return 538 | end subroutine test_varying_precision_value21 539 | 540 | subroutine test_varying_precision_value22(error) 541 | type(error_type), allocatable, intent(out) :: error 542 | call check(error, d2fixed(1729.142857142857_real64, 26), "1729.14285714285711037518922240") 543 | if (allocated(error)) return 544 | end subroutine test_varying_precision_value22 545 | 546 | subroutine test_varying_precision_value23(error) 547 | type(error_type), allocatable, intent(out) :: error 548 | call check(error, d2fixed(1729.142857142857_real64, 25), "1729.1428571428571103751892224") 549 | if (allocated(error)) return 550 | end subroutine test_varying_precision_value23 551 | 552 | subroutine test_varying_precision_value24(error) 553 | type(error_type), allocatable, intent(out) :: error 554 | call check(error, d2fixed(1729.142857142857_real64, 24), "1729.142857142857110375189222") 555 | if (allocated(error)) return 556 | end subroutine test_varying_precision_value24 557 | 558 | subroutine test_varying_precision_value25(error) 559 | type(error_type), allocatable, intent(out) :: error 560 | call check(error, d2fixed(1729.142857142857_real64, 23), "1729.14285714285711037518922") 561 | if (allocated(error)) return 562 | end subroutine test_varying_precision_value25 563 | 564 | subroutine test_varying_precision_value26(error) 565 | type(error_type), allocatable, intent(out) :: error 566 | call check(error, d2fixed(1729.142857142857_real64, 22), "1729.1428571428571103751892") 567 | if (allocated(error)) return 568 | end subroutine test_varying_precision_value26 569 | 570 | subroutine test_varying_precision_value27(error) 571 | type(error_type), allocatable, intent(out) :: error 572 | call check(error, d2fixed(1729.142857142857_real64, 21), "1729.142857142857110375189") 573 | if (allocated(error)) return 574 | end subroutine test_varying_precision_value27 575 | 576 | subroutine test_varying_precision_value28(error) 577 | type(error_type), allocatable, intent(out) :: error 578 | call check(error, d2fixed(1729.142857142857_real64, 20), "1729.14285714285711037519") 579 | if (allocated(error)) return 580 | end subroutine test_varying_precision_value28 581 | 582 | subroutine test_varying_precision_value29(error) 583 | type(error_type), allocatable, intent(out) :: error 584 | call check(error, d2fixed(1729.142857142857_real64, 19), "1729.1428571428571103752") 585 | if (allocated(error)) return 586 | end subroutine test_varying_precision_value29 587 | 588 | subroutine test_varying_precision_value30(error) 589 | type(error_type), allocatable, intent(out) :: error 590 | call check(error, d2fixed(1729.142857142857_real64, 18), "1729.142857142857110375") 591 | if (allocated(error)) return 592 | end subroutine test_varying_precision_value30 593 | 594 | subroutine test_varying_precision_value31(error) 595 | type(error_type), allocatable, intent(out) :: error 596 | call check(error, d2fixed(1729.142857142857_real64, 17), "1729.14285714285711038") 597 | if (allocated(error)) return 598 | end subroutine test_varying_precision_value31 599 | 600 | subroutine test_varying_precision_value32(error) 601 | type(error_type), allocatable, intent(out) :: error 602 | call check(error, d2fixed(1729.142857142857_real64, 16), "1729.1428571428571104") 603 | if (allocated(error)) return 604 | end subroutine test_varying_precision_value32 605 | 606 | subroutine test_varying_precision_value33(error) 607 | type(error_type), allocatable, intent(out) :: error 608 | call check(error, d2fixed(1729.142857142857_real64, 15), "1729.142857142857110") 609 | if (allocated(error)) return 610 | end subroutine test_varying_precision_value33 611 | 612 | subroutine test_varying_precision_value34(error) 613 | type(error_type), allocatable, intent(out) :: error 614 | call check(error, d2fixed(1729.142857142857_real64, 14), "1729.14285714285711") 615 | if (allocated(error)) return 616 | end subroutine test_varying_precision_value34 617 | 618 | subroutine test_varying_precision_value35(error) 619 | type(error_type), allocatable, intent(out) :: error 620 | call check(error, d2fixed(1729.142857142857_real64, 13), "1729.1428571428571") 621 | if (allocated(error)) return 622 | end subroutine test_varying_precision_value35 623 | 624 | subroutine test_varying_precision_value36(error) 625 | type(error_type), allocatable, intent(out) :: error 626 | call check(error, d2fixed(1729.142857142857_real64, 12), "1729.142857142857") 627 | if (allocated(error)) return 628 | end subroutine test_varying_precision_value36 629 | 630 | subroutine test_varying_precision_value37(error) 631 | type(error_type), allocatable, intent(out) :: error 632 | call check(error, d2fixed(1729.142857142857_real64, 11), "1729.14285714286") 633 | if (allocated(error)) return 634 | end subroutine test_varying_precision_value37 635 | 636 | subroutine test_varying_precision_value38(error) 637 | type(error_type), allocatable, intent(out) :: error 638 | call check(error, d2fixed(1729.142857142857_real64, 10), "1729.1428571429") 639 | if (allocated(error)) return 640 | end subroutine test_varying_precision_value38 641 | 642 | subroutine test_varying_precision_value39(error) 643 | type(error_type), allocatable, intent(out) :: error 644 | call check(error, d2fixed(1729.142857142857_real64, 9), "1729.142857143") 645 | if (allocated(error)) return 646 | end subroutine test_varying_precision_value39 647 | 648 | subroutine test_varying_precision_value40(error) 649 | type(error_type), allocatable, intent(out) :: error 650 | call check(error, d2fixed(1729.142857142857_real64, 8), "1729.14285714") 651 | if (allocated(error)) return 652 | end subroutine test_varying_precision_value40 653 | 654 | subroutine test_varying_precision_value41(error) 655 | type(error_type), allocatable, intent(out) :: error 656 | call check(error, d2fixed(1729.142857142857_real64, 7), "1729.1428571") 657 | if (allocated(error)) return 658 | end subroutine test_varying_precision_value41 659 | 660 | subroutine test_varying_precision_value42(error) 661 | type(error_type), allocatable, intent(out) :: error 662 | call check(error, d2fixed(1729.142857142857_real64, 6), "1729.142857") 663 | if (allocated(error)) return 664 | end subroutine test_varying_precision_value42 665 | 666 | subroutine test_varying_precision_value43(error) 667 | type(error_type), allocatable, intent(out) :: error 668 | call check(error, d2fixed(1729.142857142857_real64, 5), "1729.14286") 669 | if (allocated(error)) return 670 | end subroutine test_varying_precision_value43 671 | 672 | subroutine test_varying_precision_value44(error) 673 | type(error_type), allocatable, intent(out) :: error 674 | call check(error, d2fixed(1729.142857142857_real64, 4), "1729.1429") 675 | if (allocated(error)) return 676 | end subroutine test_varying_precision_value44 677 | 678 | subroutine test_varying_precision_value45(error) 679 | type(error_type), allocatable, intent(out) :: error 680 | call check(error, d2fixed(1729.142857142857_real64, 3), "1729.143") 681 | if (allocated(error)) return 682 | end subroutine test_varying_precision_value45 683 | 684 | subroutine test_varying_precision_value46(error) 685 | type(error_type), allocatable, intent(out) :: error 686 | call check(error, d2fixed(1729.142857142857_real64, 2), "1729.14") 687 | if (allocated(error)) return 688 | end subroutine test_varying_precision_value46 689 | 690 | subroutine test_varying_precision_value47(error) 691 | type(error_type), allocatable, intent(out) :: error 692 | call check(error, d2fixed(1729.142857142857_real64, 1), "1729.1") 693 | if (allocated(error)) return 694 | end subroutine test_varying_precision_value47 695 | 696 | subroutine test_varying_precision_value48(error) 697 | type(error_type), allocatable, intent(out) :: error 698 | call check(error, d2fixed(1729.142857142857_real64, 0), "1729") 699 | if (allocated(error)) return 700 | end subroutine test_varying_precision_value48 701 | 702 | !> ============================================================================= 703 | 704 | subroutine collect_carrying(testsuite) 705 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 706 | 707 | testsuite = [ & 708 | new_unittest("value1", test_carrying_value1), & 709 | new_unittest("value2", test_carrying_value2), & 710 | new_unittest("value3", test_carrying_value3), & 711 | new_unittest("value4", test_carrying_value4), & 712 | new_unittest("value5", test_carrying_value5), & 713 | new_unittest("value6", test_carrying_value6), & 714 | new_unittest("value7", test_carrying_value7), & 715 | new_unittest("value8", test_carrying_value8), & 716 | new_unittest("value9", test_carrying_value9), & 717 | new_unittest("value10", test_carrying_value10), & 718 | new_unittest("value11", test_carrying_value11), & 719 | new_unittest("value12", test_carrying_value12), & 720 | new_unittest("value13", test_carrying_value13), & 721 | new_unittest("value14", test_carrying_value14), & 722 | new_unittest("value15", test_carrying_value15), & 723 | new_unittest("value16", test_carrying_value16), & 724 | new_unittest("value17", test_carrying_value17), & 725 | new_unittest("value18", test_carrying_value18), & 726 | new_unittest("value19", test_carrying_value19), & 727 | new_unittest("value20", test_carrying_value20), & 728 | new_unittest("value21", test_carrying_value21), & 729 | new_unittest("value22", test_carrying_value22) & 730 | ] 731 | 732 | end subroutine collect_carrying 733 | 734 | subroutine test_carrying_value1(error) 735 | type(error_type), allocatable, intent(out) :: error 736 | call check(error, d2fixed(0.0009_real64, 4), "0.0009") 737 | if (allocated(error)) return 738 | end subroutine test_carrying_value1 739 | 740 | subroutine test_carrying_value2(error) 741 | type(error_type), allocatable, intent(out) :: error 742 | call check(error, d2fixed(0.0009_real64, 3), "0.001") 743 | if (allocated(error)) return 744 | end subroutine test_carrying_value2 745 | 746 | subroutine test_carrying_value3(error) 747 | type(error_type), allocatable, intent(out) :: error 748 | call check(error, d2fixed(0.0029_real64, 4), "0.0029") 749 | if (allocated(error)) return 750 | end subroutine test_carrying_value3 751 | 752 | subroutine test_carrying_value4(error) 753 | type(error_type), allocatable, intent(out) :: error 754 | call check(error, d2fixed(0.0029_real64, 3), "0.003") 755 | if (allocated(error)) return 756 | end subroutine test_carrying_value4 757 | 758 | subroutine test_carrying_value5(error) 759 | type(error_type), allocatable, intent(out) :: error 760 | call check(error, d2fixed(0.0099_real64, 4), "0.0099") 761 | if (allocated(error)) return 762 | end subroutine test_carrying_value5 763 | 764 | subroutine test_carrying_value6(error) 765 | type(error_type), allocatable, intent(out) :: error 766 | call check(error, d2fixed(0.0099_real64, 3), "0.010") 767 | if (allocated(error)) return 768 | end subroutine test_carrying_value6 769 | 770 | subroutine test_carrying_value7(error) 771 | type(error_type), allocatable, intent(out) :: error 772 | call check(error, d2fixed(0.0299_real64, 4), "0.0299") 773 | if (allocated(error)) return 774 | end subroutine test_carrying_value7 775 | 776 | subroutine test_carrying_value8(error) 777 | type(error_type), allocatable, intent(out) :: error 778 | call check(error, d2fixed(0.0299_real64, 3), "0.030") 779 | if (allocated(error)) return 780 | end subroutine test_carrying_value8 781 | 782 | subroutine test_carrying_value9(error) 783 | type(error_type), allocatable, intent(out) :: error 784 | call check(error, d2fixed(0.0999_real64, 4), "0.0999") 785 | if (allocated(error)) return 786 | end subroutine test_carrying_value9 787 | 788 | subroutine test_carrying_value10(error) 789 | type(error_type), allocatable, intent(out) :: error 790 | call check(error, d2fixed(0.0999_real64, 3), "0.100") 791 | if (allocated(error)) return 792 | end subroutine test_carrying_value10 793 | 794 | subroutine test_carrying_value11(error) 795 | type(error_type), allocatable, intent(out) :: error 796 | call check(error, d2fixed(0.2999_real64, 4), "0.2999") 797 | if (allocated(error)) return 798 | end subroutine test_carrying_value11 799 | 800 | subroutine test_carrying_value12(error) 801 | type(error_type), allocatable, intent(out) :: error 802 | call check(error, d2fixed(0.2999_real64, 3), "0.300") 803 | if (allocated(error)) return 804 | end subroutine test_carrying_value12 805 | 806 | subroutine test_carrying_value13(error) 807 | type(error_type), allocatable, intent(out) :: error 808 | call check(error, d2fixed(0.9999_real64, 4), "0.9999") 809 | if (allocated(error)) return 810 | end subroutine test_carrying_value13 811 | 812 | subroutine test_carrying_value14(error) 813 | type(error_type), allocatable, intent(out) :: error 814 | call check(error, d2fixed(0.9999_real64, 3), "1.000") 815 | if (allocated(error)) return 816 | end subroutine test_carrying_value14 817 | 818 | subroutine test_carrying_value15(error) 819 | type(error_type), allocatable, intent(out) :: error 820 | call check(error, d2fixed(2.9999_real64, 4), "2.9999") 821 | if (allocated(error)) return 822 | end subroutine test_carrying_value15 823 | 824 | subroutine test_carrying_value16(error) 825 | type(error_type), allocatable, intent(out) :: error 826 | call check(error, d2fixed(2.9999_real64, 3), "3.000") 827 | if (allocated(error)) return 828 | end subroutine test_carrying_value16 829 | 830 | subroutine test_carrying_value17(error) 831 | type(error_type), allocatable, intent(out) :: error 832 | call check(error, d2fixed(9.9999_real64, 4), "9.9999") 833 | if (allocated(error)) return 834 | end subroutine test_carrying_value17 835 | 836 | subroutine test_carrying_value18(error) 837 | type(error_type), allocatable, intent(out) :: error 838 | call check(error, d2fixed(9.9999_real64, 3), "10.000") 839 | if (allocated(error)) return 840 | end subroutine test_carrying_value18 841 | 842 | subroutine test_carrying_value19(error) 843 | type(error_type), allocatable, intent(out) :: error 844 | call check(error, d2fixed(29.9999_real64, 4), "29.9999") 845 | if (allocated(error)) return 846 | end subroutine test_carrying_value19 847 | 848 | subroutine test_carrying_value20(error) 849 | type(error_type), allocatable, intent(out) :: error 850 | call check(error, d2fixed(29.9999_real64, 3), "30.000") 851 | if (allocated(error)) return 852 | end subroutine test_carrying_value20 853 | 854 | subroutine test_carrying_value21(error) 855 | type(error_type), allocatable, intent(out) :: error 856 | call check(error, d2fixed(99.9999_real64, 4), "99.9999") 857 | if (allocated(error)) return 858 | end subroutine test_carrying_value21 859 | 860 | subroutine test_carrying_value22(error) 861 | type(error_type), allocatable, intent(out) :: error 862 | call check(error, d2fixed(99.9999_real64, 3), "100.000") 863 | if (allocated(error)) return 864 | end subroutine test_carrying_value22 865 | 866 | subroutine test_carrying_value23(error) 867 | type(error_type), allocatable, intent(out) :: error 868 | call check(error, d2fixed(299.9999_real64, 4), "299.9999") 869 | if (allocated(error)) return 870 | end subroutine test_carrying_value23 871 | 872 | subroutine test_carrying_value24(error) 873 | type(error_type), allocatable, intent(out) :: error 874 | call check(error, d2fixed(299.9999_real64, 3), "300.000") 875 | if (allocated(error)) return 876 | end subroutine test_carrying_value24 877 | 878 | subroutine test_carrying_value25(error) 879 | type(error_type), allocatable, intent(out) :: error 880 | call check(error, d2fixed(0.09_real64, 2), "0.09") 881 | if (allocated(error)) return 882 | end subroutine test_carrying_value25 883 | 884 | subroutine test_carrying_value26(error) 885 | type(error_type), allocatable, intent(out) :: error 886 | call check(error, d2fixed(0.09_real64, 1), "0.1") 887 | if (allocated(error)) return 888 | end subroutine test_carrying_value26 889 | 890 | subroutine test_carrying_value27(error) 891 | type(error_type), allocatable, intent(out) :: error 892 | call check(error, d2fixed(0.29_real64, 2), "0.29") 893 | if (allocated(error)) return 894 | end subroutine test_carrying_value27 895 | 896 | subroutine test_carrying_value28(error) 897 | type(error_type), allocatable, intent(out) :: error 898 | call check(error, d2fixed(0.29_real64, 1), "0.3") 899 | if (allocated(error)) return 900 | end subroutine test_carrying_value28 901 | 902 | subroutine test_carrying_value29(error) 903 | type(error_type), allocatable, intent(out) :: error 904 | call check(error, d2fixed(0.99_real64, 2), "0.99") 905 | if (allocated(error)) return 906 | end subroutine test_carrying_value29 907 | 908 | subroutine test_carrying_value30(error) 909 | type(error_type), allocatable, intent(out) :: error 910 | call check(error, d2fixed(0.99_real64, 1), "1.0") 911 | if (allocated(error)) return 912 | end subroutine test_carrying_value30 913 | 914 | subroutine test_carrying_value31(error) 915 | type(error_type), allocatable, intent(out) :: error 916 | call check(error, d2fixed(2.99_real64, 2), "2.99") 917 | if (allocated(error)) return 918 | end subroutine test_carrying_value31 919 | 920 | subroutine test_carrying_value32(error) 921 | type(error_type), allocatable, intent(out) :: error 922 | call check(error, d2fixed(2.99_real64, 1), "3.0") 923 | if (allocated(error)) return 924 | end subroutine test_carrying_value32 925 | 926 | subroutine test_carrying_value33(error) 927 | type(error_type), allocatable, intent(out) :: error 928 | call check(error, d2fixed(9.99_real64, 2), "9.99") 929 | if (allocated(error)) return 930 | end subroutine test_carrying_value33 931 | 932 | subroutine test_carrying_value34(error) 933 | type(error_type), allocatable, intent(out) :: error 934 | call check(error, d2fixed(9.99_real64, 1), "10.0") 935 | if (allocated(error)) return 936 | end subroutine test_carrying_value34 937 | 938 | subroutine test_carrying_value35(error) 939 | type(error_type), allocatable, intent(out) :: error 940 | call check(error, d2fixed(29.99_real64, 2), "29.99") 941 | if (allocated(error)) return 942 | end subroutine test_carrying_value35 943 | 944 | subroutine test_carrying_value36(error) 945 | type(error_type), allocatable, intent(out) :: error 946 | call check(error, d2fixed(29.99_real64, 1), "30.0") 947 | if (allocated(error)) return 948 | end subroutine test_carrying_value36 949 | 950 | subroutine test_carrying_value37(error) 951 | type(error_type), allocatable, intent(out) :: error 952 | call check(error, d2fixed(99.99_real64, 2), "99.99") 953 | if (allocated(error)) return 954 | end subroutine test_carrying_value37 955 | 956 | subroutine test_carrying_value38(error) 957 | type(error_type), allocatable, intent(out) :: error 958 | call check(error, d2fixed(99.99_real64, 1), "100.0") 959 | if (allocated(error)) return 960 | end subroutine test_carrying_value38 961 | 962 | subroutine test_carrying_value39(error) 963 | type(error_type), allocatable, intent(out) :: error 964 | call check(error, d2fixed(299.99_real64, 2), "299.99") 965 | if (allocated(error)) return 966 | end subroutine test_carrying_value39 967 | 968 | subroutine test_carrying_value40(error) 969 | type(error_type), allocatable, intent(out) :: error 970 | call check(error, d2fixed(299.99_real64, 1), "300.0") 971 | if (allocated(error)) return 972 | end subroutine test_carrying_value40 973 | 974 | subroutine test_carrying_value41(error) 975 | type(error_type), allocatable, intent(out) :: error 976 | call check(error, d2fixed(0.9_real64, 1), "0.9") 977 | if (allocated(error)) return 978 | end subroutine test_carrying_value41 979 | 980 | subroutine test_carrying_value42(error) 981 | type(error_type), allocatable, intent(out) :: error 982 | call check(error, d2fixed(0.9_real64, 0), "1") 983 | if (allocated(error)) return 984 | end subroutine test_carrying_value42 985 | 986 | subroutine test_carrying_value43(error) 987 | type(error_type), allocatable, intent(out) :: error 988 | call check(error, d2fixed(2.9_real64, 1), "2.9") 989 | if (allocated(error)) return 990 | end subroutine test_carrying_value43 991 | 992 | subroutine test_carrying_value44(error) 993 | type(error_type), allocatable, intent(out) :: error 994 | call check(error, d2fixed(2.9_real64, 0), "3") 995 | if (allocated(error)) return 996 | end subroutine test_carrying_value44 997 | 998 | subroutine test_carrying_value45(error) 999 | type(error_type), allocatable, intent(out) :: error 1000 | call check(error, d2fixed(9.9_real64, 1), "9.9") 1001 | if (allocated(error)) return 1002 | end subroutine test_carrying_value45 1003 | 1004 | subroutine test_carrying_value46(error) 1005 | type(error_type), allocatable, intent(out) :: error 1006 | call check(error, d2fixed(9.9_real64, 0), "10") 1007 | if (allocated(error)) return 1008 | end subroutine test_carrying_value46 1009 | 1010 | subroutine test_carrying_value47(error) 1011 | type(error_type), allocatable, intent(out) :: error 1012 | call check(error, d2fixed(29.9_real64, 1), "29.9") 1013 | if (allocated(error)) return 1014 | end subroutine test_carrying_value47 1015 | 1016 | subroutine test_carrying_value48(error) 1017 | type(error_type), allocatable, intent(out) :: error 1018 | call check(error, d2fixed(29.9_real64, 0), "30") 1019 | if (allocated(error)) return 1020 | end subroutine test_carrying_value48 1021 | 1022 | !> ============================================================================= 1023 | 1024 | subroutine collect_rounding_result_zero(testsuite) 1025 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 1026 | 1027 | testsuite = [ & 1028 | new_unittest("value1", test_rounding_result_zero_value1), & 1029 | new_unittest("value2", test_rounding_result_zero_value2), & 1030 | new_unittest("value3", test_rounding_result_zero_value3), & 1031 | new_unittest("value4", test_rounding_result_zero_value4), & 1032 | new_unittest("value5", test_rounding_result_zero_value5), & 1033 | new_unittest("value6", test_rounding_result_zero_value6) & 1034 | ] 1035 | 1036 | end subroutine collect_rounding_result_zero 1037 | 1038 | subroutine test_rounding_result_zero_value1(error) 1039 | type(error_type), allocatable, intent(out) :: error 1040 | call check(error, d2fixed(0.004_real64, 3), "0.004") 1041 | if (allocated(error)) return 1042 | end subroutine test_rounding_result_zero_value1 1043 | 1044 | subroutine test_rounding_result_zero_value2(error) 1045 | type(error_type), allocatable, intent(out) :: error 1046 | call check(error, d2fixed(0.004_real64, 2), "0.00") 1047 | if (allocated(error)) return 1048 | end subroutine test_rounding_result_zero_value2 1049 | 1050 | subroutine test_rounding_result_zero_value3(error) 1051 | type(error_type), allocatable, intent(out) :: error 1052 | call check(error, d2fixed(0.4_real64, 1), "0.4") 1053 | if (allocated(error)) return 1054 | end subroutine test_rounding_result_zero_value3 1055 | 1056 | subroutine test_rounding_result_zero_value4(error) 1057 | type(error_type), allocatable, intent(out) :: error 1058 | call check(error, d2fixed(0.4_real64, 0), "0") 1059 | if (allocated(error)) return 1060 | end subroutine test_rounding_result_zero_value4 1061 | 1062 | subroutine test_rounding_result_zero_value5(error) 1063 | type(error_type), allocatable, intent(out) :: error 1064 | call check(error, d2fixed(0.5_real64, 1), "0.5") 1065 | if (allocated(error)) return 1066 | end subroutine test_rounding_result_zero_value5 1067 | 1068 | subroutine test_rounding_result_zero_value6(error) 1069 | type(error_type), allocatable, intent(out) :: error 1070 | call check(error, d2fixed(0.5_real64, 0), "0") 1071 | if (allocated(error)) return 1072 | end subroutine test_rounding_result_zero_value6 1073 | 1074 | !> ============================================================================= 1075 | 1076 | subroutine collect_regression(testsuite) 1077 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 1078 | 1079 | testsuite = [ & 1080 | new_unittest("value1", test_regression_value1) & 1081 | ] 1082 | 1083 | end subroutine collect_regression 1084 | 1085 | subroutine test_regression_value1(error) 1086 | type(error_type), allocatable, intent(out) :: error 1087 | 1088 | call check(error, d2fixed(7.018232e-82_real64, 6), "0.000000") 1089 | if (allocated(error)) return 1090 | 1091 | end subroutine test_regression_value1 1092 | 1093 | end module test_d2fixed 1094 | -------------------------------------------------------------------------------- /test/test_d2fixed/tester.f90: -------------------------------------------------------------------------------- 1 | program main 2 | use testdrive 3 | use iso_fortran_env 4 | use test_d2fixed 5 | implicit none 6 | integer :: stat, is 7 | type(testsuite_type), dimension(:), allocatable :: testsuites 8 | character(len=*), parameter :: fmt = '("#", *(1x, a))' 9 | 10 | stat = 0 11 | 12 | testsuites = [ & 13 | new_testsuite("test_basic", collect_basic), & 14 | new_testsuite("test_zeros", collect_zeros), & 15 | new_testsuite("test_max_and_min", collect_max_and_min), & 16 | new_testsuite("test_round_to_even", collect_round_to_even), & 17 | new_testsuite("test_round_to_even_integer", collect_round_to_even_integer), & 18 | new_testsuite("test_non_round_to_even_scenarios", collect_non_round_to_even_scenarios), & 19 | new_testsuite("test_varying_precision", collect_varying_precision), & 20 | new_testsuite("test_carrying", collect_carrying), & 21 | new_testsuite("test_rounding_result_zero", collect_rounding_result_zero), & 22 | new_testsuite("test_regression", collect_regression) & 23 | ] 24 | 25 | do is = 1, size(testsuites) 26 | write (error_unit, fmt) "Testing:", testsuites(is)%name 27 | call run_testsuite(testsuites(is)%collect, error_unit, stat) 28 | end do 29 | 30 | if (stat > 0) then 31 | write (error_unit, '(i0, 1x, a)') stat, "test(s) failed!" 32 | error stop 33 | end if 34 | 35 | end program main -------------------------------------------------------------------------------- /test/test_d2shortest/tester.f90: -------------------------------------------------------------------------------- 1 | program main 2 | use testdrive 3 | use iso_fortran_env 4 | use test_d2shortest 5 | implicit none 6 | integer :: stat, is 7 | type(testsuite_type), dimension(:), allocatable :: testsuites 8 | character(len=*), parameter :: fmt = '("#", *(1x, a))' 9 | 10 | stat = 0 11 | 12 | testsuites = [ & 13 | new_testsuite("test_basic", collect_basic), & 14 | new_testsuite("test_subnormal", collect_subnormal), & 15 | new_testsuite("test_max_and_min", collect_max_and_min), & 16 | new_testsuite("test_trailing_zeros", collect_trailing_zeros), & 17 | new_testsuite("test_regression", collect_regression), & 18 | new_testsuite("test_looks_like_pow5", collect_looks_like_pow5), & 19 | new_testsuite("test_output_length", collect_output_length), & 20 | new_testsuite("test_min_max_shift", collect_min_max_shift), & 21 | new_testsuite("test_small_integers", collect_small_integers) & 22 | ] 23 | 24 | do is = 1, size(testsuites) 25 | write (error_unit, fmt) "Testing:", testsuites(is)%name 26 | call run_testsuite(testsuites(is)%collect, error_unit, stat) 27 | end do 28 | 29 | if (stat > 0) then 30 | write (error_unit, '(i0, 1x, a)') stat, "test(s) failed!" 31 | error stop 32 | end if 33 | 34 | end program main -------------------------------------------------------------------------------- /test/test_f2shortest/test_f2shortest.f90: -------------------------------------------------------------------------------- 1 | module test_f2shortest 2 | use testdrive, only: new_unittest, unittest_type, error_type, check 3 | use real32_to_shortest 4 | use iso_fortran_env, only: int32, real32 5 | implicit none 6 | private 7 | public :: collect_basic, collect_subnormal, collect_max_and_min, collect_boundary_round_even 8 | public :: collect_exact_value_round_even, collect_trailing_zeros, collect_regression 9 | public :: collect_looks_like_pow5, collect_output_length 10 | 11 | real(kind=real32), parameter :: NaN = transfer(int(z'FF800001', int32), 1._real32) 12 | real(kind=real32), parameter :: plus_infinity = transfer(int(z'7F800000', int32), 1._real32) 13 | real(kind=real32), parameter :: minus_infinity = transfer(int(z'FF800000', int32), 1._real32) 14 | 15 | contains 16 | 17 | !> ============================================================================= 18 | 19 | subroutine collect_basic(testsuite) 20 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 21 | 22 | testsuite = [ & 23 | new_unittest("plus_zero", test_plus_zero), & 24 | new_unittest("minus_zero", test_minus_zero), & 25 | new_unittest("NaN", test_NaN), & 26 | new_unittest("plus_infinity", test_plus_infinity), & 27 | new_unittest("minus_infinity", test_minus_infinity) & 28 | ] 29 | 30 | end subroutine collect_basic 31 | 32 | subroutine test_plus_zero(error) 33 | type(error_type), allocatable, intent(out) :: error 34 | 35 | call check(error, f2shortest(0._real32), "0.0") 36 | write (*, "(A,4X,A)") f2shortest(0._real32), "0.0" 37 | if (allocated(error)) return 38 | 39 | end subroutine test_plus_zero 40 | 41 | subroutine test_minus_zero(error) 42 | type(error_type), allocatable, intent(out) :: error 43 | 44 | call check(error, f2shortest(-0._real32), "-0.0") 45 | write (*, "(A,4X,A)") f2shortest(-0._real32), "-0.0" 46 | if (allocated(error)) return 47 | 48 | end subroutine test_minus_zero 49 | 50 | subroutine test_NaN(error) 51 | type(error_type), allocatable, intent(out) :: error 52 | 53 | call check(error, f2shortest(NaN), "NaN") 54 | write (*, "(A,4X,A)") f2shortest(NaN), "NaN" 55 | if (allocated(error)) return 56 | 57 | end subroutine test_NaN 58 | 59 | subroutine test_plus_infinity(error) 60 | type(error_type), allocatable, intent(out) :: error 61 | 62 | call check(error, f2shortest(plus_infinity), "Infinity") 63 | write (*, "(A,4X,A)") f2shortest(plus_infinity), "Infinity" 64 | if (allocated(error)) return 65 | 66 | end subroutine test_plus_infinity 67 | 68 | subroutine test_minus_infinity(error) 69 | type(error_type), allocatable, intent(out) :: error 70 | 71 | call check(error, f2shortest(minus_infinity), "-Infinity") 72 | write (*, "(A,4X,A)") f2shortest(minus_infinity), "-Infinity" 73 | if (allocated(error)) return 74 | 75 | end subroutine test_minus_infinity 76 | 77 | !> ============================================================================= 78 | 79 | subroutine collect_subnormal(testsuite) 80 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 81 | 82 | testsuite = [ & 83 | new_unittest("subnormal", test_subnormal) & 84 | ] 85 | 86 | end subroutine collect_subnormal 87 | 88 | subroutine test_subnormal(error) 89 | type(error_type), allocatable, intent(out) :: error 90 | 91 | call check(error, f2shortest(1.1754944e-38_real32), "1.1754944E-38") 92 | write (*, "(A,4X,A)") f2shortest(1.1754944e-38_real32), "1.1754944E-38" 93 | if (allocated(error)) return 94 | 95 | end subroutine test_subnormal 96 | 97 | !> ============================================================================= 98 | 99 | subroutine collect_max_and_min(testsuite) 100 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 101 | 102 | testsuite = [ & 103 | new_unittest("max", test_max), & 104 | new_unittest("min", test_min) & 105 | ] 106 | 107 | end subroutine collect_max_and_min 108 | 109 | subroutine test_max(error) 110 | type(error_type), allocatable, intent(out) :: error 111 | real(kind=real32), parameter :: max = transfer(2139095039_4, 1._real32) 112 | 113 | call check(error, f2shortest(max), "3.4028235E38") 114 | write (*, "(A,4X,A)") f2shortest(max), "3.4028235E38" 115 | if (allocated(error)) return 116 | 117 | end subroutine test_max 118 | 119 | subroutine test_min(error) 120 | type(error_type), allocatable, intent(out) :: error 121 | real(kind=real32), parameter :: min = transfer(1_4, 1._real32) 122 | 123 | call check(error, f2shortest(min), "1.4E-45") 124 | write (*, "(A,4X,A)") f2shortest(min), "1.4E-45" 125 | if (allocated(error)) return 126 | 127 | end subroutine test_min 128 | 129 | !> ============================================================================= 130 | 131 | subroutine collect_boundary_round_even(testsuite) 132 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 133 | 134 | testsuite = [ & 135 | new_unittest("value1", test_boundary_round_even_value1), & 136 | new_unittest("value2", test_boundary_round_even_value2), & 137 | new_unittest("value3", test_boundary_round_even_value3) & 138 | ] 139 | 140 | end subroutine collect_boundary_round_even 141 | 142 | subroutine test_boundary_round_even_value1(error) 143 | type(error_type), allocatable, intent(out) :: error 144 | 145 | call check(error, f2shortest(3.355445e7_real32), "3.355445E7") 146 | write (*, "(A,4X,A)") f2shortest(3.355445e7_real32), "3.355445E7" 147 | if (allocated(error)) return 148 | 149 | end subroutine test_boundary_round_even_value1 150 | 151 | subroutine test_boundary_round_even_value2(error) 152 | type(error_type), allocatable, intent(out) :: error 153 | 154 | call check(error, f2shortest(8.999999e9_real32), "9.0E9") 155 | write (*, "(A,4X,A)") f2shortest(8.999999e9_real32), "9.0E9" 156 | if (allocated(error)) return 157 | 158 | end subroutine test_boundary_round_even_value2 159 | 160 | subroutine test_boundary_round_even_value3(error) 161 | type(error_type), allocatable, intent(out) :: error 162 | 163 | call check(error, f2shortest(3.4366717e10_real32), "3.436672E10") 164 | write (*, "(A,4X,A)") f2shortest(3.4366717e10_real32), "3.436672E10" 165 | if (allocated(error)) return 166 | 167 | end subroutine test_boundary_round_even_value3 168 | 169 | !> ============================================================================= 170 | 171 | subroutine collect_exact_value_round_even(testsuite) 172 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 173 | 174 | testsuite = [ & 175 | new_unittest("value1", test_exact_value_round_even_value1), & 176 | new_unittest("value2", test_exact_value_round_even_value2) & 177 | ] 178 | 179 | end subroutine collect_exact_value_round_even 180 | 181 | subroutine test_exact_value_round_even_value1(error) 182 | type(error_type), allocatable, intent(out) :: error 183 | 184 | call check(error, f2shortest(3.0540412e5_real32), "305404.12") 185 | write (*, "(A,4X,A)") f2shortest(3.0540412e5_real32), "305404.12" 186 | if (allocated(error)) return 187 | 188 | end subroutine test_exact_value_round_even_value1 189 | 190 | subroutine test_exact_value_round_even_value2(error) 191 | type(error_type), allocatable, intent(out) :: error 192 | 193 | call check(error, f2shortest(8.0990312e3_real32), "8099.0312") 194 | write (*, "(A,4X,A)") f2shortest(8.0990312e3_real32), "8099.0312" 195 | if (allocated(error)) return 196 | 197 | end subroutine test_exact_value_round_even_value2 198 | 199 | !> ============================================================================= 200 | 201 | subroutine collect_trailing_zeros(testsuite) 202 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 203 | 204 | testsuite = [ & 205 | new_unittest("value1", test_trailing_zeros_value1), & 206 | new_unittest("value2", test_trailing_zeros_value2), & 207 | new_unittest("value3", test_trailing_zeros_value3), & 208 | new_unittest("value4", test_trailing_zeros_value4) & 209 | ] 210 | 211 | end subroutine collect_trailing_zeros 212 | 213 | subroutine test_trailing_zeros_value1(error) 214 | type(error_type), allocatable, intent(out) :: error 215 | 216 | call check(error, f2shortest(2.4414062e-4_real32), "2.4414062E-4") 217 | write (*, "(A,4X,A)") f2shortest(2.4414062e-4_real32), "2.4414062E-4" 218 | if (allocated(error)) return 219 | 220 | end subroutine test_trailing_zeros_value1 221 | 222 | subroutine test_trailing_zeros_value2(error) 223 | type(error_type), allocatable, intent(out) :: error 224 | 225 | call check(error, f2shortest(2.4414062e-3_real32), "0.0024414062") 226 | write (*, "(A,4X,A)") f2shortest(2.4414062e-3_real32), "0.0024414062" 227 | if (allocated(error)) return 228 | 229 | end subroutine test_trailing_zeros_value2 230 | 231 | subroutine test_trailing_zeros_value3(error) 232 | type(error_type), allocatable, intent(out) :: error 233 | 234 | call check(error, f2shortest(4.3945312e-3_real32), "0.0043945312") 235 | write (*, "(A,4X,A)") f2shortest(4.3945312e-3_real32), "0.0043945312" 236 | if (allocated(error)) return 237 | 238 | end subroutine test_trailing_zeros_value3 239 | 240 | subroutine test_trailing_zeros_value4(error) 241 | type(error_type), allocatable, intent(out) :: error 242 | 243 | call check(error, f2shortest(6.3476562e-3_real32), "0.0063476562") 244 | write (*, "(A,4X,A)") f2shortest(6.3476562e-3_real32), "0.0063476562" 245 | if (allocated(error)) return 246 | 247 | end subroutine test_trailing_zeros_value4 248 | 249 | !> ============================================================================= 250 | 251 | subroutine collect_regression(testsuite) 252 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 253 | 254 | testsuite = [ & 255 | new_unittest("value1", test_regression_value1), & 256 | new_unittest("value2", test_regression_value2), & 257 | new_unittest("value3", test_regression_value3), & 258 | new_unittest("value4", test_regression_value4), & 259 | new_unittest("value5", test_regression_value5), & 260 | new_unittest("value6", test_regression_value6), & 261 | new_unittest("value7", test_regression_value7), & 262 | new_unittest("value8", test_regression_value8), & 263 | new_unittest("value9", test_regression_value9), & 264 | new_unittest("value10", test_regression_value10), & 265 | new_unittest("value11", test_regression_value11), & 266 | new_unittest("value12", test_regression_value12), & 267 | new_unittest("value13", test_regression_value13), & 268 | new_unittest("value14", test_regression_value14), & 269 | new_unittest("value15", test_regression_value15), & 270 | new_unittest("value16", test_regression_value16), & 271 | new_unittest("value17", test_regression_value17), & 272 | new_unittest("value18", test_regression_value18), & 273 | new_unittest("value19", test_regression_value19), & 274 | new_unittest("value20", test_regression_value20), & 275 | new_unittest("value21", test_regression_value21), & 276 | new_unittest("value22", test_regression_value22), & 277 | new_unittest("value23", test_regression_value23), & 278 | new_unittest("value24", test_regression_value24), & 279 | new_unittest("value25", test_regression_value25), & 280 | new_unittest("value26", test_regression_value26), & 281 | new_unittest("value27", test_regression_value27), & 282 | new_unittest("value28", test_regression_value28), & 283 | new_unittest("value29", test_regression_value29) & 284 | ] 285 | 286 | end subroutine collect_regression 287 | 288 | subroutine test_regression_value1(error) 289 | type(error_type), allocatable, intent(out) :: error 290 | 291 | call check(error, f2shortest(4.7223665e21_real32), "4.7223665E21") 292 | write (*, "(A,4X,A)") f2shortest(4.7223665e21_real32), "4.7223665E21" 293 | if (allocated(error)) return 294 | 295 | end subroutine test_regression_value1 296 | 297 | subroutine test_regression_value2(error) 298 | type(error_type), allocatable, intent(out) :: error 299 | 300 | call check(error, f2shortest(8388608.0_real32), "8388608.0") 301 | write (*, "(A,4X,A)") f2shortest(8388608.0_real32), "8388608.0" 302 | if (allocated(error)) return 303 | 304 | end subroutine test_regression_value2 305 | 306 | subroutine test_regression_value3(error) 307 | type(error_type), allocatable, intent(out) :: error 308 | 309 | call check(error, f2shortest(1.6777216e7_real32), "1.6777216E7") 310 | write (*, "(A,4X,A)") f2shortest(1.6777216e7_real32), "1.6777216E7" 311 | if (allocated(error)) return 312 | 313 | end subroutine test_regression_value3 314 | subroutine test_regression_value4(error) 315 | type(error_type), allocatable, intent(out) :: error 316 | 317 | call check(error, f2shortest(3.3554436e7_real32), "3.3554436E7") 318 | write (*, "(A,4X,A)") f2shortest(3.3554436e7_real32), "3.3554436E7" 319 | if (allocated(error)) return 320 | 321 | end subroutine test_regression_value4 322 | subroutine test_regression_value5(error) 323 | type(error_type), allocatable, intent(out) :: error 324 | 325 | call check(error, f2shortest(6.7131496e7_real32), "6.7131496E7") 326 | write (*, "(A,4X,A)") f2shortest(6.7131496e7_real32), "6.7131496E7" 327 | if (allocated(error)) return 328 | 329 | end subroutine test_regression_value5 330 | subroutine test_regression_value6(error) 331 | type(error_type), allocatable, intent(out) :: error 332 | 333 | call check(error, f2shortest(1.9310392e-38_real32), "1.9310392E-38") 334 | write (*, "(A,4X,A)") f2shortest(1.9310392e-38_real32), "1.9310392E-38" 335 | if (allocated(error)) return 336 | 337 | end subroutine test_regression_value6 338 | subroutine test_regression_value7(error) 339 | type(error_type), allocatable, intent(out) :: error 340 | 341 | call check(error, f2shortest(-2.47e-43_real32), "-2.47E-43") 342 | write (*, "(A,4X,A)") f2shortest(-2.47e-43_real32), "-2.47E-43" 343 | if (allocated(error)) return 344 | 345 | end subroutine test_regression_value7 346 | 347 | subroutine test_regression_value8(error) 348 | type(error_type), allocatable, intent(out) :: error 349 | 350 | call check(error, f2shortest(1.993244e-38_real32), "1.993244E-38") 351 | write (*, "(A,4X,A)") f2shortest(1.993244e-38_real32), "1.993244E-38" 352 | if (allocated(error)) return 353 | 354 | end subroutine test_regression_value8 355 | 356 | subroutine test_regression_value9(error) 357 | type(error_type), allocatable, intent(out) :: error 358 | 359 | call check(error, f2shortest(4103.9003_real32), "4103.9004") 360 | write (*, "(A,4X,A)") f2shortest(4103.9003_real32), "4103.9004" 361 | if (allocated(error)) return 362 | 363 | end subroutine test_regression_value9 364 | 365 | subroutine test_regression_value10(error) 366 | type(error_type), allocatable, intent(out) :: error 367 | 368 | call check(error, f2shortest(5.3399997e9_real32), "5.3399997E9") 369 | write (*, "(A,4X,A)") f2shortest(5.3399997e9_real32), "5.3399997E9" 370 | if (allocated(error)) return 371 | 372 | end subroutine test_regression_value10 373 | 374 | subroutine test_regression_value11(error) 375 | type(error_type), allocatable, intent(out) :: error 376 | 377 | call check(error, f2shortest(6.0898e-39_real32), "6.0898E-39") 378 | write (*, "(A,4X,A)") f2shortest(6.0898e-39_real32), "6.0898E-39" 379 | if (allocated(error)) return 380 | 381 | end subroutine test_regression_value11 382 | 383 | subroutine test_regression_value12(error) 384 | type(error_type), allocatable, intent(out) :: error 385 | 386 | call check(error, f2shortest(0.0010310042_real32), "0.0010310042") 387 | write (*, "(A,4X,A)") f2shortest(0.0010310042_real32), "0.0010310042" 388 | if (allocated(error)) return 389 | 390 | end subroutine test_regression_value12 391 | 392 | subroutine test_regression_value13(error) 393 | type(error_type), allocatable, intent(out) :: error 394 | 395 | call check(error, f2shortest(2.8823261e17_real32), "2.882326E17") 396 | write (*, "(A,4X,A)") f2shortest(2.8823261e17_real32), "2.882326E17" 397 | if (allocated(error)) return 398 | 399 | end subroutine test_regression_value13 400 | 401 | subroutine test_regression_value14(error) 402 | type(error_type), allocatable, intent(out) :: error 403 | 404 | call check(error, f2shortest(7.0385309e-26_real32), "7.038531E-26") 405 | write (*, "(A,4X,A)") f2shortest(7.0385309e-26_real32), "7.038531E-26" 406 | if (allocated(error)) return 407 | 408 | end subroutine test_regression_value14 409 | 410 | subroutine test_regression_value15(error) 411 | type(error_type), allocatable, intent(out) :: error 412 | 413 | call check(error, f2shortest(9.2234038e17_real32), "9.223404E17") 414 | write (*, "(A,4X,A)") f2shortest(9.2234038e17_real32), "9.223404E17" 415 | if (allocated(error)) return 416 | 417 | end subroutine test_regression_value15 418 | 419 | subroutine test_regression_value16(error) 420 | type(error_type), allocatable, intent(out) :: error 421 | 422 | call check(error, f2shortest(6.7108872e7_real32), "6.710887E7") 423 | write (*, "(A,4X,A)") f2shortest(6.7108872e7_real32), "6.710887E7" 424 | if (allocated(error)) return 425 | 426 | end subroutine test_regression_value16 427 | 428 | subroutine test_regression_value17(error) 429 | type(error_type), allocatable, intent(out) :: error 430 | 431 | call check(error, f2shortest(1.0e-44_real32), "1.0E-44") 432 | write (*, "(A,4X,A)") f2shortest(1.0e-44_real32), "1.0E-44" 433 | if (allocated(error)) return 434 | 435 | end subroutine test_regression_value17 436 | 437 | subroutine test_regression_value18(error) 438 | type(error_type), allocatable, intent(out) :: error 439 | 440 | call check(error, f2shortest(2.816025e14_real32), "2.816025E14") 441 | write (*, "(A,4X,A)") f2shortest(2.816025e14_real32), "2.816025E14" 442 | if (allocated(error)) return 443 | 444 | end subroutine test_regression_value18 445 | 446 | subroutine test_regression_value19(error) 447 | type(error_type), allocatable, intent(out) :: error 448 | 449 | call check(error, f2shortest(9.223372e18_real32), "9.223372E18") 450 | write (*, "(A,4X,A)") f2shortest(9.223372e18_real32), "9.223372E18" 451 | if (allocated(error)) return 452 | 453 | end subroutine test_regression_value19 454 | 455 | subroutine test_regression_value20(error) 456 | type(error_type), allocatable, intent(out) :: error 457 | 458 | call check(error, f2shortest(1.5846085e29_real32), "1.5846086E29") 459 | write (*, "(A,4X,A)") f2shortest(1.5846085e29_real32), "1.5846086E29" 460 | if (allocated(error)) return 461 | 462 | end subroutine test_regression_value20 463 | 464 | subroutine test_regression_value21(error) 465 | type(error_type), allocatable, intent(out) :: error 466 | 467 | call check(error, f2shortest(1.1811161e19_real32), "1.1811161E19") 468 | write (*, "(A,4X,A)") f2shortest(1.1811161e19_real32), "1.1811161E19" 469 | if (allocated(error)) return 470 | 471 | end subroutine test_regression_value21 472 | 473 | subroutine test_regression_value22(error) 474 | type(error_type), allocatable, intent(out) :: error 475 | 476 | call check(error, f2shortest(5.368709e18_real32), "5.368709E18") 477 | write (*, "(A,4X,A)") f2shortest(5.368709e18_real32), "5.368709E18" 478 | if (allocated(error)) return 479 | 480 | end subroutine test_regression_value22 481 | 482 | subroutine test_regression_value23(error) 483 | type(error_type), allocatable, intent(out) :: error 484 | 485 | call check(error, f2shortest(4.6143165e18_real32), "4.6143166E18") 486 | write (*, "(A,4X,A)") f2shortest(4.6143165e8_real32), "4.6143166E18" 487 | if (allocated(error)) return 488 | 489 | end subroutine test_regression_value23 490 | 491 | subroutine test_regression_value24(error) 492 | type(error_type), allocatable, intent(out) :: error 493 | 494 | call check(error, f2shortest(0.007812537_real32), "0.007812537") 495 | write (*, "(A,4X,A)") f2shortest(0.007812537_real32), "0.007812537" 496 | if (allocated(error)) return 497 | 498 | end subroutine test_regression_value24 499 | 500 | subroutine test_regression_value25(error) 501 | type(error_type), allocatable, intent(out) :: error 502 | real(kind=real32) :: f 503 | 504 | ! literal constant value '1.4E-45' can not be correctly converted to binary representation 505 | f = transfer(1_int32, 1._real32) 506 | 507 | call check(error, f2shortest(f), "1.4E-45") 508 | write (*, "(A,4X,A)") f2shortest(f), "1.4E-45" 509 | if (allocated(error)) return 510 | 511 | end subroutine test_regression_value25 512 | 513 | subroutine test_regression_value26(error) 514 | type(error_type), allocatable, intent(out) :: error 515 | 516 | call check(error, f2shortest(1.18697724e20_real32), "1.18697725E20") 517 | write (*, "(A,4X,A)") f2shortest(1.18697724e20_real32), "1.18697725E20" 518 | if (allocated(error)) return 519 | 520 | end subroutine test_regression_value26 521 | 522 | subroutine test_regression_value27(error) 523 | type(error_type), allocatable, intent(out) :: error 524 | 525 | call check(error, f2shortest(1.00014165e-36_real32), "1.00014165E-36") 526 | write (*, "(A,4X,A)") f2shortest(1.00014165e-36_real32), "1.00014165E-36" 527 | if (allocated(error)) return 528 | 529 | end subroutine test_regression_value27 530 | 531 | subroutine test_regression_value28(error) 532 | type(error_type), allocatable, intent(out) :: error 533 | 534 | call check(error, f2shortest(200.0_real32), "200.0") 535 | write (*, "(A,4X,A)") f2shortest(200.0_real32), "200.0" 536 | if (allocated(error)) return 537 | 538 | end subroutine test_regression_value28 539 | 540 | subroutine test_regression_value29(error) 541 | type(error_type), allocatable, intent(out) :: error 542 | 543 | call check(error, f2shortest(3.3554432e7_real32), "3.3554432E7") 544 | write (*, "(A,4X,A)") f2shortest(3.3554432e7_real32), "3.3554432E7" 545 | if (allocated(error)) return 546 | 547 | end subroutine test_regression_value29 548 | 549 | !> ============================================================================= 550 | 551 | subroutine collect_looks_like_pow5(testsuite) 552 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 553 | 554 | testsuite = [ & 555 | new_unittest("value1", test_looks_like_pow5_value1), & 556 | new_unittest("value2", test_looks_like_pow5_value2), & 557 | new_unittest("value3", test_looks_like_pow5_value3) & 558 | ] 559 | 560 | end subroutine collect_looks_like_pow5 561 | 562 | subroutine test_looks_like_pow5_value1(error) 563 | type(error_type), allocatable, intent(out) :: error 564 | real(kind=real32) :: f 565 | 566 | f = transfer(1561658105_int32, 1._real32) 567 | 568 | call check(error, f2shortest(f), "6.7108864E17") 569 | write (*, "(A,4X,A)") f2shortest(f), "6.7108864E17" 570 | if (allocated(error)) return 571 | 572 | end subroutine test_looks_like_pow5_value1 573 | 574 | subroutine test_looks_like_pow5_value2(error) 575 | type(error_type), allocatable, intent(out) :: error 576 | real(kind=real32) :: f 577 | 578 | f = transfer(1570046713_int32, 1._real32) 579 | 580 | call check(error, f2shortest(f), "1.3421773E18") 581 | write (*, "(A,4X,A)") f2shortest(f), "1.3421773E18" 582 | if (allocated(error)) return 583 | 584 | end subroutine test_looks_like_pow5_value2 585 | 586 | subroutine test_looks_like_pow5_value3(error) 587 | type(error_type), allocatable, intent(out) :: error 588 | real(kind=real32) :: f 589 | 590 | f = transfer(1578435321_int32, 1._real32) 591 | 592 | call check(error, f2shortest(f), "2.6843546E18") 593 | write (*, "(A,4X,A)") f2shortest(f), "2.6843546E18" 594 | if (allocated(error)) return 595 | 596 | end subroutine test_looks_like_pow5_value3 597 | 598 | !> ============================================================================= 599 | 600 | subroutine collect_output_length(testsuite) 601 | type(unittest_type), dimension(:), allocatable, intent(out) :: testsuite 602 | 603 | testsuite = [ & 604 | new_unittest("value1", test_output_length_value1), & 605 | new_unittest("value2", test_output_length_value2), & 606 | new_unittest("value3", test_output_length_value3), & 607 | new_unittest("value4", test_output_length_value4), & 608 | new_unittest("value5", test_output_length_value5), & 609 | new_unittest("value6", test_output_length_value6), & 610 | new_unittest("value7", test_output_length_value7), & 611 | new_unittest("value8", test_output_length_value8), & 612 | new_unittest("value9", test_output_length_value9) & 613 | ] 614 | 615 | end subroutine collect_output_length 616 | 617 | subroutine test_output_length_value1(error) 618 | type(error_type), allocatable, intent(out) :: error 619 | 620 | call check(error, f2shortest(1.0_real32), "1.0") 621 | write (*, "(A,4X,A)") f2shortest(1.0_real32), "1.0" 622 | if (allocated(error)) return 623 | 624 | end subroutine test_output_length_value1 625 | 626 | subroutine test_output_length_value2(error) 627 | type(error_type), allocatable, intent(out) :: error 628 | 629 | call check(error, f2shortest(1.2_real32), "1.2") 630 | write (*, "(A,4X,A)") f2shortest(1.2_real32), "1.2" 631 | if (allocated(error)) return 632 | 633 | end subroutine test_output_length_value2 634 | 635 | subroutine test_output_length_value3(error) 636 | type(error_type), allocatable, intent(out) :: error 637 | 638 | call check(error, f2shortest(1.23_real32), "1.23") 639 | write (*, "(A,4X,A)") f2shortest(1.23_real32), "1.23" 640 | if (allocated(error)) return 641 | 642 | end subroutine test_output_length_value3 643 | 644 | subroutine test_output_length_value4(error) 645 | type(error_type), allocatable, intent(out) :: error 646 | 647 | call check(error, f2shortest(1.234_real32), "1.234") 648 | write (*, "(A,4X,A)") f2shortest(1.234_real32), "1.234" 649 | if (allocated(error)) return 650 | 651 | end subroutine test_output_length_value4 652 | 653 | subroutine test_output_length_value5(error) 654 | type(error_type), allocatable, intent(out) :: error 655 | 656 | call check(error, f2shortest(1.2345_real32), "1.2345") 657 | write (*, "(A,4X,A)") f2shortest(1.2345_real32), "1.2345" 658 | if (allocated(error)) return 659 | 660 | end subroutine test_output_length_value5 661 | 662 | subroutine test_output_length_value6(error) 663 | type(error_type), allocatable, intent(out) :: error 664 | 665 | call check(error, f2shortest(1.23456_real32), "1.23456") 666 | write (*, "(A,4X,A)") f2shortest(1.23456_real32), "1.23456" 667 | if (allocated(error)) return 668 | 669 | end subroutine test_output_length_value6 670 | 671 | subroutine test_output_length_value7(error) 672 | type(error_type), allocatable, intent(out) :: error 673 | 674 | call check(error, f2shortest(1.234567_real32), "1.234567") 675 | write (*, "(A,4X,A)") f2shortest(1.234567_real32), "1.234567" 676 | if (allocated(error)) return 677 | 678 | end subroutine test_output_length_value7 679 | 680 | subroutine test_output_length_value8(error) 681 | type(error_type), allocatable, intent(out) :: error 682 | 683 | call check(error, f2shortest(1.2345678_real32), "1.2345678") 684 | write (*, "(A,4X,A)") f2shortest(1.2345678_real32), "1.2345678" 685 | if (allocated(error)) return 686 | 687 | end subroutine test_output_length_value8 688 | 689 | subroutine test_output_length_value9(error) 690 | type(error_type), allocatable, intent(out) :: error 691 | 692 | call check(error, f2shortest(1.23456735e-36_real32), "1.23456735E-36") 693 | write (*, "(A,4X,A)") f2shortest(1.23456735e-36_real32), "1.23456735E-36" 694 | if (allocated(error)) return 695 | 696 | end subroutine test_output_length_value9 697 | 698 | end module test_f2shortest 699 | -------------------------------------------------------------------------------- /test/test_f2shortest/tester.f90: -------------------------------------------------------------------------------- 1 | program main 2 | use testdrive 3 | use iso_fortran_env 4 | use test_f2shortest 5 | implicit none 6 | integer :: stat, is 7 | type(testsuite_type), dimension(:), allocatable :: testsuites 8 | character(len=*), parameter :: fmt = '("#", *(1x, a))' 9 | 10 | stat = 0 11 | 12 | testsuites = [ & 13 | new_testsuite("test_basic", collect_basic), & 14 | new_testsuite("test_subnormal", collect_subnormal), & 15 | new_testsuite("test_max_and_min", collect_max_and_min), & 16 | new_testsuite("test_boundary_round_even", collect_boundary_round_even), & 17 | new_testsuite("test_exact_value_round_even", collect_exact_value_round_even), & 18 | new_testsuite("test_trailing_zeros", collect_trailing_zeros), & 19 | new_testsuite("test_regression", collect_regression), & 20 | new_testsuite("test_looks_like_pow5", collect_looks_like_pow5), & 21 | new_testsuite("test_output_length", collect_output_length) & 22 | ] 23 | 24 | do is = 1, size(testsuites) 25 | write (error_unit, fmt) "Testing:", testsuites(is)%name 26 | call run_testsuite(testsuites(is)%collect, error_unit, stat) 27 | end do 28 | 29 | if (stat > 0) then 30 | write (error_unit, '(i0, 1x, a)') stat, "test(s) failed!" 31 | error stop 32 | end if 33 | 34 | end program main 35 | --------------------------------------------------------------------------------