3 use, intrinsic :: ieee_features
4 use, intrinsic :: ieee_exceptions
5 use, intrinsic :: ieee_arithmetic
9 procedure check_equal_float
, check_equal_double
12 interface check_not_equal
13 procedure check_not_equal_float
, check_not_equal_double
17 double precision :: dx1
, dx2
, dx3
18 type(ieee_round_type
) :: mode
22 if (ieee_copy_sign(sx1
, sx1
) /= sx1
) call abort
23 if (ieee_copy_sign(sx1
, -sx1
) /= -sx1
) call abort
24 if (ieee_copy_sign(sx1
, 1.) /= sx1
) call abort
25 if (ieee_copy_sign(sx1
, -1.) /= -sx1
) call abort
27 if (ieee_copy_sign(sx1
, sx1
) /= sx1
) call abort
28 if (ieee_copy_sign(sx1
, -sx1
) /= -sx1
) call abort
29 if (ieee_copy_sign(sx1
, 1.) /= sx1
) call abort
30 if (ieee_copy_sign(sx1
, -1.) /= -sx1
) call abort
31 sx1
= ieee_value(sx1
, ieee_positive_inf
)
32 if (ieee_copy_sign(sx1
, sx1
) /= sx1
) call abort
33 if (ieee_copy_sign(sx1
, -sx1
) /= -sx1
) call abort
34 if (ieee_copy_sign(sx1
, 1.) /= sx1
) call abort
35 if (ieee_copy_sign(sx1
, -1.) /= -sx1
) call abort
37 if (ieee_copy_sign(sx1
, sx1
) /= sx1
) call abort
38 if (ieee_copy_sign(sx1
, -sx1
) /= -sx1
) call abort
39 if (ieee_copy_sign(sx1
, 1.) /= sx1
) call abort
40 if (ieee_copy_sign(sx1
, -1.) /= -sx1
) call abort
43 if (ieee_copy_sign(sx1
, sx1
) /= sx1
) call abort
44 if (ieee_copy_sign(sx1
, -sx1
) /= -sx1
) call abort
45 if (ieee_copy_sign(sx1
, 1.) /= sx1
) call abort
46 if (ieee_copy_sign(sx1
, -1.) /= -sx1
) call abort
49 if (ieee_copy_sign(sx1
, sx1
) /= sx1
) call abort
50 if (ieee_copy_sign(sx1
, -sx1
) /= -sx1
) call abort
51 if (ieee_copy_sign(sx1
, 1.) /= abs(sx1
)) call abort
52 if (ieee_copy_sign(sx1
, -1.) /= -abs(sx1
)) call abort
54 if (ieee_copy_sign(sx1
, sx1
) /= sx1
) call abort
55 if (ieee_copy_sign(sx1
, -sx1
) /= -sx1
) call abort
56 if (ieee_copy_sign(sx1
, 1.) /= abs(sx1
)) call abort
57 if (ieee_copy_sign(sx1
, -1.) /= -abs(sx1
)) call abort
58 sx1
= ieee_value(sx1
, ieee_negative_inf
)
59 if (ieee_copy_sign(sx1
, sx1
) /= sx1
) call abort
60 if (ieee_copy_sign(sx1
, -sx1
) /= -sx1
) call abort
61 if (ieee_copy_sign(sx1
, 1.) /= abs(sx1
)) call abort
62 if (ieee_copy_sign(sx1
, -1.) /= -abs(sx1
)) call abort
64 if (ieee_copy_sign(sx1
, sx1
) /= sx1
) call abort
65 if (ieee_copy_sign(sx1
, -sx1
) /= -sx1
) call abort
66 if (ieee_copy_sign(sx1
, 1.) /= abs(sx1
)) call abort
67 if (ieee_copy_sign(sx1
, -1.) /= -abs(sx1
)) call abort
70 if (ieee_copy_sign(sx1
, sx1
) /= sx1
) call abort
71 if (ieee_copy_sign(sx1
, -sx1
) /= -sx1
) call abort
72 if (ieee_copy_sign(sx1
, 1.) /= abs(sx1
)) call abort
73 if (ieee_copy_sign(sx1
, -1.) /= -abs(sx1
)) call abort
75 if (ieee_class(ieee_copy_sign(0., -1.)) /= ieee_negative_zero
) call abort
76 if (ieee_class(ieee_copy_sign(-0., -1.)) /= ieee_negative_zero
) call abort
77 if (ieee_class(ieee_copy_sign(0., 1.)) /= ieee_positive_zero
) call abort
78 if (ieee_class(ieee_copy_sign(-0., 1.)) /= ieee_positive_zero
) call abort
80 sx1
= ieee_value(0., ieee_quiet_nan
)
81 if (ieee_class(ieee_copy_sign(sx1
, 1.)) /= ieee_quiet_nan
) call abort
82 if (ieee_class(ieee_copy_sign(sx1
, -1.)) /= ieee_quiet_nan
) call abort
85 if (ieee_copy_sign(dx1
, dx1
) /= dx1
) call abort
86 if (ieee_copy_sign(dx1
, -dx1
) /= -dx1
) call abort
87 if (ieee_copy_sign(dx1
, 1.) /= dx1
) call abort
88 if (ieee_copy_sign(dx1
, -1.d0
) /= -dx1
) call abort
90 if (ieee_copy_sign(dx1
, dx1
) /= dx1
) call abort
91 if (ieee_copy_sign(dx1
, -dx1
) /= -dx1
) call abort
92 if (ieee_copy_sign(dx1
, 1.d0
) /= dx1
) call abort
93 if (ieee_copy_sign(dx1
, -1.) /= -dx1
) call abort
94 dx1
= ieee_value(dx1
, ieee_positive_inf
)
95 if (ieee_copy_sign(dx1
, dx1
) /= dx1
) call abort
96 if (ieee_copy_sign(dx1
, -dx1
) /= -dx1
) call abort
97 if (ieee_copy_sign(dx1
, 1.) /= dx1
) call abort
98 if (ieee_copy_sign(dx1
, -1.d0
) /= -dx1
) call abort
100 if (ieee_copy_sign(dx1
, dx1
) /= dx1
) call abort
101 if (ieee_copy_sign(dx1
, -dx1
) /= -dx1
) call abort
102 if (ieee_copy_sign(dx1
, 1.d0
) /= dx1
) call abort
103 if (ieee_copy_sign(dx1
, -1.) /= -dx1
) call abort
106 if (ieee_copy_sign(dx1
, dx1
) /= dx1
) call abort
107 if (ieee_copy_sign(dx1
, -dx1
) /= -dx1
) call abort
108 if (ieee_copy_sign(dx1
, 1.) /= dx1
) call abort
109 if (ieee_copy_sign(dx1
, -1.d0
) /= -dx1
) call abort
112 if (ieee_copy_sign(dx1
, dx1
) /= dx1
) call abort
113 if (ieee_copy_sign(dx1
, -dx1
) /= -dx1
) call abort
114 if (ieee_copy_sign(dx1
, 1.d0
) /= abs(dx1
)) call abort
115 if (ieee_copy_sign(dx1
, -1.) /= -abs(dx1
)) call abort
117 if (ieee_copy_sign(dx1
, dx1
) /= dx1
) call abort
118 if (ieee_copy_sign(dx1
, -dx1
) /= -dx1
) call abort
119 if (ieee_copy_sign(dx1
, 1.) /= abs(dx1
)) call abort
120 if (ieee_copy_sign(dx1
, -1.d0
) /= -abs(dx1
)) call abort
121 dx1
= ieee_value(dx1
, ieee_negative_inf
)
122 if (ieee_copy_sign(dx1
, dx1
) /= dx1
) call abort
123 if (ieee_copy_sign(dx1
, -dx1
) /= -dx1
) call abort
124 if (ieee_copy_sign(dx1
, 1.d0
) /= abs(dx1
)) call abort
125 if (ieee_copy_sign(dx1
, -1.) /= -abs(dx1
)) call abort
127 if (ieee_copy_sign(dx1
, dx1
) /= dx1
) call abort
128 if (ieee_copy_sign(dx1
, -dx1
) /= -dx1
) call abort
129 if (ieee_copy_sign(dx1
, 1.) /= abs(dx1
)) call abort
130 if (ieee_copy_sign(dx1
, -1.d0
) /= -abs(dx1
)) call abort
133 if (ieee_copy_sign(dx1
, dx1
) /= dx1
) call abort
134 if (ieee_copy_sign(dx1
, -dx1
) /= -dx1
) call abort
135 if (ieee_copy_sign(dx1
, 1.d0
) /= abs(dx1
)) call abort
136 if (ieee_copy_sign(dx1
, -1.) /= -abs(dx1
)) call abort
138 if (ieee_class(ieee_copy_sign(0.d0
, -1.)) /= ieee_negative_zero
) call abort
139 if (ieee_class(ieee_copy_sign(-0.d0
, -1.)) /= ieee_negative_zero
) call abort
140 if (ieee_class(ieee_copy_sign(0.d0
, 1.)) /= ieee_positive_zero
) call abort
141 if (ieee_class(ieee_copy_sign(-0.d0
, 1.)) /= ieee_positive_zero
) call abort
143 dx1
= ieee_value(0.d0
, ieee_quiet_nan
)
144 if (ieee_class(ieee_copy_sign(dx1
, 1.d0
)) /= ieee_quiet_nan
) call abort
145 if (ieee_class(ieee_copy_sign(dx1
, -1.)) /= ieee_quiet_nan
) call abort
149 if (ieee_logb(1.17) /= exponent(1.17) - 1) call abort
150 if (ieee_logb(-1.17) /= exponent(-1.17) - 1) call abort
151 if (ieee_logb(huge(sx1
)) /= exponent(huge(sx1
)) - 1) call abort
152 if (ieee_logb(-huge(sx1
)) /= exponent(-huge(sx1
)) - 1) call abort
153 if (ieee_logb(tiny(sx1
)) /= exponent(tiny(sx1
)) - 1) call abort
154 if (ieee_logb(-tiny(sx1
)) /= exponent(-tiny(sx1
)) - 1) call abort
156 if (ieee_class(ieee_logb(0.)) /= ieee_negative_inf
) call abort
157 if (ieee_class(ieee_logb(-0.)) /= ieee_negative_inf
) call abort
159 sx1
= ieee_value(sx1
, ieee_positive_inf
)
160 if (ieee_class(ieee_logb(sx1
)) /= ieee_positive_inf
) call abort
161 if (ieee_class(ieee_logb(-sx1
)) /= ieee_positive_inf
) call abort
163 sx1
= ieee_value(sx1
, ieee_quiet_nan
)
164 if (ieee_class(ieee_logb(sx1
)) /= ieee_quiet_nan
) call abort
166 if (ieee_logb(1.17d0) /= exponent(1.17d0) - 1) call abort
167 if (ieee_logb(-1.17d0) /= exponent(-1.17d0) - 1) call abort
168 if (ieee_logb(huge(dx1
)) /= exponent(huge(dx1
)) - 1) call abort
169 if (ieee_logb(-huge(dx1
)) /= exponent(-huge(dx1
)) - 1) call abort
170 if (ieee_logb(tiny(dx1
)) /= exponent(tiny(dx1
)) - 1) call abort
171 if (ieee_logb(-tiny(dx1
)) /= exponent(-tiny(dx1
)) - 1) call abort
173 if (ieee_class(ieee_logb(0.d0
)) /= ieee_negative_inf
) call abort
174 if (ieee_class(ieee_logb(-0.d0
)) /= ieee_negative_inf
) call abort
176 dx1
= ieee_value(dx1
, ieee_positive_inf
)
177 if (ieee_class(ieee_logb(dx1
)) /= ieee_positive_inf
) call abort
178 if (ieee_class(ieee_logb(-dx1
)) /= ieee_positive_inf
) call abort
180 dx1
= ieee_value(dx1
, ieee_quiet_nan
)
181 if (ieee_class(ieee_logb(dx1
)) /= ieee_quiet_nan
) call abort
183 ! Test IEEE_NEXT_AFTER
185 if (ieee_next_after(0.12, 1.0) /= nearest(0.12, 1.0)) call abort
186 if (ieee_next_after(0.12, -1.0) /= nearest(0.12, -1.0)) call abort
189 if (ieee_next_after(sx1
, sx1
) /= sx1
) call abort
191 if (ieee_next_after(sx1
, sx1
) /= sx1
) call abort
193 if (ieee_next_after(sx1
, sx1
) /= sx1
) call abort
195 if (ieee_next_after(sx1
, sx1
) /= sx1
) call abort
197 if (ieee_next_after(sx1
, sx1
) /= sx1
) call abort
198 sx1
= ieee_value(sx1
, ieee_negative_inf
)
199 if (ieee_next_after(sx1
, sx1
) /= sx1
) call abort
200 sx1
= ieee_value(sx1
, ieee_quiet_nan
)
201 if (ieee_class(ieee_next_after(sx1
, sx1
)) /= ieee_quiet_nan
) call abort
203 if (ieee_next_after(0., 1.0) <= 0) call abort
204 if (ieee_next_after(0., -1.0) >= 0) call abort
205 sx1
= ieee_next_after(huge(sx1
), ieee_value(sx1
, ieee_negative_inf
))
206 if (.not
. sx1
< huge(sx1
)) call abort
207 sx1
= ieee_next_after(huge(sx1
), ieee_value(sx1
, ieee_positive_inf
))
208 if (ieee_class(sx1
) /= ieee_positive_inf
) call abort
209 sx1
= ieee_next_after(-tiny(sx1
), 1.0)
210 if (ieee_class(sx1
) /= ieee_negative_denormal
) call abort
212 if (ieee_next_after(0.12d0, 1.0d0) /= nearest(0.12d0, 1.0)) call abort
213 if (ieee_next_after(0.12d0, -1.0) /= nearest(0.12d0, -1.0)) call abort
216 if (ieee_next_after(dx1
, dx1
) /= dx1
) call abort
218 if (ieee_next_after(dx1
, dx1
) /= dx1
) call abort
220 if (ieee_next_after(dx1
, dx1
) /= dx1
) call abort
222 if (ieee_next_after(dx1
, dx1
) /= dx1
) call abort
224 if (ieee_next_after(dx1
, dx1
) /= dx1
) call abort
225 dx1
= ieee_value(dx1
, ieee_negative_inf
)
226 if (ieee_next_after(dx1
, dx1
) /= dx1
) call abort
227 dx1
= ieee_value(dx1
, ieee_quiet_nan
)
228 if (ieee_class(ieee_next_after(dx1
, dx1
)) /= ieee_quiet_nan
) call abort
230 if (ieee_next_after(0.d0
, 1.0) <= 0) call abort
231 if (ieee_next_after(0.d0
, -1.0d0) >= 0) call abort
232 dx1
= ieee_next_after(huge(dx1
), ieee_value(dx1
, ieee_negative_inf
))
233 if (.not
. dx1
< huge(dx1
)) call abort
234 dx1
= ieee_next_after(huge(dx1
), ieee_value(dx1
, ieee_positive_inf
))
235 if (ieee_class(dx1
) /= ieee_positive_inf
) call abort
236 dx1
= ieee_next_after(-tiny(dx1
), 1.0d0)
237 if (ieee_class(dx1
) /= ieee_negative_denormal
) call abort
241 if (ieee_rem(4.0, 3.0) /= 1.0) call abort
242 if (ieee_rem(-4.0, 3.0) /= -1.0) call abort
243 if (ieee_rem(2.0, 3.0d0) /= -1.0d0) call abort
244 if (ieee_rem(-2.0, 3.0d0) /= 1.0d0) call abort
245 if (ieee_rem(2.0d0, 3.0d0) /= -1.0d0) call abort
246 if (ieee_rem(-2.0d0, 3.0d0) /= 1.0d0) call abort
248 if (ieee_class(ieee_rem(ieee_value(0., ieee_quiet_nan
), 1.0)) &
249 /= ieee_quiet_nan
) call abort
250 if (ieee_class(ieee_rem(1.0, ieee_value(0.d0
, ieee_quiet_nan
))) &
251 /= ieee_quiet_nan
) call abort
253 if (ieee_class(ieee_rem(ieee_value(0., ieee_positive_inf
), 1.0)) &
254 /= ieee_quiet_nan
) call abort
255 if (ieee_class(ieee_rem(ieee_value(0.d0
, ieee_negative_inf
), 1.0)) &
256 /= ieee_quiet_nan
) call abort
257 if (ieee_rem(-1.0, ieee_value(0., ieee_positive_inf
)) &
259 if (ieee_rem(1.0, ieee_value(0.d0
, ieee_negative_inf
)) &
265 if (ieee_support_rounding (ieee_nearest
, sx1
)) then
266 call ieee_get_rounding_mode (mode
)
267 call ieee_set_rounding_mode (ieee_nearest
)
269 sx1
= ieee_rint (sx1
)
270 call ieee_set_rounding_mode (mode
)
271 if (sx1
/= 2) call abort
274 if (ieee_support_rounding (ieee_up
, sx1
)) then
275 call ieee_get_rounding_mode (mode
)
276 call ieee_set_rounding_mode (ieee_up
)
278 sx1
= ieee_rint (sx1
)
279 call ieee_set_rounding_mode (mode
)
280 if (sx1
/= 3) call abort
283 if (ieee_support_rounding (ieee_down
, sx1
)) then
284 call ieee_get_rounding_mode (mode
)
285 call ieee_set_rounding_mode (ieee_down
)
287 sx1
= ieee_rint (sx1
)
288 call ieee_set_rounding_mode (mode
)
289 if (sx1
/= 2) call abort
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
)
296 sx1
= ieee_rint (sx1
)
297 call ieee_set_rounding_mode (mode
)
298 if (sx1
/= 2) call abort
301 if (ieee_class(ieee_rint(0.)) /= ieee_positive_zero
) call abort
302 if (ieee_class(ieee_rint(-0.)) /= ieee_negative_zero
) call abort
304 if (ieee_support_rounding (ieee_nearest
, dx1
)) then
305 call ieee_get_rounding_mode (mode
)
306 call ieee_set_rounding_mode (ieee_nearest
)
308 dx1
= ieee_rint (dx1
)
309 call ieee_set_rounding_mode (mode
)
310 if (dx1
/= 2) call abort
313 if (ieee_support_rounding (ieee_up
, dx1
)) then
314 call ieee_get_rounding_mode (mode
)
315 call ieee_set_rounding_mode (ieee_up
)
317 dx1
= ieee_rint (dx1
)
318 call ieee_set_rounding_mode (mode
)
319 if (dx1
/= 3) call abort
322 if (ieee_support_rounding (ieee_down
, dx1
)) then
323 call ieee_get_rounding_mode (mode
)
324 call ieee_set_rounding_mode (ieee_down
)
326 dx1
= ieee_rint (dx1
)
327 call ieee_set_rounding_mode (mode
)
328 if (dx1
/= 2) call abort
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
)
335 dx1
= ieee_rint (dx1
)
336 call ieee_set_rounding_mode (mode
)
337 if (dx1
/= 2) call abort
340 if (ieee_class(ieee_rint(0.d0
)) /= ieee_positive_zero
) call abort
341 if (ieee_class(ieee_rint(-0.d0
)) /= ieee_negative_zero
) call abort
346 if (ieee_scalb(sx1
, 2) /= 4.) call abort
347 if (ieee_scalb(-sx1
, 2) /= -4.) call abort
348 if (ieee_scalb(sx1
, -2) /= 1/4.) call abort
349 if (ieee_scalb(-sx1
, -2) /= -1/4.) call abort
350 if (ieee_class(ieee_scalb(sx1
, huge(0))) /= ieee_positive_inf
) call abort
351 if (ieee_class(ieee_scalb(-sx1
, huge(0))) /= ieee_negative_inf
) call abort
352 if (ieee_class(ieee_scalb(sx1
, -huge(0))) /= ieee_positive_zero
) call abort
353 if (ieee_class(ieee_scalb(-sx1
, -huge(0))) /= ieee_negative_zero
) call abort
355 sx1
= ieee_value(sx1
, ieee_quiet_nan
)
356 if (ieee_class(ieee_scalb(sx1
, 1)) /= ieee_quiet_nan
) call abort
357 sx1
= ieee_value(sx1
, ieee_positive_inf
)
358 if (ieee_class(ieee_scalb(sx1
, -42)) /= ieee_positive_inf
) call abort
359 sx1
= ieee_value(sx1
, ieee_negative_inf
)
360 if (ieee_class(ieee_scalb(sx1
, -42)) /= ieee_negative_inf
) call abort
363 if (ieee_scalb(dx1
, 2) /= 4.d0
) call abort
364 if (ieee_scalb(-dx1
, 2) /= -4.d0
) call abort
365 if (ieee_scalb(dx1
, -2) /= 1/4.d0
) call abort
366 if (ieee_scalb(-dx1
, -2) /= -1/4.d0
) call abort
367 if (ieee_class(ieee_scalb(dx1
, huge(0))) /= ieee_positive_inf
) call abort
368 if (ieee_class(ieee_scalb(-dx1
, huge(0))) /= ieee_negative_inf
) call abort
369 if (ieee_class(ieee_scalb(dx1
, -huge(0))) /= ieee_positive_zero
) call abort
370 if (ieee_class(ieee_scalb(-dx1
, -huge(0))) /= ieee_negative_zero
) call abort
372 dx1
= ieee_value(dx1
, ieee_quiet_nan
)
373 if (ieee_class(ieee_scalb(dx1
, 1)) /= ieee_quiet_nan
) call abort
374 dx1
= ieee_value(dx1
, ieee_positive_inf
)
375 if (ieee_class(ieee_scalb(dx1
, -42)) /= ieee_positive_inf
) call abort
376 dx1
= ieee_value(dx1
, ieee_negative_inf
)
377 if (ieee_class(ieee_scalb(dx1
, -42)) /= ieee_negative_inf
) call abort
381 subroutine check_equal_float (x
, y
)
382 real, intent(in
) :: x
, y
389 subroutine check_equal_double (x
, y
)
390 double precision, intent(in
) :: x
, y
397 subroutine check_not_equal_float (x
, y
)
398 real, intent(in
) :: x
, y
405 subroutine check_not_equal_double (x
, y
)
406 double precision, intent(in
) :: x
, y