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