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) STOP 1 23 if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 2 24 if (ieee_copy_sign(sx1, 1.) /= sx1) STOP 3 25 if (ieee_copy_sign(sx1, -1.) /= -sx1) STOP 4 26 sx1 = huge(sx1) 27 if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 5 28 if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 6 29 if (ieee_copy_sign(sx1, 1.) /= sx1) STOP 7 30 if (ieee_copy_sign(sx1, -1.) /= -sx1) STOP 8 31 sx1 = ieee_value(sx1, ieee_positive_inf) 32 if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 9 33 if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 10 34 if (ieee_copy_sign(sx1, 1.) /= sx1) STOP 11 35 if (ieee_copy_sign(sx1, -1.) /= -sx1) STOP 12 36 sx1 = tiny(sx1) 37 if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 13 38 if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 14 39 if (ieee_copy_sign(sx1, 1.) /= sx1) STOP 15 40 if (ieee_copy_sign(sx1, -1.) /= -sx1) STOP 16 41 sx1 = tiny(sx1) 42 sx1 = sx1 / 101 43 if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 17 44 if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 18 45 if (ieee_copy_sign(sx1, 1.) /= sx1) STOP 19 46 if (ieee_copy_sign(sx1, -1.) /= -sx1) STOP 20 47 48 sx1 = -1.3 49 if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 21 50 if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 22 51 if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) STOP 23 52 if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) STOP 24 53 sx1 = -huge(sx1) 54 if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 25 55 if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 26 56 if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) STOP 27 57 if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) STOP 28 58 sx1 = ieee_value(sx1, ieee_negative_inf) 59 if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 29 60 if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 30 61 if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) STOP 31 62 if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) STOP 32 63 sx1 = -tiny(sx1) 64 if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 33 65 if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 34 66 if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) STOP 35 67 if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) STOP 36 68 sx1 = -tiny(sx1) 69 sx1 = sx1 / 101 70 if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 37 71 if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 38 72 if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) STOP 39 73 if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) STOP 40 74 75 if (ieee_class(ieee_copy_sign(0., -1.)) /= ieee_negative_zero) STOP 41 76 if (ieee_class(ieee_copy_sign(-0., -1.)) /= ieee_negative_zero) STOP 42 77 if (ieee_class(ieee_copy_sign(0., 1.)) /= ieee_positive_zero) STOP 43 78 if (ieee_class(ieee_copy_sign(-0., 1.)) /= ieee_positive_zero) STOP 44 79 80 sx1 = ieee_value(0., ieee_quiet_nan) 81 if (ieee_class(ieee_copy_sign(sx1, 1.)) /= ieee_quiet_nan) STOP 45 82 if (ieee_class(ieee_copy_sign(sx1, -1.)) /= ieee_quiet_nan) STOP 46 83 84 dx1 = 1.3 85 if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 47 86 if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 48 87 if (ieee_copy_sign(dx1, 1.) /= dx1) STOP 49 88 if (ieee_copy_sign(dx1, -1.d0) /= -dx1) STOP 50 89 dx1 = huge(dx1) 90 if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 51 91 if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 52 92 if (ieee_copy_sign(dx1, 1.d0) /= dx1) STOP 53 93 if (ieee_copy_sign(dx1, -1.) /= -dx1) STOP 54 94 dx1 = ieee_value(dx1, ieee_positive_inf) 95 if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 55 96 if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 56 97 if (ieee_copy_sign(dx1, 1.) /= dx1) STOP 57 98 if (ieee_copy_sign(dx1, -1.d0) /= -dx1) STOP 58 99 dx1 = tiny(dx1) 100 if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 59 101 if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 60 102 if (ieee_copy_sign(dx1, 1.d0) /= dx1) STOP 61 103 if (ieee_copy_sign(dx1, -1.) /= -dx1) STOP 62 104 dx1 = tiny(dx1) 105 dx1 = dx1 / 101 106 if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 63 107 if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 64 108 if (ieee_copy_sign(dx1, 1.) /= dx1) STOP 65 109 if (ieee_copy_sign(dx1, -1.d0) /= -dx1) STOP 66 110 111 dx1 = -1.3d0 112 if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 67 113 if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 68 114 if (ieee_copy_sign(dx1, 1.d0) /= abs(dx1)) STOP 69 115 if (ieee_copy_sign(dx1, -1.) /= -abs(dx1)) STOP 70 116 dx1 = -huge(dx1) 117 if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 71 118 if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 72 119 if (ieee_copy_sign(dx1, 1.) /= abs(dx1)) STOP 73 120 if (ieee_copy_sign(dx1, -1.d0) /= -abs(dx1)) STOP 74 121 dx1 = ieee_value(dx1, ieee_negative_inf) 122 if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 75 123 if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 76 124 if (ieee_copy_sign(dx1, 1.d0) /= abs(dx1)) STOP 77 125 if (ieee_copy_sign(dx1, -1.) /= -abs(dx1)) STOP 78 126 dx1 = -tiny(dx1) 127 if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 79 128 if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 80 129 if (ieee_copy_sign(dx1, 1.) /= abs(dx1)) STOP 81 130 if (ieee_copy_sign(dx1, -1.d0) /= -abs(dx1)) STOP 82 131 dx1 = -tiny(dx1) 132 dx1 = dx1 / 101 133 if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 83 134 if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 84 135 if (ieee_copy_sign(dx1, 1.d0) /= abs(dx1)) STOP 85 136 if (ieee_copy_sign(dx1, -1.) /= -abs(dx1)) STOP 86 137 138 if (ieee_class(ieee_copy_sign(0.d0, -1.)) /= ieee_negative_zero) STOP 87 139 if (ieee_class(ieee_copy_sign(-0.d0, -1.)) /= ieee_negative_zero) STOP 88 140 if (ieee_class(ieee_copy_sign(0.d0, 1.)) /= ieee_positive_zero) STOP 89 141 if (ieee_class(ieee_copy_sign(-0.d0, 1.)) /= ieee_positive_zero) STOP 90 142 143 dx1 = ieee_value(0.d0, ieee_quiet_nan) 144 if (ieee_class(ieee_copy_sign(dx1, 1.d0)) /= ieee_quiet_nan) STOP 91 145 if (ieee_class(ieee_copy_sign(dx1, -1.)) /= ieee_quiet_nan) STOP 92 146 147 ! Test IEEE_LOGB 148 149 if (ieee_logb(1.17) /= exponent(1.17) - 1) STOP 93 150 if (ieee_logb(-1.17) /= exponent(-1.17) - 1) STOP 94 151 if (ieee_logb(huge(sx1)) /= exponent(huge(sx1)) - 1) STOP 95 152 if (ieee_logb(-huge(sx1)) /= exponent(-huge(sx1)) - 1) STOP 96 153 if (ieee_logb(tiny(sx1)) /= exponent(tiny(sx1)) - 1) STOP 97 154 if (ieee_logb(-tiny(sx1)) /= exponent(-tiny(sx1)) - 1) STOP 98 155 156 if (ieee_class(ieee_logb(0.)) /= ieee_negative_inf) STOP 99 157 if (ieee_class(ieee_logb(-0.)) /= ieee_negative_inf) STOP 100 158 159 sx1 = ieee_value(sx1, ieee_positive_inf) 160 if (ieee_class(ieee_logb(sx1)) /= ieee_positive_inf) STOP 101 161 if (ieee_class(ieee_logb(-sx1)) /= ieee_positive_inf) STOP 102 162 163 sx1 = ieee_value(sx1, ieee_quiet_nan) 164 if (ieee_class(ieee_logb(sx1)) /= ieee_quiet_nan) STOP 103 165 166 if (ieee_logb(1.17d0) /= exponent(1.17d0) - 1) STOP 104 167 if (ieee_logb(-1.17d0) /= exponent(-1.17d0) - 1) STOP 105 168 if (ieee_logb(huge(dx1)) /= exponent(huge(dx1)) - 1) STOP 106 169 if (ieee_logb(-huge(dx1)) /= exponent(-huge(dx1)) - 1) STOP 107 170 if (ieee_logb(tiny(dx1)) /= exponent(tiny(dx1)) - 1) STOP 108 171 if (ieee_logb(-tiny(dx1)) /= exponent(-tiny(dx1)) - 1) STOP 109 172 173 if (ieee_class(ieee_logb(0.d0)) /= ieee_negative_inf) STOP 110 174 if (ieee_class(ieee_logb(-0.d0)) /= ieee_negative_inf) STOP 111 175 176 dx1 = ieee_value(dx1, ieee_positive_inf) 177 if (ieee_class(ieee_logb(dx1)) /= ieee_positive_inf) STOP 112 178 if (ieee_class(ieee_logb(-dx1)) /= ieee_positive_inf) STOP 113 179 180 dx1 = ieee_value(dx1, ieee_quiet_nan) 181 if (ieee_class(ieee_logb(dx1)) /= ieee_quiet_nan) STOP 114 182 183 ! Test IEEE_NEXT_AFTER 184 185 if (ieee_next_after(0.12, 1.0) /= nearest(0.12, 1.0)) STOP 115 186 if (ieee_next_after(0.12, -1.0) /= nearest(0.12, -1.0)) STOP 116 187 188 sx1 = 0.12 189 if (ieee_next_after(sx1, sx1) /= sx1) STOP 117 190 sx1 = -0.12 191 if (ieee_next_after(sx1, sx1) /= sx1) STOP 118 192 sx1 = huge(sx1) 193 if (ieee_next_after(sx1, sx1) /= sx1) STOP 119 194 sx1 = tiny(sx1) 195 if (ieee_next_after(sx1, sx1) /= sx1) STOP 120 196 sx1 = 0 197 if (ieee_next_after(sx1, sx1) /= sx1) STOP 121 198 sx1 = ieee_value(sx1, ieee_negative_inf) 199 if (ieee_next_after(sx1, sx1) /= sx1) STOP 122 200 sx1 = ieee_value(sx1, ieee_quiet_nan) 201 if (ieee_class(ieee_next_after(sx1, sx1)) /= ieee_quiet_nan) STOP 123 202 203 if (ieee_next_after(0., 1.0) <= 0) STOP 124 204 if (ieee_next_after(0., -1.0) >= 0) STOP 125 205 sx1 = ieee_next_after(huge(sx1), ieee_value(sx1, ieee_negative_inf)) 206 if (.not. sx1 < huge(sx1)) STOP 126 207 sx1 = ieee_next_after(huge(sx1), ieee_value(sx1, ieee_positive_inf)) 208 if (ieee_class(sx1) /= ieee_positive_inf) STOP 127 209 sx1 = ieee_next_after(-tiny(sx1), 1.0) 210 if (ieee_class(sx1) /= ieee_negative_denormal) STOP 128 211 212 if (ieee_next_after(0.12d0, 1.0d0) /= nearest(0.12d0, 1.0)) STOP 129 213 if (ieee_next_after(0.12d0, -1.0) /= nearest(0.12d0, -1.0)) STOP 130 214 215 dx1 = 0.12 216 if (ieee_next_after(dx1, dx1) /= dx1) STOP 131 217 dx1 = -0.12 218 if (ieee_next_after(dx1, dx1) /= dx1) STOP 132 219 dx1 = huge(dx1) 220 if (ieee_next_after(dx1, dx1) /= dx1) STOP 133 221 dx1 = tiny(dx1) 222 if (ieee_next_after(dx1, dx1) /= dx1) STOP 134 223 dx1 = 0 224 if (ieee_next_after(dx1, dx1) /= dx1) STOP 135 225 dx1 = ieee_value(dx1, ieee_negative_inf) 226 if (ieee_next_after(dx1, dx1) /= dx1) STOP 136 227 dx1 = ieee_value(dx1, ieee_quiet_nan) 228 if (ieee_class(ieee_next_after(dx1, dx1)) /= ieee_quiet_nan) STOP 137 229 230 if (ieee_next_after(0.d0, 1.0) <= 0) STOP 138 231 if (ieee_next_after(0.d0, -1.0d0) >= 0) STOP 139 232 dx1 = ieee_next_after(huge(dx1), ieee_value(dx1, ieee_negative_inf)) 233 if (.not. dx1 < huge(dx1)) STOP 140 234 dx1 = ieee_next_after(huge(dx1), ieee_value(dx1, ieee_positive_inf)) 235 if (ieee_class(dx1) /= ieee_positive_inf) STOP 141 236 dx1 = ieee_next_after(-tiny(dx1), 1.0d0) 237 if (ieee_class(dx1) /= ieee_negative_denormal) STOP 142 238 239 ! Test IEEE_REM 240 241 if (ieee_rem(4.0, 3.0) /= 1.0) STOP 143 242 if (ieee_rem(-4.0, 3.0) /= -1.0) STOP 144 243 if (ieee_rem(2.0, 3.0d0) /= -1.0d0) STOP 145 244 if (ieee_rem(-2.0, 3.0d0) /= 1.0d0) STOP 146 245 if (ieee_rem(2.0d0, 3.0d0) /= -1.0d0) STOP 147 246 if (ieee_rem(-2.0d0, 3.0d0) /= 1.0d0) STOP 148 247 248 if (ieee_class(ieee_rem(ieee_value(0., ieee_quiet_nan), 1.0)) & 249 /= ieee_quiet_nan) STOP 149 250 if (ieee_class(ieee_rem(1.0, ieee_value(0.d0, ieee_quiet_nan))) & 251 /= ieee_quiet_nan) STOP 150 252 253 if (ieee_class(ieee_rem(ieee_value(0., ieee_positive_inf), 1.0)) & 254 /= ieee_quiet_nan) STOP 151 255 if (ieee_class(ieee_rem(ieee_value(0.d0, ieee_negative_inf), 1.0)) & 256 /= ieee_quiet_nan) STOP 152 257 if (ieee_rem(-1.0, ieee_value(0., ieee_positive_inf)) & 258 /= -1.0) STOP 153 259 if (ieee_rem(1.0, ieee_value(0.d0, ieee_negative_inf)) & 260 /= 1.0) STOP 154 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) STOP 155 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) STOP 156 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) STOP 157 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) STOP 158 299 end if 300 301 if (ieee_class(ieee_rint(0.)) /= ieee_positive_zero) STOP 159 302 if (ieee_class(ieee_rint(-0.)) /= ieee_negative_zero) STOP 160 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) STOP 161 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) STOP 162 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) STOP 163 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) STOP 164 338 end if 339 340 if (ieee_class(ieee_rint(0.d0)) /= ieee_positive_zero) STOP 165 341 if (ieee_class(ieee_rint(-0.d0)) /= ieee_negative_zero) STOP 166 342 343 ! Test IEEE_SCALB 344 345 sx1 = 1 346 if (ieee_scalb(sx1, 2) /= 4.) STOP 167 347 if (ieee_scalb(-sx1, 2) /= -4.) STOP 168 348 if (ieee_scalb(sx1, -2) /= 1/4.) STOP 169 349 if (ieee_scalb(-sx1, -2) /= -1/4.) STOP 170 350 if (ieee_class(ieee_scalb(sx1, huge(0))) /= ieee_positive_inf) STOP 171 351 if (ieee_class(ieee_scalb(-sx1, huge(0))) /= ieee_negative_inf) STOP 172 352 if (ieee_class(ieee_scalb(sx1, -huge(0))) /= ieee_positive_zero) STOP 173 353 if (ieee_class(ieee_scalb(-sx1, -huge(0))) /= ieee_negative_zero) STOP 174 354 355 sx1 = ieee_value(sx1, ieee_quiet_nan) 356 if (ieee_class(ieee_scalb(sx1, 1)) /= ieee_quiet_nan) STOP 175 357 sx1 = ieee_value(sx1, ieee_positive_inf) 358 if (ieee_class(ieee_scalb(sx1, -42)) /= ieee_positive_inf) STOP 176 359 sx1 = ieee_value(sx1, ieee_negative_inf) 360 if (ieee_class(ieee_scalb(sx1, -42)) /= ieee_negative_inf) STOP 177 361 362 dx1 = 1 363 if (ieee_scalb(dx1, 2) /= 4.d0) STOP 178 364 if (ieee_scalb(-dx1, 2) /= -4.d0) STOP 179 365 if (ieee_scalb(dx1, -2) /= 1/4.d0) STOP 180 366 if (ieee_scalb(-dx1, -2) /= -1/4.d0) STOP 181 367 if (ieee_class(ieee_scalb(dx1, huge(0))) /= ieee_positive_inf) STOP 182 368 if (ieee_class(ieee_scalb(-dx1, huge(0))) /= ieee_negative_inf) STOP 183 369 if (ieee_class(ieee_scalb(dx1, -huge(0))) /= ieee_positive_zero) STOP 184 370 if (ieee_class(ieee_scalb(-dx1, -huge(0))) /= ieee_negative_zero) STOP 185 371 372 dx1 = ieee_value(dx1, ieee_quiet_nan) 373 if (ieee_class(ieee_scalb(dx1, 1)) /= ieee_quiet_nan) STOP 186 374 dx1 = ieee_value(dx1, ieee_positive_inf) 375 if (ieee_class(ieee_scalb(dx1, -42)) /= ieee_positive_inf) STOP 187 376 dx1 = ieee_value(dx1, ieee_negative_inf) 377 if (ieee_class(ieee_scalb(dx1, -42)) /= ieee_negative_inf) STOP 188 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 STOP 189 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 STOP 190 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 STOP 191 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 STOP 192 410 end if 411 end subroutine 412 413end 414