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))) call abort 24 if (ieee_is_finite(ieee_value(0._k1, ieee_negative_inf))) call abort 25 x1 = -42 26 if (.not. ieee_is_finite(x1)) call abort 27 if (ieee_is_finite(sqrt(x1))) call abort 28 29 if (.not. ieee_is_finite(huge(0._k2))) call abort 30 if (ieee_is_finite(ieee_value(0._k2, ieee_negative_inf))) call abort 31 x2 = -42 32 if (.not. ieee_is_finite(x2)) call abort 33 if (ieee_is_finite(sqrt(x2))) call abort 34 35 ! Other ieee_is intrinsics 36 37 if (ieee_is_nan(huge(0._k1))) call abort 38 if (.not. ieee_is_negative(-huge(0._k1))) call abort 39 if (.not. ieee_is_normal(-huge(0._k1))) call abort 40 41 if (ieee_is_nan(huge(0._k2))) call abort 42 if (.not. ieee_is_negative(-huge(0._k2))) call abort 43 if (.not. ieee_is_normal(-huge(0._k2))) call abort 44 45 ! ieee_support intrinsics 46 47 if (.not. ieee_support_datatype(x1)) call abort 48 if (.not. ieee_support_denormal(x1)) call abort 49 if (.not. ieee_support_divide(x1)) call abort 50 if (.not. ieee_support_inf(x1)) call abort 51 if (.not. ieee_support_io(x1)) call abort 52 if (.not. ieee_support_nan(x1)) call abort 53 if (.not. ieee_support_rounding(ieee_nearest, x1)) call abort 54 if (.not. ieee_support_sqrt(x1)) call abort 55 if (.not. ieee_support_standard(x1)) call abort 56 57 l = ieee_support_underflow_control(x1) 58 59 if (.not. ieee_support_datatype(x2)) call abort 60 if (.not. ieee_support_denormal(x2)) call abort 61 if (.not. ieee_support_divide(x2)) call abort 62 if (.not. ieee_support_inf(x2)) call abort 63 if (.not. ieee_support_io(x2)) call abort 64 if (.not. ieee_support_nan(x2)) call abort 65 if (.not. ieee_support_rounding(ieee_nearest, x2)) call abort 66 if (.not. ieee_support_sqrt(x2)) call abort 67 if (.not. ieee_support_standard(x2)) call abort 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))) call abort 74 if (ieee_class(ieee_value(x1, ieee_positive_denormal)) & 75 /= ieee_positive_denormal) call abort 76 77 if (.not. ieee_is_nan(ieee_value(x2, ieee_quiet_nan))) call abort 78 if (ieee_class(ieee_value(x2, ieee_positive_denormal)) & 79 /= ieee_positive_denormal) call abort 80 81 ! ieee_unordered 82 83 if (.not. ieee_unordered(ieee_value(x1, ieee_quiet_nan), 0._k1)) call abort 84 if (ieee_unordered(ieee_value(x1, ieee_negative_inf), 0._k1)) call abort 85 86 if (.not. ieee_unordered(ieee_value(x2, ieee_quiet_nan), 0._k2)) call abort 87 if (ieee_unordered(ieee_value(x2, ieee_negative_inf), 0._k2)) call abort 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) call abort 93 if (.not. ieee_class(ieee_copy_sign(0._k1, -42._k2)) & 94 == ieee_negative_zero) call abort 95 96 if (.not. ieee_class(ieee_copy_sign(ieee_value(x2, ieee_positive_inf), -1.)) & 97 == ieee_negative_inf) call abort 98 if (.not. ieee_class(ieee_copy_sign(0._k2, -42._k1)) & 99 == ieee_negative_zero) call abort 100 101 ! ieee_logb 102 103 if (ieee_logb (42._k1) /= exponent(42._k1) - 1) call abort 104 105 if (ieee_logb (42._k2) /= exponent(42._k2) - 1) call abort 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)) call abort 111 112 if (ieee_next_after(42._k2, ieee_value(x2, ieee_positive_inf)) & 113 /= 42._k2 + spacing(42._k2)) call abort 114 115 ! ieee_rem 116 117 if (ieee_class(ieee_rem(-42._k1, 2._k1)) /= ieee_negative_zero) & 118 call abort 119 120 if (ieee_class(ieee_rem(-42._k2, 2._k2)) /= ieee_negative_zero) & 121 call abort 122 123 ! ieee_rint 124 125 if (ieee_rint(-1.1_k1) /= -1._k1) call abort 126 if (ieee_rint(huge(x1)) /= huge(x1)) call abort 127 128 if (ieee_rint(-1.1_k2) /= -1._k2) call abort 129 if (ieee_rint(huge(x2)) /= huge(x2)) call abort 130 131 ! ieee_scalb 132 133 x1 = sqrt(42._k1) 134 if (ieee_scalb(x1, 2) /= 4._k1 * x1) call abort 135 if (ieee_scalb(x1, -2) /= x1 / 4._k1) call abort 136 137 x2 = sqrt(42._k2) 138 if (ieee_scalb(x2, 2) /= 4._k2 * x2) call abort 139 if (ieee_scalb(x2, -2) /= x2 / 4._k2) call abort 140 141end program test 142