2 * Test program for the DOUBLE PRECISION Level 1 BLAS.
3 * Based upon the original BLAS test routine together with:
4 * F06EAF Example Program Text
8 * .. Scalars in Common ..
9 INTEGER ICASE, INCX, INCY, MODE, N
14 * .. External Subroutines ..
15 EXTERNAL CHECK0, CHECK1, CHECK2, CHECK3, HEADER
17 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
18 * .. Data statements ..
19 DATA SFAC/9.765625D-4/
20 * .. Executable Statements ..
26 * .. Initialize PASS, INCX, INCY, and MODE for a new case. ..
27 * .. the value 9999 for INCX, INCY or MODE will appear in the ..
28 * .. detailed output, if any, for cases that do not involve ..
29 * .. these parameters ..
37 ELSE IF (ICASE.EQ.7 .OR. ICASE.EQ.8 .OR. ICASE.EQ.9 .OR.
40 ELSE IF (ICASE.EQ.1 .OR. ICASE.EQ.2 .OR. ICASE.EQ.5 .OR.
43 ELSE IF (ICASE.EQ.4) THEN
47 IF (PASS) WRITE (NOUT,99998)
51 99999 FORMAT (' Real BLAS Test Program Results',/1X)
52 99998 FORMAT (' ----- PASS -----')
58 * .. Scalars in Common ..
59 INTEGER ICASE, INCX, INCY, MODE, N
64 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
65 * .. Data statements ..
76 * .. Executable Statements ..
77 WRITE (NOUT,99999) ICASE, L(ICASE)
80 99999 FORMAT (/' Test of subprogram number',I3,12X,A6)
82 SUBROUTINE CHECK0(SFAC)
86 * .. Scalar Arguments ..
88 * .. Scalars in Common ..
89 INTEGER ICASE, INCX, INCY, MODE, N
92 DOUBLE PRECISION D12, SA, SB, SC, SS
95 DOUBLE PRECISION DA1(8), DATRUE(8), DB1(8), DBTRUE(8), DC1(8),
97 * .. External Subroutines ..
98 EXTERNAL DROTG, STEST1
100 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
101 * .. Data statements ..
102 DATA DA1/0.3D0, 0.4D0, -0.3D0, -0.4D0, -0.3D0, 0.0D0,
104 DATA DB1/0.4D0, 0.3D0, 0.4D0, 0.3D0, -0.4D0, 0.0D0,
106 DATA DC1/0.6D0, 0.8D0, -0.6D0, 0.8D0, 0.6D0, 1.0D0,
108 DATA DS1/0.8D0, 0.6D0, 0.8D0, -0.6D0, 0.8D0, 0.0D0,
110 DATA DATRUE/0.5D0, 0.5D0, 0.5D0, -0.5D0, -0.5D0,
111 + 0.0D0, 1.0D0, 1.0D0/
112 DATA DBTRUE/0.0D0, 0.6D0, 0.0D0, -0.6D0, 0.0D0,
113 + 0.0D0, 1.0D0, 0.0D0/
115 * .. Executable Statements ..
117 * Compute true values which cannot be prestored
118 * in decimal notation
120 DBTRUE(1) = 1.0D0/0.6D0
121 DBTRUE(3) = -1.0D0/0.6D0
122 DBTRUE(5) = 1.0D0/0.6D0
125 * .. Set N=K for identification in output if any ..
132 CALL DROTG(SA,SB,SC,SS)
133 CALL STEST1(SA,DATRUE(K),DATRUE(K),SFAC)
134 CALL STEST1(SB,DBTRUE(K),DBTRUE(K),SFAC)
135 CALL STEST1(SC,DC1(K),DC1(K),SFAC)
136 CALL STEST1(SS,DS1(K),DS1(K),SFAC)
138 WRITE (NOUT,*) ' Shouldn''t be here in CHECK0'
144 SUBROUTINE CHECK1(SFAC)
148 * .. Scalar Arguments ..
149 DOUBLE PRECISION SFAC
150 * .. Scalars in Common ..
151 INTEGER ICASE, INCX, INCY, MODE, N
153 * .. Local Scalars ..
156 DOUBLE PRECISION DTRUE1(5), DTRUE3(5), DTRUE5(8,5,2), DV(8,5,2),
157 + SA(10), STEMP(1), STRUE(8), SX(8)
159 * .. External Functions ..
160 DOUBLE PRECISION DASUM, DNRM2
162 EXTERNAL DASUM, DNRM2, IDAMAX
163 * .. External Subroutines ..
164 EXTERNAL ITEST1, DSCAL, STEST, STEST1
165 * .. Intrinsic Functions ..
167 * .. Common blocks ..
168 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
169 * .. Data statements ..
170 DATA SA/0.3D0, -1.0D0, 0.0D0, 1.0D0, 0.3D0, 0.3D0,
171 + 0.3D0, 0.3D0, 0.3D0, 0.3D0/
172 DATA DV/0.1D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0,
173 + 2.0D0, 2.0D0, 0.3D0, 3.0D0, 3.0D0, 3.0D0, 3.0D0,
174 + 3.0D0, 3.0D0, 3.0D0, 0.3D0, -0.4D0, 4.0D0,
175 + 4.0D0, 4.0D0, 4.0D0, 4.0D0, 4.0D0, 0.2D0,
176 + -0.6D0, 0.3D0, 5.0D0, 5.0D0, 5.0D0, 5.0D0,
177 + 5.0D0, 0.1D0, -0.3D0, 0.5D0, -0.1D0, 6.0D0,
178 + 6.0D0, 6.0D0, 6.0D0, 0.1D0, 8.0D0, 8.0D0, 8.0D0,
179 + 8.0D0, 8.0D0, 8.0D0, 8.0D0, 0.3D0, 9.0D0, 9.0D0,
180 + 9.0D0, 9.0D0, 9.0D0, 9.0D0, 9.0D0, 0.3D0, 2.0D0,
181 + -0.4D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0,
182 + 0.2D0, 3.0D0, -0.6D0, 5.0D0, 0.3D0, 2.0D0,
183 + 2.0D0, 2.0D0, 0.1D0, 4.0D0, -0.3D0, 6.0D0,
184 + -0.5D0, 7.0D0, -0.1D0, 3.0D0/
185 DATA DTRUE1/0.0D0, 0.3D0, 0.5D0, 0.7D0, 0.6D0/
186 DATA DTRUE3/0.0D0, 0.3D0, 0.7D0, 1.1D0, 1.0D0/
187 DATA DTRUE5/0.10D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0,
188 + 2.0D0, 2.0D0, 2.0D0, -0.3D0, 3.0D0, 3.0D0,
189 + 3.0D0, 3.0D0, 3.0D0, 3.0D0, 3.0D0, 0.0D0, 0.0D0,
190 + 4.0D0, 4.0D0, 4.0D0, 4.0D0, 4.0D0, 4.0D0,
191 + 0.20D0, -0.60D0, 0.30D0, 5.0D0, 5.0D0, 5.0D0,
192 + 5.0D0, 5.0D0, 0.03D0, -0.09D0, 0.15D0, -0.03D0,
193 + 6.0D0, 6.0D0, 6.0D0, 6.0D0, 0.10D0, 8.0D0,
194 + 8.0D0, 8.0D0, 8.0D0, 8.0D0, 8.0D0, 8.0D0,
195 + 0.09D0, 9.0D0, 9.0D0, 9.0D0, 9.0D0, 9.0D0,
196 + 9.0D0, 9.0D0, 0.09D0, 2.0D0, -0.12D0, 2.0D0,
197 + 2.0D0, 2.0D0, 2.0D0, 2.0D0, 0.06D0, 3.0D0,
198 + -0.18D0, 5.0D0, 0.09D0, 2.0D0, 2.0D0, 2.0D0,
199 + 0.03D0, 4.0D0, -0.09D0, 6.0D0, -0.15D0, 7.0D0,
201 DATA ITRUE2/0, 1, 2, 2, 3/
202 * .. Executable Statements ..
207 * .. Set vector arguments ..
209 SX(I) = DV(I,NP1,INCX)
214 STEMP(1) = DTRUE1(NP1)
215 CALL STEST1(DNRM2(N,SX,INCX),STEMP,STEMP,SFAC)
216 ELSE IF (ICASE.EQ.8) THEN
218 STEMP(1) = DTRUE3(NP1)
219 CALL STEST1(DASUM(N,SX,INCX),STEMP,STEMP,SFAC)
220 ELSE IF (ICASE.EQ.9) THEN
222 CALL DSCAL(N,SA((INCX-1)*5+NP1),SX,INCX)
224 STRUE(I) = DTRUE5(I,NP1,INCX)
226 CALL STEST(LEN,SX,STRUE,STRUE,SFAC)
227 ELSE IF (ICASE.EQ.10) THEN
229 CALL ITEST1(IDAMAX(N,SX,INCX),ITRUE2(NP1))
231 WRITE (NOUT,*) ' Shouldn''t be here in CHECK1'
238 SUBROUTINE CHECK2(SFAC)
242 * .. Scalar Arguments ..
243 DOUBLE PRECISION SFAC
244 * .. Scalars in Common ..
245 INTEGER ICASE, INCX, INCY, MODE, N
247 * .. Local Scalars ..
248 DOUBLE PRECISION SA, SC, SS
249 INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY
251 DOUBLE PRECISION DT10X(7,4,4), DT10Y(7,4,4), DT7(4,4),
252 + DT8(7,4,4), DT9X(7,4,4), DT9Y(7,4,4), DX1(7),
253 + DY1(7), SSIZE1(4), SSIZE2(14,2), STX(7), STY(7),
255 INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4)
256 * .. External Functions ..
257 DOUBLE PRECISION DDOT
259 * .. External Subroutines ..
260 EXTERNAL DAXPY, DCOPY, DSWAP, STEST, STEST1
261 * .. Intrinsic Functions ..
263 * .. Common blocks ..
264 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
265 * .. Data statements ..
267 DATA INCXS/1, 2, -2, -1/
268 DATA INCYS/1, -2, 1, -2/
269 DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/
271 DATA DX1/0.6D0, 0.1D0, -0.5D0, 0.8D0, 0.9D0, -0.3D0,
273 DATA DY1/0.5D0, -0.9D0, 0.3D0, 0.7D0, -0.6D0, 0.2D0,
275 DATA SC, SS/0.8D0, 0.6D0/
276 DATA DT7/0.0D0, 0.30D0, 0.21D0, 0.62D0, 0.0D0,
277 + 0.30D0, -0.07D0, 0.85D0, 0.0D0, 0.30D0, -0.79D0,
278 + -0.74D0, 0.0D0, 0.30D0, 0.33D0, 1.27D0/
279 DATA DT8/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
280 + 0.0D0, 0.68D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
281 + 0.0D0, 0.0D0, 0.68D0, -0.87D0, 0.0D0, 0.0D0,
282 + 0.0D0, 0.0D0, 0.0D0, 0.68D0, -0.87D0, 0.15D0,
283 + 0.94D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0,
284 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.68D0,
285 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
286 + 0.35D0, -0.9D0, 0.48D0, 0.0D0, 0.0D0, 0.0D0,
287 + 0.0D0, 0.38D0, -0.9D0, 0.57D0, 0.7D0, -0.75D0,
288 + 0.2D0, 0.98D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0,
289 + 0.0D0, 0.0D0, 0.0D0, 0.68D0, 0.0D0, 0.0D0,
290 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.35D0, -0.72D0,
291 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.38D0,
292 + -0.63D0, 0.15D0, 0.88D0, 0.0D0, 0.0D0, 0.0D0,
293 + 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
294 + 0.68D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
295 + 0.0D0, 0.68D0, -0.9D0, 0.33D0, 0.0D0, 0.0D0,
296 + 0.0D0, 0.0D0, 0.68D0, -0.9D0, 0.33D0, 0.7D0,
297 + -0.75D0, 0.2D0, 1.04D0/
298 DATA DT9X/0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
299 + 0.0D0, 0.78D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
300 + 0.0D0, 0.0D0, 0.78D0, -0.46D0, 0.0D0, 0.0D0,
301 + 0.0D0, 0.0D0, 0.0D0, 0.78D0, -0.46D0, -0.22D0,
302 + 1.06D0, 0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0,
303 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.78D0,
304 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
305 + 0.66D0, 0.1D0, -0.1D0, 0.0D0, 0.0D0, 0.0D0,
306 + 0.0D0, 0.96D0, 0.1D0, -0.76D0, 0.8D0, 0.90D0,
307 + -0.3D0, -0.02D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0,
308 + 0.0D0, 0.0D0, 0.0D0, 0.78D0, 0.0D0, 0.0D0,
309 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.06D0, 0.1D0,
310 + -0.1D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.90D0,
311 + 0.1D0, -0.22D0, 0.8D0, 0.18D0, -0.3D0, -0.02D0,
312 + 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
313 + 0.78D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
314 + 0.0D0, 0.78D0, 0.26D0, 0.0D0, 0.0D0, 0.0D0,
315 + 0.0D0, 0.0D0, 0.78D0, 0.26D0, -0.76D0, 1.12D0,
316 + 0.0D0, 0.0D0, 0.0D0/
317 DATA DT9Y/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
318 + 0.0D0, 0.04D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
319 + 0.0D0, 0.0D0, 0.04D0, -0.78D0, 0.0D0, 0.0D0,
320 + 0.0D0, 0.0D0, 0.0D0, 0.04D0, -0.78D0, 0.54D0,
321 + 0.08D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0,
322 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.04D0,
323 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.7D0,
324 + -0.9D0, -0.12D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
325 + 0.64D0, -0.9D0, -0.30D0, 0.7D0, -0.18D0, 0.2D0,
326 + 0.28D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
327 + 0.0D0, 0.0D0, 0.04D0, 0.0D0, 0.0D0, 0.0D0,
328 + 0.0D0, 0.0D0, 0.0D0, 0.7D0, -1.08D0, 0.0D0,
329 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.64D0, -1.26D0,
330 + 0.54D0, 0.20D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0,
331 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
332 + 0.04D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
333 + 0.0D0, 0.04D0, -0.9D0, 0.18D0, 0.0D0, 0.0D0,
334 + 0.0D0, 0.0D0, 0.04D0, -0.9D0, 0.18D0, 0.7D0,
335 + -0.18D0, 0.2D0, 0.16D0/
336 DATA DT10X/0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
337 + 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
338 + 0.0D0, 0.5D0, -0.9D0, 0.0D0, 0.0D0, 0.0D0,
339 + 0.0D0, 0.0D0, 0.5D0, -0.9D0, 0.3D0, 0.7D0,
340 + 0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0,
341 + 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0,
342 + 0.0D0, 0.0D0, 0.0D0, 0.3D0, 0.1D0, 0.5D0, 0.0D0,
343 + 0.0D0, 0.0D0, 0.0D0, 0.8D0, 0.1D0, -0.6D0,
344 + 0.8D0, 0.3D0, -0.3D0, 0.5D0, 0.6D0, 0.0D0,
345 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0,
346 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.9D0,
347 + 0.1D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.7D0,
348 + 0.1D0, 0.3D0, 0.8D0, -0.9D0, -0.3D0, 0.5D0,
349 + 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
350 + 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
351 + 0.5D0, 0.3D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
352 + 0.5D0, 0.3D0, -0.6D0, 0.8D0, 0.0D0, 0.0D0,
354 DATA DT10Y/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
355 + 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
356 + 0.0D0, 0.6D0, 0.1D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
357 + 0.0D0, 0.6D0, 0.1D0, -0.5D0, 0.8D0, 0.0D0,
358 + 0.0D0, 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
359 + 0.0D0, 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
360 + 0.0D0, 0.0D0, -0.5D0, -0.9D0, 0.6D0, 0.0D0,
361 + 0.0D0, 0.0D0, 0.0D0, -0.4D0, -0.9D0, 0.9D0,
362 + 0.7D0, -0.5D0, 0.2D0, 0.6D0, 0.5D0, 0.0D0,
363 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0,
364 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.5D0,
365 + 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
366 + -0.4D0, 0.9D0, -0.5D0, 0.6D0, 0.0D0, 0.0D0,
367 + 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
368 + 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
369 + 0.0D0, 0.6D0, -0.9D0, 0.1D0, 0.0D0, 0.0D0,
370 + 0.0D0, 0.0D0, 0.6D0, -0.9D0, 0.1D0, 0.7D0,
371 + -0.5D0, 0.2D0, 0.8D0/
372 DATA SSIZE1/0.0D0, 0.3D0, 1.6D0, 3.2D0/
373 DATA SSIZE2/0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
374 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
375 + 0.0D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0,
376 + 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0,
377 + 1.17D0, 1.17D0, 1.17D0/
378 * .. Executable Statements ..
391 * .. Initialize all argument arrays ..
399 CALL STEST1(DDOT(N,SX,INCX,SY,INCY),DT7(KN,KI),SSIZE1(KN)
401 ELSE IF (ICASE.EQ.2) THEN
403 CALL DAXPY(N,SA,SX,INCX,SY,INCY)
405 STY(J) = DT8(J,KN,KI)
407 CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC)
408 ELSE IF (ICASE.EQ.5) THEN
411 STY(I) = DT10Y(I,KN,KI)
413 CALL DCOPY(N,SX,INCX,SY,INCY)
414 CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0D0)
415 ELSE IF (ICASE.EQ.6) THEN
417 CALL DSWAP(N,SX,INCX,SY,INCY)
419 STX(I) = DT10X(I,KN,KI)
420 STY(I) = DT10Y(I,KN,KI)
422 CALL STEST(LENX,SX,STX,SSIZE2(1,1),1.0D0)
423 CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0D0)
425 WRITE (NOUT,*) ' Shouldn''t be here in CHECK2'
432 SUBROUTINE CHECK3(SFAC)
436 * .. Scalar Arguments ..
437 DOUBLE PRECISION SFAC
438 * .. Scalars in Common ..
439 INTEGER ICASE, INCX, INCY, MODE, N
441 * .. Local Scalars ..
442 DOUBLE PRECISION SA, SC, SS
443 INTEGER I, K, KI, KN, KSIZE, LENX, LENY, MX, MY
445 DOUBLE PRECISION COPYX(5), COPYY(5), DT9X(7,4,4), DT9Y(7,4,4),
446 + DX1(7), DY1(7), MWPC(11), MWPS(11), MWPSTX(5),
447 + MWPSTY(5), MWPTX(11,5), MWPTY(11,5), MWPX(5),
448 + MWPY(5), SSIZE2(14,2), STX(7), STY(7), SX(7),
450 INTEGER INCXS(4), INCYS(4), LENS(4,2), MWPINX(11),
451 + MWPINY(11), MWPN(11), NS(4)
452 * .. External Subroutines ..
454 * .. Intrinsic Functions ..
456 * .. Common blocks ..
457 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
458 * .. Data statements ..
460 DATA INCXS/1, 2, -2, -1/
461 DATA INCYS/1, -2, 1, -2/
462 DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/
464 DATA DX1/0.6D0, 0.1D0, -0.5D0, 0.8D0, 0.9D0, -0.3D0,
466 DATA DY1/0.5D0, -0.9D0, 0.3D0, 0.7D0, -0.6D0, 0.2D0,
468 DATA SC, SS/0.8D0, 0.6D0/
469 DATA DT9X/0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
470 + 0.0D0, 0.78D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
471 + 0.0D0, 0.0D0, 0.78D0, -0.46D0, 0.0D0, 0.0D0,
472 + 0.0D0, 0.0D0, 0.0D0, 0.78D0, -0.46D0, -0.22D0,
473 + 1.06D0, 0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0,
474 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.78D0,
475 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
476 + 0.66D0, 0.1D0, -0.1D0, 0.0D0, 0.0D0, 0.0D0,
477 + 0.0D0, 0.96D0, 0.1D0, -0.76D0, 0.8D0, 0.90D0,
478 + -0.3D0, -0.02D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0,
479 + 0.0D0, 0.0D0, 0.0D0, 0.78D0, 0.0D0, 0.0D0,
480 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.06D0, 0.1D0,
481 + -0.1D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.90D0,
482 + 0.1D0, -0.22D0, 0.8D0, 0.18D0, -0.3D0, -0.02D0,
483 + 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
484 + 0.78D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
485 + 0.0D0, 0.78D0, 0.26D0, 0.0D0, 0.0D0, 0.0D0,
486 + 0.0D0, 0.0D0, 0.78D0, 0.26D0, -0.76D0, 1.12D0,
487 + 0.0D0, 0.0D0, 0.0D0/
488 DATA DT9Y/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
489 + 0.0D0, 0.04D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
490 + 0.0D0, 0.0D0, 0.04D0, -0.78D0, 0.0D0, 0.0D0,
491 + 0.0D0, 0.0D0, 0.0D0, 0.04D0, -0.78D0, 0.54D0,
492 + 0.08D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0,
493 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.04D0,
494 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.7D0,
495 + -0.9D0, -0.12D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
496 + 0.64D0, -0.9D0, -0.30D0, 0.7D0, -0.18D0, 0.2D0,
497 + 0.28D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
498 + 0.0D0, 0.0D0, 0.04D0, 0.0D0, 0.0D0, 0.0D0,
499 + 0.0D0, 0.0D0, 0.0D0, 0.7D0, -1.08D0, 0.0D0,
500 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.64D0, -1.26D0,
501 + 0.54D0, 0.20D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0,
502 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
503 + 0.04D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
504 + 0.0D0, 0.04D0, -0.9D0, 0.18D0, 0.0D0, 0.0D0,
505 + 0.0D0, 0.0D0, 0.04D0, -0.9D0, 0.18D0, 0.7D0,
506 + -0.18D0, 0.2D0, 0.16D0/
507 DATA SSIZE2/0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
508 + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
509 + 0.0D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0,
510 + 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0,
511 + 1.17D0, 1.17D0, 1.17D0/
512 * .. Executable Statements ..
531 STX(I) = DT9X(I,KN,KI)
532 STY(I) = DT9Y(I,KN,KI)
534 CALL DROT(N,SX,INCX,SY,INCY,SC,SS)
535 CALL STEST(LENX,SX,STX,SSIZE2(1,KSIZE),SFAC)
536 CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC)
538 WRITE (NOUT,*) ' Shouldn''t be here in CHECK3'
630 MWPSTX(K) = MWPTX(I,K)
631 MWPSTY(K) = MWPTY(I,K)
633 CALL DROT(MWPN(I),COPYX,INCX,COPYY,INCY,MWPC(I),MWPS(I))
634 CALL STEST(5,COPYX,MWPSTX,MWPSTX,SFAC)
635 CALL STEST(5,COPYY,MWPSTY,MWPSTY,SFAC)
639 SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC)
640 * ********************************* STEST **************************
642 * THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO
643 * SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
646 * C. L. LAWSON, JPL, 1974 DEC 10
651 * .. Scalar Arguments ..
652 DOUBLE PRECISION SFAC
654 * .. Array Arguments ..
655 DOUBLE PRECISION SCOMP(LEN), SSIZE(LEN), STRUE(LEN)
656 * .. Scalars in Common ..
657 INTEGER ICASE, INCX, INCY, MODE, N
659 * .. Local Scalars ..
662 * .. External Functions ..
663 DOUBLE PRECISION SDIFF
665 * .. Intrinsic Functions ..
667 * .. Common blocks ..
668 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
669 * .. Executable Statements ..
672 SD = SCOMP(I) - STRUE(I)
673 IF (SDIFF(ABS(SSIZE(I))+ABS(SFAC*SD),ABS(SSIZE(I))).EQ.0.0D0)
676 * HERE SCOMP(I) IS NOT CLOSE TO STRUE(I).
678 IF ( .NOT. PASS) GO TO 20
679 * PRINT FAIL MESSAGE AND HEADER.
683 20 WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, I, SCOMP(I),
684 + STRUE(I), SD, SSIZE(I)
688 99999 FORMAT (' FAIL')
689 99998 FORMAT (/' CASE N INCX INCY MODE I ',
690 + ' COMP(I) TRUE(I) DIFFERENCE',
692 99997 FORMAT (1X,I4,I3,3I5,I3,2D36.8,2D12.4)
694 SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC)
695 * ************************* STEST1 *****************************
697 * THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN
698 * REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
699 * ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
701 * C.L. LAWSON, JPL, 1978 DEC 6
703 * .. Scalar Arguments ..
704 DOUBLE PRECISION SCOMP1, SFAC, STRUE1
705 * .. Array Arguments ..
706 DOUBLE PRECISION SSIZE(*)
708 DOUBLE PRECISION SCOMP(1), STRUE(1)
709 * .. External Subroutines ..
711 * .. Executable Statements ..
715 CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC)
719 DOUBLE PRECISION FUNCTION SDIFF(SA,SB)
720 * ********************************* SDIFF **************************
721 * COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
723 * .. Scalar Arguments ..
724 DOUBLE PRECISION SA, SB
725 * .. Executable Statements ..
729 SUBROUTINE ITEST1(ICOMP,ITRUE)
730 * ********************************* ITEST1 *************************
732 * THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
734 * C. L. LAWSON, JPL, 1974 DEC 10
739 * .. Scalar Arguments ..
741 * .. Scalars in Common ..
742 INTEGER ICASE, INCX, INCY, MODE, N
744 * .. Local Scalars ..
746 * .. Common blocks ..
747 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
748 * .. Executable Statements ..
750 IF (ICOMP.EQ.ITRUE) GO TO 40
752 * HERE ICOMP IS NOT EQUAL TO ITRUE.
754 IF ( .NOT. PASS) GO TO 20
755 * PRINT FAIL MESSAGE AND HEADER.
759 20 ID = ICOMP - ITRUE
760 WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, ICOMP, ITRUE, ID
764 99999 FORMAT (' FAIL')
765 99998 FORMAT (/' CASE N INCX INCY MODE ',
766 + ' COMP TRUE DIFFERENCE',
768 99997 FORMAT (1X,I4,I3,3I5,2I36,I12)