1! { dg-do run }
2
3  use, intrinsic :: ieee_features
4  use, intrinsic :: ieee_exceptions
5  use, intrinsic :: ieee_arithmetic
6  implicit none
7
8  interface check_equal
9    procedure check_equal_float, check_equal_double
10  end interface
11
12  interface check_not_equal
13    procedure check_not_equal_float, check_not_equal_double
14  end interface
15
16  real :: sx1, sx2, sx3
17  double precision :: dx1, dx2, dx3
18  type(ieee_round_type) :: mode
19
20  ! Test IEEE_COPY_SIGN
21  sx1 = 1.3
22  if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 1
23  if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 2
24  if (ieee_copy_sign(sx1, 1.) /= sx1) STOP 3
25  if (ieee_copy_sign(sx1, -1.) /= -sx1) STOP 4
26  sx1 = huge(sx1)
27  if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 5
28  if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 6
29  if (ieee_copy_sign(sx1, 1.) /= sx1) STOP 7
30  if (ieee_copy_sign(sx1, -1.) /= -sx1) STOP 8
31  sx1 = ieee_value(sx1, ieee_positive_inf)
32  if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 9
33  if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 10
34  if (ieee_copy_sign(sx1, 1.) /= sx1) STOP 11
35  if (ieee_copy_sign(sx1, -1.) /= -sx1) STOP 12
36  sx1 = tiny(sx1)
37  if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 13
38  if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 14
39  if (ieee_copy_sign(sx1, 1.) /= sx1) STOP 15
40  if (ieee_copy_sign(sx1, -1.) /= -sx1) STOP 16
41  sx1 = tiny(sx1)
42  sx1 = sx1 / 101
43  if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 17
44  if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 18
45  if (ieee_copy_sign(sx1, 1.) /= sx1) STOP 19
46  if (ieee_copy_sign(sx1, -1.) /= -sx1) STOP 20
47
48  sx1 = -1.3
49  if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 21
50  if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 22
51  if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) STOP 23
52  if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) STOP 24
53  sx1 = -huge(sx1)
54  if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 25
55  if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 26
56  if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) STOP 27
57  if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) STOP 28
58  sx1 = ieee_value(sx1, ieee_negative_inf)
59  if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 29
60  if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 30
61  if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) STOP 31
62  if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) STOP 32
63  sx1 = -tiny(sx1)
64  if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 33
65  if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 34
66  if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) STOP 35
67  if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) STOP 36
68  sx1 = -tiny(sx1)
69  sx1 = sx1 / 101
70  if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 37
71  if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 38
72  if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) STOP 39
73  if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) STOP 40
74
75  if (ieee_class(ieee_copy_sign(0., -1.)) /= ieee_negative_zero) STOP 41
76  if (ieee_class(ieee_copy_sign(-0., -1.)) /= ieee_negative_zero) STOP 42
77  if (ieee_class(ieee_copy_sign(0., 1.)) /= ieee_positive_zero) STOP 43
78  if (ieee_class(ieee_copy_sign(-0., 1.)) /= ieee_positive_zero) STOP 44
79
80  sx1 = ieee_value(0., ieee_quiet_nan)
81  if (ieee_class(ieee_copy_sign(sx1, 1.)) /= ieee_quiet_nan) STOP 45
82  if (ieee_class(ieee_copy_sign(sx1, -1.)) /= ieee_quiet_nan) STOP 46
83
84  dx1 = 1.3
85  if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 47
86  if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 48
87  if (ieee_copy_sign(dx1, 1.) /= dx1) STOP 49
88  if (ieee_copy_sign(dx1, -1.d0) /= -dx1) STOP 50
89  dx1 = huge(dx1)
90  if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 51
91  if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 52
92  if (ieee_copy_sign(dx1, 1.d0) /= dx1) STOP 53
93  if (ieee_copy_sign(dx1, -1.) /= -dx1) STOP 54
94  dx1 = ieee_value(dx1, ieee_positive_inf)
95  if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 55
96  if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 56
97  if (ieee_copy_sign(dx1, 1.) /= dx1) STOP 57
98  if (ieee_copy_sign(dx1, -1.d0) /= -dx1) STOP 58
99  dx1 = tiny(dx1)
100  if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 59
101  if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 60
102  if (ieee_copy_sign(dx1, 1.d0) /= dx1) STOP 61
103  if (ieee_copy_sign(dx1, -1.) /= -dx1) STOP 62
104  dx1 = tiny(dx1)
105  dx1 = dx1 / 101
106  if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 63
107  if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 64
108  if (ieee_copy_sign(dx1, 1.) /= dx1) STOP 65
109  if (ieee_copy_sign(dx1, -1.d0) /= -dx1) STOP 66
110
111  dx1 = -1.3d0
112  if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 67
113  if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 68
114  if (ieee_copy_sign(dx1, 1.d0) /= abs(dx1)) STOP 69
115  if (ieee_copy_sign(dx1, -1.) /= -abs(dx1)) STOP 70
116  dx1 = -huge(dx1)
117  if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 71
118  if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 72
119  if (ieee_copy_sign(dx1, 1.) /= abs(dx1)) STOP 73
120  if (ieee_copy_sign(dx1, -1.d0) /= -abs(dx1)) STOP 74
121  dx1 = ieee_value(dx1, ieee_negative_inf)
122  if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 75
123  if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 76
124  if (ieee_copy_sign(dx1, 1.d0) /= abs(dx1)) STOP 77
125  if (ieee_copy_sign(dx1, -1.) /= -abs(dx1)) STOP 78
126  dx1 = -tiny(dx1)
127  if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 79
128  if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 80
129  if (ieee_copy_sign(dx1, 1.) /= abs(dx1)) STOP 81
130  if (ieee_copy_sign(dx1, -1.d0) /= -abs(dx1)) STOP 82
131  dx1 = -tiny(dx1)
132  dx1 = dx1 / 101
133  if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 83
134  if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 84
135  if (ieee_copy_sign(dx1, 1.d0) /= abs(dx1)) STOP 85
136  if (ieee_copy_sign(dx1, -1.) /= -abs(dx1)) STOP 86
137
138  if (ieee_class(ieee_copy_sign(0.d0, -1.)) /= ieee_negative_zero) STOP 87
139  if (ieee_class(ieee_copy_sign(-0.d0, -1.)) /= ieee_negative_zero) STOP 88
140  if (ieee_class(ieee_copy_sign(0.d0, 1.)) /= ieee_positive_zero) STOP 89
141  if (ieee_class(ieee_copy_sign(-0.d0, 1.)) /= ieee_positive_zero) STOP 90
142
143  dx1 = ieee_value(0.d0, ieee_quiet_nan)
144  if (ieee_class(ieee_copy_sign(dx1, 1.d0)) /= ieee_quiet_nan) STOP 91
145  if (ieee_class(ieee_copy_sign(dx1, -1.)) /= ieee_quiet_nan) STOP 92
146
147  ! Test IEEE_LOGB
148
149  if (ieee_logb(1.17) /= exponent(1.17) - 1) STOP 93
150  if (ieee_logb(-1.17) /= exponent(-1.17) - 1) STOP 94
151  if (ieee_logb(huge(sx1)) /= exponent(huge(sx1)) - 1) STOP 95
152  if (ieee_logb(-huge(sx1)) /= exponent(-huge(sx1)) - 1) STOP 96
153  if (ieee_logb(tiny(sx1)) /= exponent(tiny(sx1)) - 1) STOP 97
154  if (ieee_logb(-tiny(sx1)) /= exponent(-tiny(sx1)) - 1) STOP 98
155
156  if (ieee_class(ieee_logb(0.)) /= ieee_negative_inf) STOP 99
157  if (ieee_class(ieee_logb(-0.)) /= ieee_negative_inf) STOP 100
158
159  sx1 = ieee_value(sx1, ieee_positive_inf)
160  if (ieee_class(ieee_logb(sx1)) /= ieee_positive_inf) STOP 101
161  if (ieee_class(ieee_logb(-sx1)) /= ieee_positive_inf) STOP 102
162
163  sx1 = ieee_value(sx1, ieee_quiet_nan)
164  if (ieee_class(ieee_logb(sx1)) /= ieee_quiet_nan) STOP 103
165
166  if (ieee_logb(1.17d0) /= exponent(1.17d0) - 1) STOP 104
167  if (ieee_logb(-1.17d0) /= exponent(-1.17d0) - 1) STOP 105
168  if (ieee_logb(huge(dx1)) /= exponent(huge(dx1)) - 1) STOP 106
169  if (ieee_logb(-huge(dx1)) /= exponent(-huge(dx1)) - 1) STOP 107
170  if (ieee_logb(tiny(dx1)) /= exponent(tiny(dx1)) - 1) STOP 108
171  if (ieee_logb(-tiny(dx1)) /= exponent(-tiny(dx1)) - 1) STOP 109
172
173  if (ieee_class(ieee_logb(0.d0)) /= ieee_negative_inf) STOP 110
174  if (ieee_class(ieee_logb(-0.d0)) /= ieee_negative_inf) STOP 111
175
176  dx1 = ieee_value(dx1, ieee_positive_inf)
177  if (ieee_class(ieee_logb(dx1)) /= ieee_positive_inf) STOP 112
178  if (ieee_class(ieee_logb(-dx1)) /= ieee_positive_inf) STOP 113
179
180  dx1 = ieee_value(dx1, ieee_quiet_nan)
181  if (ieee_class(ieee_logb(dx1)) /= ieee_quiet_nan) STOP 114
182
183  ! Test IEEE_NEXT_AFTER
184
185  if (ieee_next_after(0.12, 1.0) /= nearest(0.12, 1.0)) STOP 115
186  if (ieee_next_after(0.12, -1.0) /= nearest(0.12, -1.0)) STOP 116
187
188  sx1 = 0.12
189  if (ieee_next_after(sx1, sx1) /= sx1) STOP 117
190  sx1 = -0.12
191  if (ieee_next_after(sx1, sx1) /= sx1) STOP 118
192  sx1 = huge(sx1)
193  if (ieee_next_after(sx1, sx1) /= sx1) STOP 119
194  sx1 = tiny(sx1)
195  if (ieee_next_after(sx1, sx1) /= sx1) STOP 120
196  sx1 = 0
197  if (ieee_next_after(sx1, sx1) /= sx1) STOP 121
198  sx1 = ieee_value(sx1, ieee_negative_inf)
199  if (ieee_next_after(sx1, sx1) /= sx1) STOP 122
200  sx1 = ieee_value(sx1, ieee_quiet_nan)
201  if (ieee_class(ieee_next_after(sx1, sx1)) /= ieee_quiet_nan) STOP 123
202
203  if (ieee_next_after(0., 1.0) <= 0) STOP 124
204  if (ieee_next_after(0., -1.0) >= 0) STOP 125
205  sx1 = ieee_next_after(huge(sx1), ieee_value(sx1, ieee_negative_inf))
206  if (.not. sx1 < huge(sx1)) STOP 126
207  sx1 = ieee_next_after(huge(sx1), ieee_value(sx1, ieee_positive_inf))
208  if (ieee_class(sx1) /= ieee_positive_inf) STOP 127
209  sx1 = ieee_next_after(-tiny(sx1), 1.0)
210  if (ieee_class(sx1) /= ieee_negative_denormal) STOP 128
211
212  if (ieee_next_after(0.12d0, 1.0d0) /= nearest(0.12d0, 1.0)) STOP 129
213  if (ieee_next_after(0.12d0, -1.0) /= nearest(0.12d0, -1.0)) STOP 130
214
215  dx1 = 0.12
216  if (ieee_next_after(dx1, dx1) /= dx1) STOP 131
217  dx1 = -0.12
218  if (ieee_next_after(dx1, dx1) /= dx1) STOP 132
219  dx1 = huge(dx1)
220  if (ieee_next_after(dx1, dx1) /= dx1) STOP 133
221  dx1 = tiny(dx1)
222  if (ieee_next_after(dx1, dx1) /= dx1) STOP 134
223  dx1 = 0
224  if (ieee_next_after(dx1, dx1) /= dx1) STOP 135
225  dx1 = ieee_value(dx1, ieee_negative_inf)
226  if (ieee_next_after(dx1, dx1) /= dx1) STOP 136
227  dx1 = ieee_value(dx1, ieee_quiet_nan)
228  if (ieee_class(ieee_next_after(dx1, dx1)) /= ieee_quiet_nan) STOP 137
229
230  if (ieee_next_after(0.d0, 1.0) <= 0) STOP 138
231  if (ieee_next_after(0.d0, -1.0d0) >= 0) STOP 139
232  dx1 = ieee_next_after(huge(dx1), ieee_value(dx1, ieee_negative_inf))
233  if (.not. dx1 < huge(dx1)) STOP 140
234  dx1 = ieee_next_after(huge(dx1), ieee_value(dx1, ieee_positive_inf))
235  if (ieee_class(dx1) /= ieee_positive_inf) STOP 141
236  dx1 = ieee_next_after(-tiny(dx1), 1.0d0)
237  if (ieee_class(dx1) /= ieee_negative_denormal) STOP 142
238
239  ! Test IEEE_REM
240
241  if (ieee_rem(4.0, 3.0) /= 1.0) STOP 143
242  if (ieee_rem(-4.0, 3.0) /= -1.0) STOP 144
243  if (ieee_rem(2.0, 3.0d0) /= -1.0d0) STOP 145
244  if (ieee_rem(-2.0, 3.0d0) /= 1.0d0) STOP 146
245  if (ieee_rem(2.0d0, 3.0d0) /= -1.0d0) STOP 147
246  if (ieee_rem(-2.0d0, 3.0d0) /= 1.0d0) STOP 148
247
248  if (ieee_class(ieee_rem(ieee_value(0., ieee_quiet_nan), 1.0)) &
249      /= ieee_quiet_nan) STOP 149
250  if (ieee_class(ieee_rem(1.0, ieee_value(0.d0, ieee_quiet_nan))) &
251      /= ieee_quiet_nan) STOP 150
252
253  if (ieee_class(ieee_rem(ieee_value(0., ieee_positive_inf), 1.0)) &
254      /= ieee_quiet_nan) STOP 151
255  if (ieee_class(ieee_rem(ieee_value(0.d0, ieee_negative_inf), 1.0)) &
256      /= ieee_quiet_nan) STOP 152
257  if (ieee_rem(-1.0, ieee_value(0., ieee_positive_inf)) &
258      /= -1.0) STOP 153
259  if (ieee_rem(1.0, ieee_value(0.d0, ieee_negative_inf)) &
260      /= 1.0) STOP 154
261
262
263  ! Test IEEE_RINT
264
265  if (ieee_support_rounding (ieee_nearest, sx1)) then
266    call ieee_get_rounding_mode (mode)
267    call ieee_set_rounding_mode (ieee_nearest)
268    sx1 = 7 / 3.
269    sx1 = ieee_rint (sx1)
270    call ieee_set_rounding_mode (mode)
271    if (sx1 /= 2) STOP 155
272  end if
273
274  if (ieee_support_rounding (ieee_up, sx1)) then
275    call ieee_get_rounding_mode (mode)
276    call ieee_set_rounding_mode (ieee_up)
277    sx1 = 7 / 3.
278    sx1 = ieee_rint (sx1)
279    call ieee_set_rounding_mode (mode)
280    if (sx1 /= 3) STOP 156
281  end if
282
283  if (ieee_support_rounding (ieee_down, sx1)) then
284    call ieee_get_rounding_mode (mode)
285    call ieee_set_rounding_mode (ieee_down)
286    sx1 = 7 / 3.
287    sx1 = ieee_rint (sx1)
288    call ieee_set_rounding_mode (mode)
289    if (sx1 /= 2) STOP 157
290  end if
291
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)
295    sx1 = 7 / 3.
296    sx1 = ieee_rint (sx1)
297    call ieee_set_rounding_mode (mode)
298    if (sx1 /= 2) STOP 158
299  end if
300
301  if (ieee_class(ieee_rint(0.)) /= ieee_positive_zero) STOP 159
302  if (ieee_class(ieee_rint(-0.)) /= ieee_negative_zero) STOP 160
303
304  if (ieee_support_rounding (ieee_nearest, dx1)) then
305    call ieee_get_rounding_mode (mode)
306    call ieee_set_rounding_mode (ieee_nearest)
307    dx1 = 7 / 3.d0
308    dx1 = ieee_rint (dx1)
309    call ieee_set_rounding_mode (mode)
310    if (dx1 /= 2) STOP 161
311  end if
312
313  if (ieee_support_rounding (ieee_up, dx1)) then
314    call ieee_get_rounding_mode (mode)
315    call ieee_set_rounding_mode (ieee_up)
316    dx1 = 7 / 3.d0
317    dx1 = ieee_rint (dx1)
318    call ieee_set_rounding_mode (mode)
319    if (dx1 /= 3) STOP 162
320  end if
321
322  if (ieee_support_rounding (ieee_down, dx1)) then
323    call ieee_get_rounding_mode (mode)
324    call ieee_set_rounding_mode (ieee_down)
325    dx1 = 7 / 3.d0
326    dx1 = ieee_rint (dx1)
327    call ieee_set_rounding_mode (mode)
328    if (dx1 /= 2) STOP 163
329  end if
330
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)
334    dx1 = 7 / 3.d0
335    dx1 = ieee_rint (dx1)
336    call ieee_set_rounding_mode (mode)
337    if (dx1 /= 2) STOP 164
338  end if
339
340  if (ieee_class(ieee_rint(0.d0)) /= ieee_positive_zero) STOP 165
341  if (ieee_class(ieee_rint(-0.d0)) /= ieee_negative_zero) STOP 166
342
343  ! Test IEEE_SCALB
344
345  sx1 = 1
346  if (ieee_scalb(sx1, 2) /= 4.) STOP 167
347  if (ieee_scalb(-sx1, 2) /= -4.) STOP 168
348  if (ieee_scalb(sx1, -2) /= 1/4.) STOP 169
349  if (ieee_scalb(-sx1, -2) /= -1/4.) STOP 170
350  if (ieee_class(ieee_scalb(sx1, huge(0))) /= ieee_positive_inf) STOP 171
351  if (ieee_class(ieee_scalb(-sx1, huge(0))) /= ieee_negative_inf) STOP 172
352  if (ieee_class(ieee_scalb(sx1, -huge(0))) /= ieee_positive_zero) STOP 173
353  if (ieee_class(ieee_scalb(-sx1, -huge(0))) /= ieee_negative_zero) STOP 174
354
355  sx1 = ieee_value(sx1, ieee_quiet_nan)
356  if (ieee_class(ieee_scalb(sx1, 1)) /= ieee_quiet_nan) STOP 175
357  sx1 = ieee_value(sx1, ieee_positive_inf)
358  if (ieee_class(ieee_scalb(sx1, -42)) /= ieee_positive_inf) STOP 176
359  sx1 = ieee_value(sx1, ieee_negative_inf)
360  if (ieee_class(ieee_scalb(sx1, -42)) /= ieee_negative_inf) STOP 177
361
362  dx1 = 1
363  if (ieee_scalb(dx1, 2) /= 4.d0) STOP 178
364  if (ieee_scalb(-dx1, 2) /= -4.d0) STOP 179
365  if (ieee_scalb(dx1, -2) /= 1/4.d0) STOP 180
366  if (ieee_scalb(-dx1, -2) /= -1/4.d0) STOP 181
367  if (ieee_class(ieee_scalb(dx1, huge(0))) /= ieee_positive_inf) STOP 182
368  if (ieee_class(ieee_scalb(-dx1, huge(0))) /= ieee_negative_inf) STOP 183
369  if (ieee_class(ieee_scalb(dx1, -huge(0))) /= ieee_positive_zero) STOP 184
370  if (ieee_class(ieee_scalb(-dx1, -huge(0))) /= ieee_negative_zero) STOP 185
371
372  dx1 = ieee_value(dx1, ieee_quiet_nan)
373  if (ieee_class(ieee_scalb(dx1, 1)) /= ieee_quiet_nan) STOP 186
374  dx1 = ieee_value(dx1, ieee_positive_inf)
375  if (ieee_class(ieee_scalb(dx1, -42)) /= ieee_positive_inf) STOP 187
376  dx1 = ieee_value(dx1, ieee_negative_inf)
377  if (ieee_class(ieee_scalb(dx1, -42)) /= ieee_negative_inf) STOP 188
378
379contains
380
381  subroutine check_equal_float (x, y)
382    real, intent(in) :: x, y
383    if (x /= y) then
384      print *, x, y
385      STOP 189
386    end if
387  end subroutine
388
389  subroutine check_equal_double (x, y)
390    double precision, intent(in) :: x, y
391    if (x /= y) then
392      print *, x, y
393      STOP 190
394    end if
395  end subroutine
396
397  subroutine check_not_equal_float (x, y)
398    real, intent(in) :: x, y
399    if (x == y) then
400      print *, x, y
401      STOP 191
402    end if
403  end subroutine
404
405  subroutine check_not_equal_double (x, y)
406    double precision, intent(in) :: x, y
407    if (x == y) then
408      print *, x, y
409      STOP 192
410    end if
411  end subroutine
412
413end
414