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