1! { dg-do run } 2 3 use, intrinsic :: ieee_features 4 use, intrinsic :: ieee_exceptions 5 use, intrinsic :: ieee_arithmetic 6 implicit none 7 8 interface check_equal 9 procedure check_equal_float, check_equal_double 10 end interface 11 12 interface check_not_equal 13 procedure check_not_equal_float, check_not_equal_double 14 end interface 15 16 real :: sx1, sx2, sx3 17 double precision :: dx1, dx2, dx3 18 type(ieee_round_type) :: mode 19 20 ! Test IEEE_COPY_SIGN 21 sx1 = 1.3 22 if (ieee_copy_sign(sx1, sx1) /= sx1) call abort 23 if (ieee_copy_sign(sx1, -sx1) /= -sx1) call abort 24 if (ieee_copy_sign(sx1, 1.) /= sx1) call abort 25 if (ieee_copy_sign(sx1, -1.) /= -sx1) call abort 26 sx1 = huge(sx1) 27 if (ieee_copy_sign(sx1, sx1) /= sx1) call abort 28 if (ieee_copy_sign(sx1, -sx1) /= -sx1) call abort 29 if (ieee_copy_sign(sx1, 1.) /= sx1) call abort 30 if (ieee_copy_sign(sx1, -1.) /= -sx1) call abort 31 sx1 = ieee_value(sx1, ieee_positive_inf) 32 if (ieee_copy_sign(sx1, sx1) /= sx1) call abort 33 if (ieee_copy_sign(sx1, -sx1) /= -sx1) call abort 34 if (ieee_copy_sign(sx1, 1.) /= sx1) call abort 35 if (ieee_copy_sign(sx1, -1.) /= -sx1) call abort 36 sx1 = tiny(sx1) 37 if (ieee_copy_sign(sx1, sx1) /= sx1) call abort 38 if (ieee_copy_sign(sx1, -sx1) /= -sx1) call abort 39 if (ieee_copy_sign(sx1, 1.) /= sx1) call abort 40 if (ieee_copy_sign(sx1, -1.) /= -sx1) call abort 41 sx1 = tiny(sx1) 42 sx1 = sx1 / 101 43 if (ieee_copy_sign(sx1, sx1) /= sx1) call abort 44 if (ieee_copy_sign(sx1, -sx1) /= -sx1) call abort 45 if (ieee_copy_sign(sx1, 1.) /= sx1) call abort 46 if (ieee_copy_sign(sx1, -1.) /= -sx1) call abort 47 48 sx1 = -1.3 49 if (ieee_copy_sign(sx1, sx1) /= sx1) call abort 50 if (ieee_copy_sign(sx1, -sx1) /= -sx1) call abort 51 if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) call abort 52 if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) call abort 53 sx1 = -huge(sx1) 54 if (ieee_copy_sign(sx1, sx1) /= sx1) call abort 55 if (ieee_copy_sign(sx1, -sx1) /= -sx1) call abort 56 if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) call abort 57 if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) call abort 58 sx1 = ieee_value(sx1, ieee_negative_inf) 59 if (ieee_copy_sign(sx1, sx1) /= sx1) call abort 60 if (ieee_copy_sign(sx1, -sx1) /= -sx1) call abort 61 if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) call abort 62 if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) call abort 63 sx1 = -tiny(sx1) 64 if (ieee_copy_sign(sx1, sx1) /= sx1) call abort 65 if (ieee_copy_sign(sx1, -sx1) /= -sx1) call abort 66 if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) call abort 67 if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) call abort 68 sx1 = -tiny(sx1) 69 sx1 = sx1 / 101 70 if (ieee_copy_sign(sx1, sx1) /= sx1) call abort 71 if (ieee_copy_sign(sx1, -sx1) /= -sx1) call abort 72 if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) call abort 73 if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) call abort 74 75 if (ieee_class(ieee_copy_sign(0., -1.)) /= ieee_negative_zero) call abort 76 if (ieee_class(ieee_copy_sign(-0., -1.)) /= ieee_negative_zero) call abort 77 if (ieee_class(ieee_copy_sign(0., 1.)) /= ieee_positive_zero) call abort 78 if (ieee_class(ieee_copy_sign(-0., 1.)) /= ieee_positive_zero) call abort 79 80 sx1 = ieee_value(0., ieee_quiet_nan) 81 if (ieee_class(ieee_copy_sign(sx1, 1.)) /= ieee_quiet_nan) call abort 82 if (ieee_class(ieee_copy_sign(sx1, -1.)) /= ieee_quiet_nan) call abort 83 84 dx1 = 1.3 85 if (ieee_copy_sign(dx1, dx1) /= dx1) call abort 86 if (ieee_copy_sign(dx1, -dx1) /= -dx1) call abort 87 if (ieee_copy_sign(dx1, 1.) /= dx1) call abort 88 if (ieee_copy_sign(dx1, -1.d0) /= -dx1) call abort 89 dx1 = huge(dx1) 90 if (ieee_copy_sign(dx1, dx1) /= dx1) call abort 91 if (ieee_copy_sign(dx1, -dx1) /= -dx1) call abort 92 if (ieee_copy_sign(dx1, 1.d0) /= dx1) call abort 93 if (ieee_copy_sign(dx1, -1.) /= -dx1) call abort 94 dx1 = ieee_value(dx1, ieee_positive_inf) 95 if (ieee_copy_sign(dx1, dx1) /= dx1) call abort 96 if (ieee_copy_sign(dx1, -dx1) /= -dx1) call abort 97 if (ieee_copy_sign(dx1, 1.) /= dx1) call abort 98 if (ieee_copy_sign(dx1, -1.d0) /= -dx1) call abort 99 dx1 = tiny(dx1) 100 if (ieee_copy_sign(dx1, dx1) /= dx1) call abort 101 if (ieee_copy_sign(dx1, -dx1) /= -dx1) call abort 102 if (ieee_copy_sign(dx1, 1.d0) /= dx1) call abort 103 if (ieee_copy_sign(dx1, -1.) /= -dx1) call abort 104 dx1 = tiny(dx1) 105 dx1 = dx1 / 101 106 if (ieee_copy_sign(dx1, dx1) /= dx1) call abort 107 if (ieee_copy_sign(dx1, -dx1) /= -dx1) call abort 108 if (ieee_copy_sign(dx1, 1.) /= dx1) call abort 109 if (ieee_copy_sign(dx1, -1.d0) /= -dx1) call abort 110 111 dx1 = -1.3d0 112 if (ieee_copy_sign(dx1, dx1) /= dx1) call abort 113 if (ieee_copy_sign(dx1, -dx1) /= -dx1) call abort 114 if (ieee_copy_sign(dx1, 1.d0) /= abs(dx1)) call abort 115 if (ieee_copy_sign(dx1, -1.) /= -abs(dx1)) call abort 116 dx1 = -huge(dx1) 117 if (ieee_copy_sign(dx1, dx1) /= dx1) call abort 118 if (ieee_copy_sign(dx1, -dx1) /= -dx1) call abort 119 if (ieee_copy_sign(dx1, 1.) /= abs(dx1)) call abort 120 if (ieee_copy_sign(dx1, -1.d0) /= -abs(dx1)) call abort 121 dx1 = ieee_value(dx1, ieee_negative_inf) 122 if (ieee_copy_sign(dx1, dx1) /= dx1) call abort 123 if (ieee_copy_sign(dx1, -dx1) /= -dx1) call abort 124 if (ieee_copy_sign(dx1, 1.d0) /= abs(dx1)) call abort 125 if (ieee_copy_sign(dx1, -1.) /= -abs(dx1)) call abort 126 dx1 = -tiny(dx1) 127 if (ieee_copy_sign(dx1, dx1) /= dx1) call abort 128 if (ieee_copy_sign(dx1, -dx1) /= -dx1) call abort 129 if (ieee_copy_sign(dx1, 1.) /= abs(dx1)) call abort 130 if (ieee_copy_sign(dx1, -1.d0) /= -abs(dx1)) call abort 131 dx1 = -tiny(dx1) 132 dx1 = dx1 / 101 133 if (ieee_copy_sign(dx1, dx1) /= dx1) call abort 134 if (ieee_copy_sign(dx1, -dx1) /= -dx1) call abort 135 if (ieee_copy_sign(dx1, 1.d0) /= abs(dx1)) call abort 136 if (ieee_copy_sign(dx1, -1.) /= -abs(dx1)) call abort 137 138 if (ieee_class(ieee_copy_sign(0.d0, -1.)) /= ieee_negative_zero) call abort 139 if (ieee_class(ieee_copy_sign(-0.d0, -1.)) /= ieee_negative_zero) call abort 140 if (ieee_class(ieee_copy_sign(0.d0, 1.)) /= ieee_positive_zero) call abort 141 if (ieee_class(ieee_copy_sign(-0.d0, 1.)) /= ieee_positive_zero) call abort 142 143 dx1 = ieee_value(0.d0, ieee_quiet_nan) 144 if (ieee_class(ieee_copy_sign(dx1, 1.d0)) /= ieee_quiet_nan) call abort 145 if (ieee_class(ieee_copy_sign(dx1, -1.)) /= ieee_quiet_nan) call abort 146 147 ! Test IEEE_LOGB 148 149 if (ieee_logb(1.17) /= exponent(1.17) - 1) call abort 150 if (ieee_logb(-1.17) /= exponent(-1.17) - 1) call abort 151 if (ieee_logb(huge(sx1)) /= exponent(huge(sx1)) - 1) call abort 152 if (ieee_logb(-huge(sx1)) /= exponent(-huge(sx1)) - 1) call abort 153 if (ieee_logb(tiny(sx1)) /= exponent(tiny(sx1)) - 1) call abort 154 if (ieee_logb(-tiny(sx1)) /= exponent(-tiny(sx1)) - 1) call abort 155 156 if (ieee_class(ieee_logb(0.)) /= ieee_negative_inf) call abort 157 if (ieee_class(ieee_logb(-0.)) /= ieee_negative_inf) call abort 158 159 sx1 = ieee_value(sx1, ieee_positive_inf) 160 if (ieee_class(ieee_logb(sx1)) /= ieee_positive_inf) call abort 161 if (ieee_class(ieee_logb(-sx1)) /= ieee_positive_inf) call abort 162 163 sx1 = ieee_value(sx1, ieee_quiet_nan) 164 if (ieee_class(ieee_logb(sx1)) /= ieee_quiet_nan) call abort 165 166 if (ieee_logb(1.17d0) /= exponent(1.17d0) - 1) call abort 167 if (ieee_logb(-1.17d0) /= exponent(-1.17d0) - 1) call abort 168 if (ieee_logb(huge(dx1)) /= exponent(huge(dx1)) - 1) call abort 169 if (ieee_logb(-huge(dx1)) /= exponent(-huge(dx1)) - 1) call abort 170 if (ieee_logb(tiny(dx1)) /= exponent(tiny(dx1)) - 1) call abort 171 if (ieee_logb(-tiny(dx1)) /= exponent(-tiny(dx1)) - 1) call abort 172 173 if (ieee_class(ieee_logb(0.d0)) /= ieee_negative_inf) call abort 174 if (ieee_class(ieee_logb(-0.d0)) /= ieee_negative_inf) call abort 175 176 dx1 = ieee_value(dx1, ieee_positive_inf) 177 if (ieee_class(ieee_logb(dx1)) /= ieee_positive_inf) call abort 178 if (ieee_class(ieee_logb(-dx1)) /= ieee_positive_inf) call abort 179 180 dx1 = ieee_value(dx1, ieee_quiet_nan) 181 if (ieee_class(ieee_logb(dx1)) /= ieee_quiet_nan) call abort 182 183 ! Test IEEE_NEXT_AFTER 184 185 if (ieee_next_after(0.12, 1.0) /= nearest(0.12, 1.0)) call abort 186 if (ieee_next_after(0.12, -1.0) /= nearest(0.12, -1.0)) call abort 187 188 sx1 = 0.12 189 if (ieee_next_after(sx1, sx1) /= sx1) call abort 190 sx1 = -0.12 191 if (ieee_next_after(sx1, sx1) /= sx1) call abort 192 sx1 = huge(sx1) 193 if (ieee_next_after(sx1, sx1) /= sx1) call abort 194 sx1 = tiny(sx1) 195 if (ieee_next_after(sx1, sx1) /= sx1) call abort 196 sx1 = 0 197 if (ieee_next_after(sx1, sx1) /= sx1) call abort 198 sx1 = ieee_value(sx1, ieee_negative_inf) 199 if (ieee_next_after(sx1, sx1) /= sx1) call abort 200 sx1 = ieee_value(sx1, ieee_quiet_nan) 201 if (ieee_class(ieee_next_after(sx1, sx1)) /= ieee_quiet_nan) call abort 202 203 if (ieee_next_after(0., 1.0) <= 0) call abort 204 if (ieee_next_after(0., -1.0) >= 0) call abort 205 sx1 = ieee_next_after(huge(sx1), ieee_value(sx1, ieee_negative_inf)) 206 if (.not. sx1 < huge(sx1)) call abort 207 sx1 = ieee_next_after(huge(sx1), ieee_value(sx1, ieee_positive_inf)) 208 if (ieee_class(sx1) /= ieee_positive_inf) call abort 209 sx1 = ieee_next_after(-tiny(sx1), 1.0) 210 if (ieee_class(sx1) /= ieee_negative_denormal) call abort 211 212 if (ieee_next_after(0.12d0, 1.0d0) /= nearest(0.12d0, 1.0)) call abort 213 if (ieee_next_after(0.12d0, -1.0) /= nearest(0.12d0, -1.0)) call abort 214 215 dx1 = 0.12 216 if (ieee_next_after(dx1, dx1) /= dx1) call abort 217 dx1 = -0.12 218 if (ieee_next_after(dx1, dx1) /= dx1) call abort 219 dx1 = huge(dx1) 220 if (ieee_next_after(dx1, dx1) /= dx1) call abort 221 dx1 = tiny(dx1) 222 if (ieee_next_after(dx1, dx1) /= dx1) call abort 223 dx1 = 0 224 if (ieee_next_after(dx1, dx1) /= dx1) call abort 225 dx1 = ieee_value(dx1, ieee_negative_inf) 226 if (ieee_next_after(dx1, dx1) /= dx1) call abort 227 dx1 = ieee_value(dx1, ieee_quiet_nan) 228 if (ieee_class(ieee_next_after(dx1, dx1)) /= ieee_quiet_nan) call abort 229 230 if (ieee_next_after(0.d0, 1.0) <= 0) call abort 231 if (ieee_next_after(0.d0, -1.0d0) >= 0) call abort 232 dx1 = ieee_next_after(huge(dx1), ieee_value(dx1, ieee_negative_inf)) 233 if (.not. dx1 < huge(dx1)) call abort 234 dx1 = ieee_next_after(huge(dx1), ieee_value(dx1, ieee_positive_inf)) 235 if (ieee_class(dx1) /= ieee_positive_inf) call abort 236 dx1 = ieee_next_after(-tiny(dx1), 1.0d0) 237 if (ieee_class(dx1) /= ieee_negative_denormal) call abort 238 239 ! Test IEEE_REM 240 241 if (ieee_rem(4.0, 3.0) /= 1.0) call abort 242 if (ieee_rem(-4.0, 3.0) /= -1.0) call abort 243 if (ieee_rem(2.0, 3.0d0) /= -1.0d0) call abort 244 if (ieee_rem(-2.0, 3.0d0) /= 1.0d0) call abort 245 if (ieee_rem(2.0d0, 3.0d0) /= -1.0d0) call abort 246 if (ieee_rem(-2.0d0, 3.0d0) /= 1.0d0) call abort 247 248 if (ieee_class(ieee_rem(ieee_value(0., ieee_quiet_nan), 1.0)) & 249 /= ieee_quiet_nan) call abort 250 if (ieee_class(ieee_rem(1.0, ieee_value(0.d0, ieee_quiet_nan))) & 251 /= ieee_quiet_nan) call abort 252 253 if (ieee_class(ieee_rem(ieee_value(0., ieee_positive_inf), 1.0)) & 254 /= ieee_quiet_nan) call abort 255 if (ieee_class(ieee_rem(ieee_value(0.d0, ieee_negative_inf), 1.0)) & 256 /= ieee_quiet_nan) call abort 257 if (ieee_rem(-1.0, ieee_value(0., ieee_positive_inf)) & 258 /= -1.0) call abort 259 if (ieee_rem(1.0, ieee_value(0.d0, ieee_negative_inf)) & 260 /= 1.0) call abort 261 262 263 ! Test IEEE_RINT 264 265 if (ieee_support_rounding (ieee_nearest, sx1)) then 266 call ieee_get_rounding_mode (mode) 267 call ieee_set_rounding_mode (ieee_nearest) 268 sx1 = 7 / 3. 269 sx1 = ieee_rint (sx1) 270 call ieee_set_rounding_mode (mode) 271 if (sx1 /= 2) call abort 272 end if 273 274 if (ieee_support_rounding (ieee_up, sx1)) then 275 call ieee_get_rounding_mode (mode) 276 call ieee_set_rounding_mode (ieee_up) 277 sx1 = 7 / 3. 278 sx1 = ieee_rint (sx1) 279 call ieee_set_rounding_mode (mode) 280 if (sx1 /= 3) call abort 281 end if 282 283 if (ieee_support_rounding (ieee_down, sx1)) then 284 call ieee_get_rounding_mode (mode) 285 call ieee_set_rounding_mode (ieee_down) 286 sx1 = 7 / 3. 287 sx1 = ieee_rint (sx1) 288 call ieee_set_rounding_mode (mode) 289 if (sx1 /= 2) call abort 290 end if 291 292 if (ieee_support_rounding (ieee_to_zero, sx1)) then 293 call ieee_get_rounding_mode (mode) 294 call ieee_set_rounding_mode (ieee_to_zero) 295 sx1 = 7 / 3. 296 sx1 = ieee_rint (sx1) 297 call ieee_set_rounding_mode (mode) 298 if (sx1 /= 2) call abort 299 end if 300 301 if (ieee_class(ieee_rint(0.)) /= ieee_positive_zero) call abort 302 if (ieee_class(ieee_rint(-0.)) /= ieee_negative_zero) call abort 303 304 if (ieee_support_rounding (ieee_nearest, dx1)) then 305 call ieee_get_rounding_mode (mode) 306 call ieee_set_rounding_mode (ieee_nearest) 307 dx1 = 7 / 3.d0 308 dx1 = ieee_rint (dx1) 309 call ieee_set_rounding_mode (mode) 310 if (dx1 /= 2) call abort 311 end if 312 313 if (ieee_support_rounding (ieee_up, dx1)) then 314 call ieee_get_rounding_mode (mode) 315 call ieee_set_rounding_mode (ieee_up) 316 dx1 = 7 / 3.d0 317 dx1 = ieee_rint (dx1) 318 call ieee_set_rounding_mode (mode) 319 if (dx1 /= 3) call abort 320 end if 321 322 if (ieee_support_rounding (ieee_down, dx1)) then 323 call ieee_get_rounding_mode (mode) 324 call ieee_set_rounding_mode (ieee_down) 325 dx1 = 7 / 3.d0 326 dx1 = ieee_rint (dx1) 327 call ieee_set_rounding_mode (mode) 328 if (dx1 /= 2) call abort 329 end if 330 331 if (ieee_support_rounding (ieee_to_zero, dx1)) then 332 call ieee_get_rounding_mode (mode) 333 call ieee_set_rounding_mode (ieee_to_zero) 334 dx1 = 7 / 3.d0 335 dx1 = ieee_rint (dx1) 336 call ieee_set_rounding_mode (mode) 337 if (dx1 /= 2) call abort 338 end if 339 340 if (ieee_class(ieee_rint(0.d0)) /= ieee_positive_zero) call abort 341 if (ieee_class(ieee_rint(-0.d0)) /= ieee_negative_zero) call abort 342 343 ! Test IEEE_SCALB 344 345 sx1 = 1 346 if (ieee_scalb(sx1, 2) /= 4.) call abort 347 if (ieee_scalb(-sx1, 2) /= -4.) call abort 348 if (ieee_scalb(sx1, -2) /= 1/4.) call abort 349 if (ieee_scalb(-sx1, -2) /= -1/4.) call abort 350 if (ieee_class(ieee_scalb(sx1, huge(0))) /= ieee_positive_inf) call abort 351 if (ieee_class(ieee_scalb(-sx1, huge(0))) /= ieee_negative_inf) call abort 352 if (ieee_class(ieee_scalb(sx1, -huge(0))) /= ieee_positive_zero) call abort 353 if (ieee_class(ieee_scalb(-sx1, -huge(0))) /= ieee_negative_zero) call abort 354 355 sx1 = ieee_value(sx1, ieee_quiet_nan) 356 if (ieee_class(ieee_scalb(sx1, 1)) /= ieee_quiet_nan) call abort 357 sx1 = ieee_value(sx1, ieee_positive_inf) 358 if (ieee_class(ieee_scalb(sx1, -42)) /= ieee_positive_inf) call abort 359 sx1 = ieee_value(sx1, ieee_negative_inf) 360 if (ieee_class(ieee_scalb(sx1, -42)) /= ieee_negative_inf) call abort 361 362 dx1 = 1 363 if (ieee_scalb(dx1, 2) /= 4.d0) call abort 364 if (ieee_scalb(-dx1, 2) /= -4.d0) call abort 365 if (ieee_scalb(dx1, -2) /= 1/4.d0) call abort 366 if (ieee_scalb(-dx1, -2) /= -1/4.d0) call abort 367 if (ieee_class(ieee_scalb(dx1, huge(0))) /= ieee_positive_inf) call abort 368 if (ieee_class(ieee_scalb(-dx1, huge(0))) /= ieee_negative_inf) call abort 369 if (ieee_class(ieee_scalb(dx1, -huge(0))) /= ieee_positive_zero) call abort 370 if (ieee_class(ieee_scalb(-dx1, -huge(0))) /= ieee_negative_zero) call abort 371 372 dx1 = ieee_value(dx1, ieee_quiet_nan) 373 if (ieee_class(ieee_scalb(dx1, 1)) /= ieee_quiet_nan) call abort 374 dx1 = ieee_value(dx1, ieee_positive_inf) 375 if (ieee_class(ieee_scalb(dx1, -42)) /= ieee_positive_inf) call abort 376 dx1 = ieee_value(dx1, ieee_negative_inf) 377 if (ieee_class(ieee_scalb(dx1, -42)) /= ieee_negative_inf) call abort 378 379contains 380 381 subroutine check_equal_float (x, y) 382 real, intent(in) :: x, y 383 if (x /= y) then 384 print *, x, y 385 call abort 386 end if 387 end subroutine 388 389 subroutine check_equal_double (x, y) 390 double precision, intent(in) :: x, y 391 if (x /= y) then 392 print *, x, y 393 call abort 394 end if 395 end subroutine 396 397 subroutine check_not_equal_float (x, y) 398 real, intent(in) :: x, y 399 if (x == y) then 400 print *, x, y 401 call abort 402 end if 403 end subroutine 404 405 subroutine check_not_equal_double (x, y) 406 double precision, intent(in) :: x, y 407 if (x == y) then 408 print *, x, y 409 call abort 410 end if 411 end subroutine 412 413end 414