1! { dg-do run } 2! 3! Testing IEEE modules on large real kinds 4 5program test 6 7 use ieee_arithmetic 8 implicit none 9 10 ! k1 and k2 will be large real kinds, if supported, and single/double 11 ! otherwise 12 integer, parameter :: k1 = & 13 max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.)) 14 integer, parameter :: k2 = & 15 max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0)) 16 17 real(kind=k1) :: x1, y1 18 real(kind=k2) :: x2, y2 19 logical :: l 20 21 ! Checking ieee_is_finite 22 23 if (.not. ieee_is_finite(huge(0._k1))) STOP 1 24 if (ieee_is_finite(ieee_value(0._k1, ieee_negative_inf))) STOP 2 25 x1 = -42 26 if (.not. ieee_is_finite(x1)) STOP 3 27 if (ieee_is_finite(sqrt(x1))) STOP 4 28 29 if (.not. ieee_is_finite(huge(0._k2))) STOP 5 30 if (ieee_is_finite(ieee_value(0._k2, ieee_negative_inf))) STOP 6 31 x2 = -42 32 if (.not. ieee_is_finite(x2)) STOP 7 33 if (ieee_is_finite(sqrt(x2))) STOP 8 34 35 ! Other ieee_is intrinsics 36 37 if (ieee_is_nan(huge(0._k1))) STOP 9 38 if (.not. ieee_is_negative(-huge(0._k1))) STOP 10 39 if (.not. ieee_is_normal(-huge(0._k1))) STOP 11 40 41 if (ieee_is_nan(huge(0._k2))) STOP 12 42 if (.not. ieee_is_negative(-huge(0._k2))) STOP 13 43 if (.not. ieee_is_normal(-huge(0._k2))) STOP 14 44 45 ! ieee_support intrinsics 46 47 if (.not. ieee_support_datatype(x1)) STOP 15 48 if (.not. ieee_support_denormal(x1)) STOP 16 49 if (.not. ieee_support_divide(x1)) STOP 17 50 if (.not. ieee_support_inf(x1)) STOP 18 51 if (.not. ieee_support_io(x1)) STOP 19 52 if (.not. ieee_support_nan(x1)) STOP 20 53 if (.not. ieee_support_rounding(ieee_nearest, x1)) STOP 21 54 if (.not. ieee_support_sqrt(x1)) STOP 22 55 if (.not. ieee_support_standard(x1)) STOP 23 56 57 l = ieee_support_underflow_control(x1) 58 59 if (.not. ieee_support_datatype(x2)) STOP 24 60 if (.not. ieee_support_denormal(x2)) STOP 25 61 if (.not. ieee_support_divide(x2)) STOP 26 62 if (.not. ieee_support_inf(x2)) STOP 27 63 if (.not. ieee_support_io(x2)) STOP 28 64 if (.not. ieee_support_nan(x2)) STOP 29 65 if (.not. ieee_support_rounding(ieee_nearest, x2)) STOP 30 66 if (.not. ieee_support_sqrt(x2)) STOP 31 67 if (.not. ieee_support_standard(x2)) STOP 32 68 69 l = ieee_support_underflow_control(x2) 70 71 ! ieee_value and ieee_class 72 73 if (.not. ieee_is_nan(ieee_value(x1, ieee_quiet_nan))) STOP 33 74 if (ieee_class(ieee_value(x1, ieee_positive_denormal)) & 75 /= ieee_positive_denormal) STOP 34 76 77 if (.not. ieee_is_nan(ieee_value(x2, ieee_quiet_nan))) STOP 35 78 if (ieee_class(ieee_value(x2, ieee_positive_denormal)) & 79 /= ieee_positive_denormal) STOP 36 80 81 ! ieee_unordered 82 83 if (.not. ieee_unordered(ieee_value(x1, ieee_quiet_nan), 0._k1)) STOP 37 84 if (ieee_unordered(ieee_value(x1, ieee_negative_inf), 0._k1)) STOP 38 85 86 if (.not. ieee_unordered(ieee_value(x2, ieee_quiet_nan), 0._k2)) STOP 39 87 if (ieee_unordered(ieee_value(x2, ieee_negative_inf), 0._k2)) STOP 40 88 89 ! ieee_copy_sign 90 91 if (.not. ieee_class(ieee_copy_sign(ieee_value(x1, ieee_positive_inf), -1.)) & 92 == ieee_negative_inf) STOP 41 93 if (.not. ieee_class(ieee_copy_sign(0._k1, -42._k2)) & 94 == ieee_negative_zero) STOP 42 95 96 if (.not. ieee_class(ieee_copy_sign(ieee_value(x2, ieee_positive_inf), -1.)) & 97 == ieee_negative_inf) STOP 43 98 if (.not. ieee_class(ieee_copy_sign(0._k2, -42._k1)) & 99 == ieee_negative_zero) STOP 44 100 101 ! ieee_logb 102 103 if (ieee_logb (42._k1) /= exponent(42._k1) - 1) STOP 45 104 105 if (ieee_logb (42._k2) /= exponent(42._k2) - 1) STOP 46 106 107 ! ieee_next_after 108 109 if (ieee_next_after(42._k1, ieee_value(x1, ieee_positive_inf)) & 110 /= 42._k1 + spacing(42._k1)) STOP 47 111 112 if (ieee_next_after(42._k2, ieee_value(x2, ieee_positive_inf)) & 113 /= 42._k2 + spacing(42._k2)) STOP 48 114 115 ! ieee_rem 116 117 if (ieee_class(ieee_rem(-42._k1, 2._k1)) /= ieee_negative_zero) & 118 STOP 49 119 120 if (ieee_class(ieee_rem(-42._k2, 2._k2)) /= ieee_negative_zero) & 121 STOP 50 122 123 ! ieee_rint 124 125 if (ieee_rint(-1.1_k1) /= -1._k1) STOP 51 126 if (ieee_rint(huge(x1)) /= huge(x1)) STOP 52 127 128 if (ieee_rint(-1.1_k2) /= -1._k2) STOP 53 129 if (ieee_rint(huge(x2)) /= huge(x2)) STOP 54 130 131 ! ieee_scalb 132 133 x1 = sqrt(42._k1) 134 if (ieee_scalb(x1, 2) /= 4._k1 * x1) STOP 55 135 if (ieee_scalb(x1, -2) /= x1 / 4._k1) STOP 56 136 137 x2 = sqrt(42._k2) 138 if (ieee_scalb(x2, 2) /= 4._k2 * x2) STOP 57 139 if (ieee_scalb(x2, -2) /= x2 / 4._k2) STOP 58 140 141end program test 142