1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
|
;
; Alain C, 26 Feb. 2018, under GNU GPL v3 or later
;
; Except FIX() in "test_fix.pro", we don't ready test the rounding
; functions : ROUND(), CEIL(), FLOOR(), COMPLEXROUND()
;
; We have to test :
; -- if the output TYPE (and value) is OK or not for all integer type
; (TEST_ROUNDING_TYPE) : it should not be changed !!!!
; -- if the output is OK of not (TEST_ROUNDING_REAL)
;
; We also need to check whether the /L64 is OK or not
;
; IMPORTANT NOTE :
;
; AC 2018-Mar-17 during night shift test for MIRI (JWST)
; this code is working for IDL (8.2 & 8.4)
; this code is not OK for GDL on TEST_ROUNDING_L64: /ceil & /floor
; GD 2019: This happens only at saturation 2^32 of ints and the code is OK and optimized. I suggest to ignore these 2 errors above.
;
; ----------------------------------------------------
; Modifications history :
;
; 2018-Feb-26 :
;
; ----------------------------------------------------
;
; First test is not really on value BUT on type preservation
; for all types in "INTEGER" family !
;
pro TEST_ROUNDING_TYPE, cumul_errors, test=test, verbose=verbose, $
round=round, ceil=ceil, floor=floor
;
flags=KEYWORD_SET(round) + KEYWORD_SET(ceil) + KEYWORD_SET(floor)
if flags EQ 0 then MESSAGE, 'Set at least one keyword in : /ROUND, /CEIL, /FLOOR'
if flags GT 1 then MESSAGE, 'Keywords /ROUND, /CEIL, /FLOOR are exclusive'
;
if KEYWORD_SET(round) then MESSAGE, /Continue, 'testing /ROUND'
if KEYWORD_SET(ceil) then MESSAGE, /Continue, 'testing /CEIL'
if KEYWORD_SET(floor) then MESSAGE, /Continue, 'testing /FLOOR'
;
nb_errors=0
;
GIVE_LIST_NUMERIC, list_numeric_types, list_numeric_names, /integer
types=list_numeric_types
names=list_numeric_names
;
seed=[123.4, -123.4]
;
;if KEYWORD_SET(round) then
expected=[123, -123]
;
for ii=0, N_ELEMENTS(list_numeric_types)-1 do begin
;;
if KEYWORD_SET(round) then res_int=ROUND(FIX(seed, type=types[ii]))
if KEYWORD_SET(ceil) then res_int=CEIL(FIX(seed, type=types[ii]))
if KEYWORD_SET(floor) then res_int=FLOOR(FIX(seed, type=types[ii]))
;;
expected_int=FIX(expected, type=list_numeric_types[ii])
;;
if KEYWORD_SET(verbose) then begin
HELP, res_int
HELP, expected_int
print, res_int
print, expected_int
endif
;;
if (TYPENAME(res_int) NE TYPENAME(expected_int)) then $
ERRORS_ADD, nb_errors, 'bad conv. type '+list_numeric_names[ii]
if ~ARRAY_EQUAL(expected_int, res_int, /no_typeconv) then begin
ERRORS_ADD, nb_errors, 'bad value type '+list_numeric_names[ii]
if (expected_int[0] NE res_int[0]) then print, 'Pos. side'
if (expected_int[1] NE res_int[1]) then print, 'Neg. side'
endif
endfor
;
; ----- final ----
;
BANNER_FOR_TESTSUITE, 'TEST_ROUNDING_TYPE', nb_errors, /noline
ERRORS_CUMUL, cumul_errors, nb_errors
if KEYWORD_set(test) then STOP
;
end
;
; ----------------------------------------------
;
; second test for Float, Double, Complex & Dcomplex
;
pro TEST_ROUNDING_FLOAT, cumul_errors, test=test, verbose=verbose, $
round=round, ceil=ceil, floor=floor
;
flags=KEYWORD_SET(round) + KEYWORD_SET(ceil) + KEYWORD_SET(floor)
if flags EQ 0 then MESSAGE, 'Set at least one keyword in : /ROUND, /CEIL, /FLOOR'
if flags GT 1 then MESSAGE, 'Keywords /ROUND, /CEIL, /FLOOR are exclusive'
;
if KEYWORD_SET(round) then MESSAGE, /Continue, 'testing /ROUND'
if KEYWORD_SET(ceil) then MESSAGE, /Continue, 'testing /CEIL'
if KEYWORD_SET(floor) then MESSAGE, /Continue, 'testing /FLOOR'
;
nb_errors=0
;
seed=[123.4, -123.4]
expected_long=[123l,-123l]
if KEYWORD_SET(ceil) then expected_long[0]++
if KEYWORD_SET(floor) then expected_long[1]--
;
GIVE_LIST_NUMERIC, list_numeric_types, list_numeric_names
types=[4,5,6,9]
;
for ii=0, N_ELEMENTS(types)-1 do begin
factor=1.+MAKE_ARRAY(1,type=types[ii])
val=factor[0]*seed
;;
if KEYWORD_SET(round) then res_long=ROUND(val)
if KEYWORD_SET(ceil) then res_long=CEIL(val)
if KEYWORD_SET(floor) then res_long=FLOOR(val)
;;
if KEYWORD_SET(verbose) then begin
print, 'input val. : ', val
print, 'expected val. : ', expected_long
print, 'result val. : ', res_long
endif
;;
if (TYPENAME(res_long) NE TYPENAME(expected_long)) then $
ERRORS_ADD, nb_errors, 'bad conv. type '+list_numeric_names[types[ii]]
if ~ARRAY_EQUAL(expected_long, res_long, /no_typeconv) then begin
ERRORS_ADD, nb_errors, 'bad value type '+list_numeric_names[types[ii]]
if (expected_long[0] NE res_long[0]) then print, 'Pos. side'
if (expected_long[1] NE res_long[1]) then print, 'Neg. side'
endif
endfor
;
; ----- final ----
;
BANNER_FOR_TESTSUITE, 'TEST_ROUNDING_FLOAT', nb_errors, /noline
ERRORS_CUMUL, cumul_errors, nb_errors
if KEYWORD_set(test) then STOP
;
end
;
; ----------------------------------------------
;
pro TEST_ROUNDING_L64, cumul_errors, test=test, verbose=verbose, $
round=round, ceil=ceil, floor=floor
;
flags=KEYWORD_SET(round) + KEYWORD_SET(ceil) + KEYWORD_SET(floor)
if flags EQ 0 then MESSAGE, 'Set at least one keyword in : /ROUND, /CEIL, /FLOOR'
if flags GT 1 then MESSAGE, 'Keywords /ROUND, /CEIL, /FLOOR are exclusive'
;
if KEYWORD_SET(round) then MESSAGE, /Continue, 'testing /ROUND'
if KEYWORD_SET(ceil) then MESSAGE, /Continue, 'testing /CEIL'
if KEYWORD_SET(floor) then MESSAGE, /Continue, 'testing /FLOOR'
;
nb_errors=0
;
; third test : above 2LL^31 (L64 needed)
;
large=4294967296.1d ;; (2LL^31 +0.1d)
mess=[', case Pos.',', case Neg.']
;
expected_long=2L^31 ;;-2147483648l
expected_l64=4294967296ll
;
for ii=0, 1 do begin
if (ii EQ 1) then begin
large=-1d*large
expected_l64=-expected_l64
endif
;;
if KEYWORD_SET(round) then begin
res_long=ROUND(large)
res_l64=ROUND(large,/l64)
endif
if KEYWORD_SET(ceil) then begin
res_long=CEIL(large)
res_l64=CEIL(large,/l64)
if (ii EQ 0) then begin
res_long--
res_l64--
endif
endif
if KEYWORD_SET(floor) then begin
res_long=FLOOR(large)
res_l64=FLOOR(large,/l64)
if (ii EQ 1) then begin
res_long++
res_l64++
endif
endif
;;
if KEYWORD_SET(verbose) then begin
print, 'Expected :', expected_long, expected_l64
print, 'Result :', res_long, res_l64
endif
;;
if (TYPENAME(res_long) NE 'LONG') then $
ERRORS_ADD, nb_errors, 'bad conv. type Long'+mess[ii]
if (TYPENAME(res_l64) NE 'LONG64') then $
ERRORS_ADD, nb_errors, 'bad conv. type L64'+mess[ii]
;;
;; if ~ARRAY_EQUAL(expected_long, res_long, /no_typeconv) then $
;; ERRORS_ADD, nb_errors, 'bad value type LONG'+mess[ii]
;; if ~ARRAY_EQUAL(expected_l64, res_l64, /no_typeconv) then $
;; ERRORS_ADD, nb_errors, 'bad value type LONG64'+mess[ii]
endfor
;
; ----- final ----
;
BANNER_FOR_TESTSUITE, 'TEST_ROUNDING_L64', nb_errors, /noline ;short
ERRORS_CUMUL, cumul_errors, nb_errors
if KEYWORD_set(test) then STOP
;
end
;
; ----------------------------------------------
;
pro TEST_ROUNDING, help=help, test=test, no_exit=no_exit, verbose=verbose
;
if KEYWORD_SET(help) then begin
print, 'pro TEST_ROUNDING, help=help, test=test, $'
print, ' no_exit=no_exit, verbose=verbose'
return
endif
;
cumul_errors=0
;
BANNER_FOR_TESTSUITE, 'TEST_ROUNDING_TYPE', 0, /line
TEST_ROUNDING_TYPE, cumul_errors, verbose=verbose, /round
TEST_ROUNDING_TYPE, cumul_errors, verbose=verbose, /ceil
TEST_ROUNDING_TYPE, cumul_errors, verbose=verbose, /floor
BANNER_FOR_TESTSUITE, 'TEST_ROUNDING_TYPE', 0, /line
;
BANNER_FOR_TESTSUITE, 'TEST_ROUNDING_FLOAT', 0, /line
TEST_ROUNDING_FLOAT, cumul_errors, verbose=verbose, /round
TEST_ROUNDING_FLOAT, cumul_errors, verbose=verbose, /ceil
TEST_ROUNDING_FLOAT, cumul_errors, verbose=verbose, /floor
BANNER_FOR_TESTSUITE, 'TEST_ROUNDING_FLOAT', 0, /line
;
BANNER_FOR_TESTSUITE, 'TEST_ROUNDING_L64', 0, /line
TEST_ROUNDING_L64, cumul_errors, verbose=verbose, /round
TEST_ROUNDING_L64, cumul_errors, verbose=verbose, /ceil
TEST_ROUNDING_L64, cumul_errors, verbose=verbose, /floor
BANNER_FOR_TESTSUITE, 'TEST_ROUNDING_L64', 0, /line
;
; ----------------- final message ----------
;
BANNER_FOR_TESTSUITE, 'TEST_ROUNDING', cumul_errors
;
if (cumul_errors GT 0) AND ~KEYWORD_SET(no_exit) then EXIT, status=1
;
if KEYWORD_SET(test) then STOP
;
end
|
