1 PROGRAM DBLAT2
2 *
3 * Test program for the DOUBLE PRECISION Level 2 Blas.
4 *
5 * The program must be driven by a short data file. The first 17 records
6 * of the file are read using list-directed input, the last 16 records
7 * are read using the format ( A12, L2 ). An annotated example of a data
8 * file can be obtained by deleting the first 3 characters from the
9 * following 33 lines:
10 * 'DBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE
11 * -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
12 * F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
13 * F LOGICAL FLAG, T TO STOP ON FAILURES.
14 * T LOGICAL FLAG, T TO TEST ERROR EXITS.
15 * 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH
16 * 16.0 THRESHOLD VALUE OF TEST RATIO
17 * 6 NUMBER OF VALUES OF N
18 * 0 1 2 3 5 9 VALUES OF N
19 * 4 NUMBER OF VALUES OF K
20 * 0 1 2 4 VALUES OF K
21 * 4 NUMBER OF VALUES OF INCX AND INCY
22 * 1 2 -1 -2 VALUES OF INCX AND INCY
23 * 3 NUMBER OF VALUES OF ALPHA
24 * 0.0 1.0 0.7 VALUES OF ALPHA
25 * 3 NUMBER OF VALUES OF BETA
26 * 0.0 1.0 0.9 VALUES OF BETA
27 * cblas_dgemv T PUT F FOR NO TEST. SAME COLUMNS.
28 * cblas_dgbmv T PUT F FOR NO TEST. SAME COLUMNS.
29 * cblas_dsymv T PUT F FOR NO TEST. SAME COLUMNS.
30 * cblas_dsbmv T PUT F FOR NO TEST. SAME COLUMNS.
31 * cblas_dspmv T PUT F FOR NO TEST. SAME COLUMNS.
32 * cblas_dtrmv T PUT F FOR NO TEST. SAME COLUMNS.
33 * cblas_dtbmv T PUT F FOR NO TEST. SAME COLUMNS.
34 * cblas_dtpmv T PUT F FOR NO TEST. SAME COLUMNS.
35 * cblas_dtrsv T PUT F FOR NO TEST. SAME COLUMNS.
36 * cblas_dtbsv T PUT F FOR NO TEST. SAME COLUMNS.
37 * cblas_dtpsv T PUT F FOR NO TEST. SAME COLUMNS.
38 * cblas_dger T PUT F FOR NO TEST. SAME COLUMNS.
39 * cblas_dsyr T PUT F FOR NO TEST. SAME COLUMNS.
40 * cblas_dspr T PUT F FOR NO TEST. SAME COLUMNS.
41 * cblas_dsyr2 T PUT F FOR NO TEST. SAME COLUMNS.
42 * cblas_dspr2 T PUT F FOR NO TEST. SAME COLUMNS.
43 *
44 * See:
45 *
46 * Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J..
47 * An extended set of Fortran Basic Linear Algebra Subprograms.
48 *
49 * Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics
50 * and Computer Science Division, Argonne National Laboratory,
51 * 9700 South Cass Avenue, Argonne, Illinois 60439, US.
52 *
53 * Or
54 *
55 * NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms
56 * Group Ltd., NAG Central Office, 256 Banbury Road, Oxford
57 * OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st
58 * Street, Suite 100, Downers Grove, Illinois 60515-1263, USA.
59 *
60 *
61 * -- Written on 10-August-1987.
62 * Richard Hanson, Sandia National Labs.
63 * Jeremy Du Croz, NAG Central Office.
64 *
65 * .. Parameters ..
66 INTEGER NIN, NOUT
67 PARAMETER ( NIN = 5, NOUT = 6 )
68 INTEGER NSUBS
69 PARAMETER ( NSUBS = 16 )
70 DOUBLE PRECISION ZERO, HALF, ONE
71 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
72 INTEGER NMAX, INCMAX
73 PARAMETER ( NMAX = 65, INCMAX = 2 )
74 INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX
75 PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7,
76 $ NALMAX = 7, NBEMAX = 7 )
77 * .. Local Scalars ..
78 DOUBLE PRECISION EPS, ERR, THRESH
79 INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB,
80 $ NTRA, LAYOUT
81 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
82 $ TSTERR, CORDER, RORDER
83 CHARACTER*1 TRANS
84 CHARACTER*12 SNAMET
85 CHARACTER*32 SNAPS
86 * .. Local Arrays ..
87 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ),
88 $ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ),
89 $ G( NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
90 $ XX( NMAX*INCMAX ), Y( NMAX ),
91 $ YS( NMAX*INCMAX ), YT( NMAX ),
92 $ YY( NMAX*INCMAX ), Z( 2*NMAX )
93 INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX )
94 LOGICAL LTEST( NSUBS )
95 CHARACTER*12 SNAMES( NSUBS )
96 * .. External Functions ..
97 DOUBLE PRECISION DDIFF
98 LOGICAL LDE
99 EXTERNAL DDIFF, LDE
100 * .. External Subroutines ..
101 EXTERNAL DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, DCHK6,
102 $ CD2CHKE, DMVCH
103 * .. Intrinsic Functions ..
104 INTRINSIC ABS, MAX, MIN
105 * .. Scalars in Common ..
106 INTEGER INFOT, NOUTC
107 LOGICAL OK
108 CHARACTER*12 SRNAMT
109 * .. Common blocks ..
110 COMMON /INFOC/INFOT, NOUTC, OK
111 COMMON /SRNAMC/SRNAMT
112 * .. Data statements ..
113 DATA SNAMES/'cblas_dgemv ', 'cblas_dgbmv ',
114 $ 'cblas_dsymv ','cblas_dsbmv ','cblas_dspmv ',
115 $ 'cblas_dtrmv ','cblas_dtbmv ','cblas_dtpmv ',
116 $ 'cblas_dtrsv ','cblas_dtbsv ','cblas_dtpsv ',
117 $ 'cblas_dger ','cblas_dsyr ','cblas_dspr ',
118 $ 'cblas_dsyr2 ','cblas_dspr2 '/
119 * .. Executable Statements ..
120 *
121 NOUTC = NOUT
122 *
123 * Read name and unit number for snapshot output file and open file.
124 *
125 READ( NIN, FMT = * )SNAPS
126 READ( NIN, FMT = * )NTRA
127 TRACE = NTRA.GE.0
128 IF( TRACE )THEN
129 OPEN( NTRA, FILE = SNAPS )
130 END IF
131 * Read the flag that directs rewinding of the snapshot file.
132 READ( NIN, FMT = * )REWI
133 REWI = REWI.AND.TRACE
134 * Read the flag that directs stopping on any failure.
135 READ( NIN, FMT = * )SFATAL
136 * Read the flag that indicates whether error exits are to be tested.
137 READ( NIN, FMT = * )TSTERR
138 * Read the flag that indicates whether row-major data layout to be tested.
139 READ( NIN, FMT = * )LAYOUT
140 * Read the threshold value of the test ratio
141 READ( NIN, FMT = * )THRESH
142 *
143 * Read and check the parameter values for the tests.
144 *
145 * Values of N
146 READ( NIN, FMT = * )NIDIM
147 IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
148 WRITE( NOUT, FMT = 9997 )'N', NIDMAX
149 GO TO 230
150 END IF
151 READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
152 DO 10 I = 1, NIDIM
153 IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
154 WRITE( NOUT, FMT = 9996 )NMAX
155 GO TO 230
156 END IF
157 10 CONTINUE
158 * Values of K
159 READ( NIN, FMT = * )NKB
160 IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN
161 WRITE( NOUT, FMT = 9997 )'K', NKBMAX
162 GO TO 230
163 END IF
164 READ( NIN, FMT = * )( KB( I ), I = 1, NKB )
165 DO 20 I = 1, NKB
166 IF( KB( I ).LT.0 )THEN
167 WRITE( NOUT, FMT = 9995 )
168 GO TO 230
169 END IF
170 20 CONTINUE
171 * Values of INCX and INCY
172 READ( NIN, FMT = * )NINC
173 IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN
174 WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX
175 GO TO 230
176 END IF
177 READ( NIN, FMT = * )( INC( I ), I = 1, NINC )
178 DO 30 I = 1, NINC
179 IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN
180 WRITE( NOUT, FMT = 9994 )INCMAX
181 GO TO 230
182 END IF
183 30 CONTINUE
184 * Values of ALPHA
185 READ( NIN, FMT = * )NALF
186 IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
187 WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
188 GO TO 230
189 END IF
190 READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
191 * Values of BETA
192 READ( NIN, FMT = * )NBET
193 IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
194 WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
195 GO TO 230
196 END IF
197 READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
198 *
199 * Report values of parameters.
200 *
201 WRITE( NOUT, FMT = 9993 )
202 WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM )
203 WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB )
204 WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC )
205 WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF )
206 WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET )
207 IF( .NOT.TSTERR )THEN
208 WRITE( NOUT, FMT = * )
209 WRITE( NOUT, FMT = 9980 )
210 END IF
211 WRITE( NOUT, FMT = * )
212 WRITE( NOUT, FMT = 9999 )THRESH
213 WRITE( NOUT, FMT = * )
214
215 RORDER = .FALSE.
216 CORDER = .FALSE.
217 IF (LAYOUT.EQ.2) THEN
218 RORDER = .TRUE.
219 CORDER = .TRUE.
220 WRITE( *, FMT = 10002 )
221 ELSE IF (LAYOUT.EQ.1) THEN
222 RORDER = .TRUE.
223 WRITE( *, FMT = 10001 )
224 ELSE IF (LAYOUT.EQ.0) THEN
225 CORDER = .TRUE.
226 WRITE( *, FMT = 10000 )
227 END IF
228 WRITE( *, FMT = * )
229 *
230 * Read names of subroutines and flags which indicate
231 * whether they are to be tested.
232 *
233 DO 40 I = 1, NSUBS
234 LTEST( I ) = .FALSE.
235 40 CONTINUE
236 50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT
237 DO 60 I = 1, NSUBS
238 IF( SNAMET.EQ.SNAMES( I ) )
239 $ GO TO 70
240 60 CONTINUE
241 WRITE( NOUT, FMT = 9986 )SNAMET
242 STOP
243 70 LTEST( I ) = LTESTT
244 GO TO 50
245 *
246 80 CONTINUE
247 CLOSE ( NIN )
248 *
249 * Compute EPS (the machine precision).
250 *
251 EPS = ONE
252 90 CONTINUE
253 IF( DDIFF( ONE + EPS, ONE ).EQ.ZERO )
254 $ GO TO 100
255 EPS = HALF*EPS
256 GO TO 90
257 100 CONTINUE
258 EPS = EPS + EPS
259 WRITE( NOUT, FMT = 9998 )EPS
260 *
261 * Check the reliability of DMVCH using exact data.
262 *
263 N = MIN( 32, NMAX )
264 DO 120 J = 1, N
265 DO 110 I = 1, N
266 A( I, J ) = MAX( I - J + 1, 0 )
267 110 CONTINUE
268 X( J ) = J
269 Y( J ) = ZERO
270 120 CONTINUE
271 DO 130 J = 1, N
272 YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
273 130 CONTINUE
274 * YY holds the exact result. On exit from DMVCH YT holds
275 * the result computed by DMVCH.
276 TRANS = 'N'
277 CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G,
278 $ YY, EPS, ERR, FATAL, NOUT, .TRUE. )
279 SAME = LDE( YY, YT, N )
280 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
281 WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
282 STOP
283 END IF
284 TRANS = 'T'
285 CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G,
286 $ YY, EPS, ERR, FATAL, NOUT, .TRUE. )
287 SAME = LDE( YY, YT, N )
288 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
289 WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
290 STOP
291 END IF
292 *
293 * Test each subroutine in turn.
294 *
295 DO 210 ISNUM = 1, NSUBS
296 WRITE( NOUT, FMT = * )
297 IF( .NOT.LTEST( ISNUM ) )THEN
298 * Subprogram is not to be tested.
299 WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM )
300 ELSE
301 SRNAMT = SNAMES( ISNUM )
302 * Test error exits.
303 IF( TSTERR )THEN
304 CALL CD2CHKE( SNAMES( ISNUM ) )
305 WRITE( NOUT, FMT = * )
306 END IF
307 * Test computations.
308 INFOT = 0
309 OK = .TRUE.
310 FATAL = .FALSE.
311 GO TO ( 140, 140, 150, 150, 150, 160, 160,
312 $ 160, 160, 160, 160, 170, 180, 180,
313 $ 190, 190 )ISNUM
314 * Test DGEMV, 01, and DGBMV, 02.
315 140 IF (CORDER) THEN
316 CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
317 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
318 $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
319 $ X, XX, XS, Y, YY, YS, YT, G, 0 )
320 END IF
321 IF (RORDER) THEN
322 CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
323 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
324 $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
325 $ X, XX, XS, Y, YY, YS, YT, G, 1 )
326 END IF
327 GO TO 200
328 * Test DSYMV, 03, DSBMV, 04, and DSPMV, 05.
329 150 IF (CORDER) THEN
330 CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
331 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
332 $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
333 $ X, XX, XS, Y, YY, YS, YT, G, 0 )
334 END IF
335 IF (RORDER) THEN
336 CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
337 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
338 $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
339 $ X, XX, XS, Y, YY, YS, YT, G, 1 )
340 END IF
341 GO TO 200
342 * Test DTRMV, 06, DTBMV, 07, DTPMV, 08,
343 * DTRSV, 09, DTBSV, 10, and DTPSV, 11.
344 160 IF (CORDER) THEN
345 CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
346 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC,
347 $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z,
348 $ 0 )
349 END IF
350 IF (RORDER) THEN
351 CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
352 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC,
353 $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z,
354 $ 1 )
355 END IF
356 GO TO 200
357 * Test DGER, 12.
358 170 IF (CORDER) THEN
359 CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
360 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
361 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
362 $ YT, G, Z, 0 )
363 END IF
364 IF (RORDER) THEN
365 CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
366 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
367 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
368 $ YT, G, Z, 1 )
369 END IF
370 GO TO 200
371 * Test DSYR, 13, and DSPR, 14.
372 180 IF (CORDER) THEN
373 CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
374 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
375 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
376 $ YT, G, Z, 0 )
377 END IF
378 IF (RORDER) THEN
379 CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
380 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
381 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
382 $ YT, G, Z, 1 )
383 END IF
384 GO TO 200
385 * Test DSYR2, 15, and DSPR2, 16.
386 190 IF (CORDER) THEN
387 CALL DCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
388 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
389 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
390 $ YT, G, Z, 0 )
391 END IF
392 IF (RORDER) THEN
393 CALL DCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
394 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
395 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
396 $ YT, G, Z, 1 )
397 END IF
398 *
399 200 IF( FATAL.AND.SFATAL )
400 $ GO TO 220
401 END IF
402 210 CONTINUE
403 WRITE( NOUT, FMT = 9982 )
404 GO TO 240
405 *
406 220 CONTINUE
407 WRITE( NOUT, FMT = 9981 )
408 GO TO 240
409 *
410 230 CONTINUE
411 WRITE( NOUT, FMT = 9987 )
412 *
413 240 CONTINUE
414 IF( TRACE )
415 $ CLOSE ( NTRA )
416 CLOSE ( NOUT )
417 STOP
418 *
419 10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' )
420 10001 FORMAT( ' ROW-MAJOR DATA LAYOUT IS TESTED' )
421 10000 FORMAT( ' COLUMN-MAJOR DATA LAYOUT IS TESTED' )
422 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
423 $ 'S THAN', F8.2 )
424 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 )
425 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
426 $ 'THAN ', I2 )
427 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
428 9995 FORMAT( ' VALUE OF K IS LESS THAN 0' )
429 9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ',
430 $ I2 )
431 9993 FORMAT( ' TESTS OF THE DOUBLE PRECISION LEVEL 2 BLAS', //' THE F',
432 $ 'OLLOWING PARAMETER VALUES WILL BE USED:' )
433 9992 FORMAT( ' FOR N ', 9I6 )
434 9991 FORMAT( ' FOR K ', 7I6 )
435 9990 FORMAT( ' FOR INCX AND INCY ', 7I6 )
436 9989 FORMAT( ' FOR ALPHA ', 7F6.1 )
437 9988 FORMAT( ' FOR BETA ', 7F6.1 )
438 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
439 $ /' ******* TESTS ABANDONED *******' )
440 9986 FORMAT( ' SUBPROGRAM NAME ',A12, ' NOT RECOGNIZED', /' ******* T',
441 $ 'ESTS ABANDONED *******' )
442 9985 FORMAT( ' ERROR IN DMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
443 $ 'ATED WRONGLY.', /' DMVCH WAS CALLED WITH TRANS = ', A1,
444 $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', /
445 $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.'
446 $ , /' ******* TESTS ABANDONED *******' )
447 9984 FORMAT(A12, L2 )
448 9983 FORMAT( 1X,A12, ' WAS NOT TESTED' )
449 9982 FORMAT( /' END OF TESTS' )
450 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
451 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
452 *
453 * End of DBLAT2.
454 *
455 END
456 SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
457 $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
458 $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
459 $ XS, Y, YY, YS, YT, G, IORDER )
460 *
461 * Tests DGEMV and DGBMV.
462 *
463 * Auxiliary routine for test program for Level 2 Blas.
464 *
465 * -- Written on 10-August-1987.
466 * Richard Hanson, Sandia National Labs.
467 * Jeremy Du Croz, NAG Central Office.
468 *
469 * .. Parameters ..
470 DOUBLE PRECISION ZERO, HALF
471 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0 )
472 * .. Scalar Arguments ..
473 DOUBLE PRECISION EPS, THRESH
474 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
475 $ NOUT, NTRA, IORDER
476 LOGICAL FATAL, REWI, TRACE
477 CHARACTER*12 SNAME
478 * .. Array Arguments ..
479 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
480 $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ),
481 $ X( NMAX ), XS( NMAX*INCMAX ),
482 $ XX( NMAX*INCMAX ), Y( NMAX ),
483 $ YS( NMAX*INCMAX ), YT( NMAX ),
484 $ YY( NMAX*INCMAX )
485 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
486 * .. Local Scalars ..
487 DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL
488 INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY,
489 $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA,
490 $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK,
491 $ NL, NS
492 LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN
493 CHARACTER*1 TRANS, TRANSS
494 CHARACTER*14 CTRANS
495 CHARACTER*3 ICH
496 * .. Local Arrays ..
497 LOGICAL ISAME( 13 )
498 * .. External Functions ..
499 LOGICAL LDE, LDERES
500 EXTERNAL LDE, LDERES
501 * .. External Subroutines ..
502 EXTERNAL CDGBMV, CDGEMV, DMAKE, DMVCH
503 * .. Intrinsic Functions ..
504 INTRINSIC ABS, MAX, MIN
505 * .. Scalars in Common ..
506 INTEGER INFOT, NOUTC
507 LOGICAL OK
508 * .. Common blocks ..
509 COMMON /INFOC/INFOT, NOUTC, OK
510 * .. Data statements ..
511 DATA ICH/'NTC'/
512 * .. Executable Statements ..
513 FULL = SNAME( 9: 9 ).EQ.'e'
514 BANDED = SNAME( 9: 9 ).EQ.'b'
515 * Define the number of arguments.
516 IF( FULL )THEN
517 NARGS = 11
518 ELSE IF( BANDED )THEN
519 NARGS = 13
520 END IF
521 *
522 NC = 0
523 RESET = .TRUE.
524 ERRMAX = ZERO
525 *
526 DO 120 IN = 1, NIDIM
527 N = IDIM( IN )
528 ND = N/2 + 1
529 *
530 DO 110 IM = 1, 2
531 IF( IM.EQ.1 )
532 $ M = MAX( N - ND, 0 )
533 IF( IM.EQ.2 )
534 $ M = MIN( N + ND, NMAX )
535 *
536 IF( BANDED )THEN
537 NK = NKB
538 ELSE
539 NK = 1
540 END IF
541 DO 100 IKU = 1, NK
542 IF( BANDED )THEN
543 KU = KB( IKU )
544 KL = MAX( KU - 1, 0 )
545 ELSE
546 KU = N - 1
547 KL = M - 1
548 END IF
549 * Set LDA to 1 more than minimum value if room.
550 IF( BANDED )THEN
551 LDA = KL + KU + 1
552 ELSE
553 LDA = M
554 END IF
555 IF( LDA.LT.NMAX )
556 $ LDA = LDA + 1
557 * Skip tests if not enough room.
558 IF( LDA.GT.NMAX )
559 $ GO TO 100
560 LAA = LDA*N
561 NULL = N.LE.0.OR.M.LE.0
562 *
563 * Generate the matrix A.
564 *
565 TRANSL = ZERO
566 CALL DMAKE( SNAME( 8: 9 ), ' ', ' ', M, N, A, NMAX, AA,
567 $ LDA, KL, KU, RESET, TRANSL )
568 *
569 DO 90 IC = 1, 3
570 TRANS = ICH( IC: IC )
571 IF (TRANS.EQ.'N')THEN
572 CTRANS = ' CblasNoTrans'
573 ELSE IF (TRANS.EQ.'T')THEN
574 CTRANS = ' CblasTrans'
575 ELSE
576 CTRANS = 'CblasConjTrans'
577 END IF
578 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
579 *
580 IF( TRAN )THEN
581 ML = N
582 NL = M
583 ELSE
584 ML = M
585 NL = N
586 END IF
587 *
588 DO 80 IX = 1, NINC
589 INCX = INC( IX )
590 LX = ABS( INCX )*NL
591 *
592 * Generate the vector X.
593 *
594 TRANSL = HALF
595 CALL DMAKE( 'ge', ' ', ' ', 1, NL, X, 1, XX,
596 $ ABS( INCX ), 0, NL - 1, RESET, TRANSL )
597 IF( NL.GT.1 )THEN
598 X( NL/2 ) = ZERO
599 XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO
600 END IF
601 *
602 DO 70 IY = 1, NINC
603 INCY = INC( IY )
604 LY = ABS( INCY )*ML
605 *
606 DO 60 IA = 1, NALF
607 ALPHA = ALF( IA )
608 *
609 DO 50 IB = 1, NBET
610 BETA = BET( IB )
611 *
612 * Generate the vector Y.
613 *
614 TRANSL = ZERO
615 CALL DMAKE( 'ge', ' ', ' ', 1, ML, Y, 1,
616 $ YY, ABS( INCY ), 0, ML - 1,
617 $ RESET, TRANSL )
618 *
619 NC = NC + 1
620 *
621 * Save every datum before calling the
622 * subroutine.
623 *
624 TRANSS = TRANS
625 MS = M
626 NS = N
627 KLS = KL
628 KUS = KU
629 ALS = ALPHA
630 DO 10 I = 1, LAA
631 AS( I ) = AA( I )
632 10 CONTINUE
633 LDAS = LDA
634 DO 20 I = 1, LX
635 XS( I ) = XX( I )
636 20 CONTINUE
637 INCXS = INCX
638 BLS = BETA
639 DO 30 I = 1, LY
640 YS( I ) = YY( I )
641 30 CONTINUE
642 INCYS = INCY
643 *
644 * Call the subroutine.
645 *
646 IF( FULL )THEN
647 IF( TRACE )
648 $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
649 $ CTRANS, M, N, ALPHA, LDA, INCX,
650 $ BETA, INCY
651 IF( REWI )
652 $ REWIND NTRA
653 CALL CDGEMV( IORDER, TRANS, M, N,
654 $ ALPHA, AA, LDA, XX, INCX,
655 $ BETA, YY, INCY )
656 ELSE IF( BANDED )THEN
657 IF( TRACE )
658 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
659 $ CTRANS, M, N, KL, KU, ALPHA, LDA,
660 $ INCX, BETA, INCY
661 IF( REWI )
662 $ REWIND NTRA
663 CALL CDGBMV( IORDER, TRANS, M, N, KL,
664 $ KU, ALPHA, AA, LDA, XX,
665 $ INCX, BETA, YY, INCY )
666 END IF
667 *
668 * Check if error-exit was taken incorrectly.
669 *
670 IF( .NOT.OK )THEN
671 WRITE( NOUT, FMT = 9993 )
672 FATAL = .TRUE.
673 GO TO 130
674 END IF
675 *
676 * See what data changed inside subroutines.
677 *
678 ISAME( 1 ) = TRANS.EQ.TRANSS
679 ISAME( 2 ) = MS.EQ.M
680 ISAME( 3 ) = NS.EQ.N
681 IF( FULL )THEN
682 ISAME( 4 ) = ALS.EQ.ALPHA
683 ISAME( 5 ) = LDE( AS, AA, LAA )
684 ISAME( 6 ) = LDAS.EQ.LDA
685 ISAME( 7 ) = LDE( XS, XX, LX )
686 ISAME( 8 ) = INCXS.EQ.INCX
687 ISAME( 9 ) = BLS.EQ.BETA
688 IF( NULL )THEN
689 ISAME( 10 ) = LDE( YS, YY, LY )
690 ELSE
691 ISAME( 10 ) = LDERES( 'ge', ' ', 1,
692 $ ML, YS, YY,
693 $ ABS( INCY ) )
694 END IF
695 ISAME( 11 ) = INCYS.EQ.INCY
696 ELSE IF( BANDED )THEN
697 ISAME( 4 ) = KLS.EQ.KL
698 ISAME( 5 ) = KUS.EQ.KU
699 ISAME( 6 ) = ALS.EQ.ALPHA
700 ISAME( 7 ) = LDE( AS, AA, LAA )
701 ISAME( 8 ) = LDAS.EQ.LDA
702 ISAME( 9 ) = LDE( XS, XX, LX )
703 ISAME( 10 ) = INCXS.EQ.INCX
704 ISAME( 11 ) = BLS.EQ.BETA
705 IF( NULL )THEN
706 ISAME( 12 ) = LDE( YS, YY, LY )
707 ELSE
708 ISAME( 12 ) = LDERES( 'ge', ' ', 1,
709 $ ML, YS, YY,
710 $ ABS( INCY ) )
711 END IF
712 ISAME( 13 ) = INCYS.EQ.INCY
713 END IF
714 *
715 * If data was incorrectly changed, report
716 * and return.
717 *
718 SAME = .TRUE.
719 DO 40 I = 1, NARGS
720 SAME = SAME.AND.ISAME( I )
721 IF( .NOT.ISAME( I ) )
722 $ WRITE( NOUT, FMT = 9998 )I
723 40 CONTINUE
724 IF( .NOT.SAME )THEN
725 FATAL = .TRUE.
726 GO TO 130
727 END IF
728 *
729 IF( .NOT.NULL )THEN
730 *
731 * Check the result.
732 *
733 CALL DMVCH( TRANS, M, N, ALPHA, A,
734 $ NMAX, X, INCX, BETA, Y,
735 $ INCY, YT, G, YY, EPS, ERR,
736 $ FATAL, NOUT, .TRUE. )
737 ERRMAX = MAX( ERRMAX, ERR )
738 * If got really bad answer, report and
739 * return.
740 IF( FATAL )
741 $ GO TO 130
742 ELSE
743 * Avoid repeating tests with M.le.0 or
744 * N.le.0.
745 GO TO 110
746 END IF
747 *
748 50 CONTINUE
749 *
750 60 CONTINUE
751 *
752 70 CONTINUE
753 *
754 80 CONTINUE
755 *
756 90 CONTINUE
757 *
758 100 CONTINUE
759 *
760 110 CONTINUE
761 *
762 120 CONTINUE
763 *
764 * Report result.
765 *
766 IF( ERRMAX.LT.THRESH )THEN
767 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
768 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
769 ELSE
770 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
771 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
772 END IF
773 GO TO 140
774 *
775 130 CONTINUE
776 WRITE( NOUT, FMT = 9996 )SNAME
777 IF( FULL )THEN
778 WRITE( NOUT, FMT = 9994 )NC, SNAME, CTRANS, M, N, ALPHA, LDA,
779 $ INCX, BETA, INCY
780 ELSE IF( BANDED )THEN
781 WRITE( NOUT, FMT = 9995 )NC, SNAME, CTRANS, M, N, KL, KU,
782 $ ALPHA, LDA, INCX, BETA, INCY
783 END IF
784 *
785 140 CONTINUE
786 RETURN
787 *
788 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
789 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
790 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
791 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
792 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
793 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
794 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
795 $ ' (', I6, ' CALL', 'S)' )
796 10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
797 $ ' (', I6, ' CALL', 'S)' )
798 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
799 $ 'ANGED INCORRECTLY *******' )
800 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
801 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
802 $ ' - SUSPECT *******' )
803 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' )
804 9995 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 4( I3, ',' ), F4.1,
805 $ ', A,', I3, ',',/ 10x,'X,', I2, ',', F4.1, ', Y,',
806 $ I2, ') .' )
807 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 2( I3, ',' ), F4.1,
808 $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2,
809 $ ') .' )
810 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
811 $ '******' )
812 *
813 * End of DCHK1.
814 *
815 END
816 SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
817 $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
818 $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
819 $ XS, Y, YY, YS, YT, G, IORDER )
820 *
821 * Tests DSYMV, DSBMV and DSPMV.
822 *
823 * Auxiliary routine for test program for Level 2 Blas.
824 *
825 * -- Written on 10-August-1987.
826 * Richard Hanson, Sandia National Labs.
827 * Jeremy Du Croz, NAG Central Office.
828 *
829 * .. Parameters ..
830 DOUBLE PRECISION ZERO, HALF
831 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0 )
832 * .. Scalar Arguments ..
833 DOUBLE PRECISION EPS, THRESH
834 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
835 $ NOUT, NTRA, IORDER
836 LOGICAL FATAL, REWI, TRACE
837 CHARACTER*12 SNAME
838 * .. Array Arguments ..
839 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
840 $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ),
841 $ X( NMAX ), XS( NMAX*INCMAX ),
842 $ XX( NMAX*INCMAX ), Y( NMAX ),
843 $ YS( NMAX*INCMAX ), YT( NMAX ),
844 $ YY( NMAX*INCMAX )
845 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
846 * .. Local Scalars ..
847 DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL
848 INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY,
849 $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY,
850 $ N, NARGS, NC, NK, NS
851 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
852 CHARACTER*1 UPLO, UPLOS
853 CHARACTER*14 CUPLO
854 CHARACTER*2 ICH
855 * .. Local Arrays ..
856 LOGICAL ISAME( 13 )
857 * .. External Functions ..
858 LOGICAL LDE, LDERES
859 EXTERNAL LDE, LDERES
860 * .. External Subroutines ..
861 EXTERNAL DMAKE, DMVCH, CDSBMV, CDSPMV, CDSYMV
862 * .. Intrinsic Functions ..
863 INTRINSIC ABS, MAX
864 * .. Scalars in Common ..
865 INTEGER INFOT, NOUTC
866 LOGICAL OK
867 * .. Common blocks ..
868 COMMON /INFOC/INFOT, NOUTC, OK
869 * .. Data statements ..
870 DATA ICH/'UL'/
871 * .. Executable Statements ..
872 FULL = SNAME( 9: 9 ).EQ.'y'
873 BANDED = SNAME( 9: 9 ).EQ.'b'
874 PACKED = SNAME( 9: 9 ).EQ.'p'
875 * Define the number of arguments.
876 IF( FULL )THEN
877 NARGS = 10
878 ELSE IF( BANDED )THEN
879 NARGS = 11
880 ELSE IF( PACKED )THEN
881 NARGS = 9
882 END IF
883 *
884 NC = 0
885 RESET = .TRUE.
886 ERRMAX = ZERO
887 *
888 DO 110 IN = 1, NIDIM
889 N = IDIM( IN )
890 *
891 IF( BANDED )THEN
892 NK = NKB
893 ELSE
894 NK = 1
895 END IF
896 DO 100 IK = 1, NK
897 IF( BANDED )THEN
898 K = KB( IK )
899 ELSE
900 K = N - 1
901 END IF
902 * Set LDA to 1 more than minimum value if room.
903 IF( BANDED )THEN
904 LDA = K + 1
905 ELSE
906 LDA = N
907 END IF
908 IF( LDA.LT.NMAX )
909 $ LDA = LDA + 1
910 * Skip tests if not enough room.
911 IF( LDA.GT.NMAX )
912 $ GO TO 100
913 IF( PACKED )THEN
914 LAA = ( N*( N + 1 ) )/2
915 ELSE
916 LAA = LDA*N
917 END IF
918 NULL = N.LE.0
919 *
920 DO 90 IC = 1, 2
921 UPLO = ICH( IC: IC )
922 IF (UPLO.EQ.'U')THEN
923 CUPLO = ' CblasUpper'
924 ELSE
925 CUPLO = ' CblasLower'
926 END IF
927 *
928 * Generate the matrix A.
929 *
930 TRANSL = ZERO
931 CALL DMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A, NMAX, AA,
932 $ LDA, K, K, RESET, TRANSL )
933 *
934 DO 80 IX = 1, NINC
935 INCX = INC( IX )
936 LX = ABS( INCX )*N
937 *
938 * Generate the vector X.
939 *
940 TRANSL = HALF
941 CALL DMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX,
942 $ ABS( INCX ), 0, N - 1, RESET, TRANSL )
943 IF( N.GT.1 )THEN
944 X( N/2 ) = ZERO
945 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
946 END IF
947 *
948 DO 70 IY = 1, NINC
949 INCY = INC( IY )
950 LY = ABS( INCY )*N
951 *
952 DO 60 IA = 1, NALF
953 ALPHA = ALF( IA )
954 *
955 DO 50 IB = 1, NBET
956 BETA = BET( IB )
957 *
958 * Generate the vector Y.
959 *
960 TRANSL = ZERO
961 CALL DMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY,
962 $ ABS( INCY ), 0, N - 1, RESET,
963 $ TRANSL )
964 *
965 NC = NC + 1
966 *
967 * Save every datum before calling the
968 * subroutine.
969 *
970 UPLOS = UPLO
971 NS = N
972 KS = K
973 ALS = ALPHA
974 DO 10 I = 1, LAA
975 AS( I ) = AA( I )
976 10 CONTINUE
977 LDAS = LDA
978 DO 20 I = 1, LX
979 XS( I ) = XX( I )
980 20 CONTINUE
981 INCXS = INCX
982 BLS = BETA
983 DO 30 I = 1, LY
984 YS( I ) = YY( I )
985 30 CONTINUE
986 INCYS = INCY
987 *
988 * Call the subroutine.
989 *
990 IF( FULL )THEN
991 IF( TRACE )
992 $ WRITE( NTRA, FMT = 9993 )NC, SNAME,
993 $ CUPLO, N, ALPHA, LDA, INCX, BETA, INCY
994 IF( REWI )
995 $ REWIND NTRA
996 CALL CDSYMV( IORDER, UPLO, N, ALPHA, AA,
997 $ LDA, XX, INCX, BETA, YY, INCY )
998 ELSE IF( BANDED )THEN
999 IF( TRACE )
1000 $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
1001 $ CUPLO, N, K, ALPHA, LDA, INCX, BETA,
1002 $ INCY
1003 IF( REWI )
1004 $ REWIND NTRA
1005 CALL CDSBMV( IORDER, UPLO, N, K, ALPHA,
1006 $ AA, LDA, XX, INCX, BETA, YY,
1007 $ INCY )
1008 ELSE IF( PACKED )THEN
1009 IF( TRACE )
1010 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1011 $ CUPLO, N, ALPHA, INCX, BETA, INCY
1012 IF( REWI )
1013 $ REWIND NTRA
1014 CALL CDSPMV( IORDER, UPLO, N, ALPHA, AA,
1015 $ XX, INCX, BETA, YY, INCY )
1016 END IF
1017 *
1018 * Check if error-exit was taken incorrectly.
1019 *
1020 IF( .NOT.OK )THEN
1021 WRITE( NOUT, FMT = 9992 )
1022 FATAL = .TRUE.
1023 GO TO 120
1024 END IF
1025 *
1026 * See what data changed inside subroutines.
1027 *
1028 ISAME( 1 ) = UPLO.EQ.UPLOS
1029 ISAME( 2 ) = NS.EQ.N
1030 IF( FULL )THEN
1031 ISAME( 3 ) = ALS.EQ.ALPHA
1032 ISAME( 4 ) = LDE( AS, AA, LAA )
1033 ISAME( 5 ) = LDAS.EQ.LDA
1034 ISAME( 6 ) = LDE( XS, XX, LX )
1035 ISAME( 7 ) = INCXS.EQ.INCX
1036 ISAME( 8 ) = BLS.EQ.BETA
1037 IF( NULL )THEN
1038 ISAME( 9 ) = LDE( YS, YY, LY )
1039 ELSE
1040 ISAME( 9 ) = LDERES( 'ge', ' ', 1, N,
1041 $ YS, YY, ABS( INCY ) )
1042 END IF
1043 ISAME( 10 ) = INCYS.EQ.INCY
1044 ELSE IF( BANDED )THEN
1045 ISAME( 3 ) = KS.EQ.K
1046 ISAME( 4 ) = ALS.EQ.ALPHA
1047 ISAME( 5 ) = LDE( AS, AA, LAA )
1048 ISAME( 6 ) = LDAS.EQ.LDA
1049 ISAME( 7 ) = LDE( XS, XX, LX )
1050 ISAME( 8 ) = INCXS.EQ.INCX
1051 ISAME( 9 ) = BLS.EQ.BETA
1052 IF( NULL )THEN
1053 ISAME( 10 ) = LDE( YS, YY, LY )
1054 ELSE
1055 ISAME( 10 ) = LDERES( 'ge', ' ', 1, N,
1056 $ YS, YY, ABS( INCY ) )
1057 END IF
1058 ISAME( 11 ) = INCYS.EQ.INCY
1059 ELSE IF( PACKED )THEN
1060 ISAME( 3 ) = ALS.EQ.ALPHA
1061 ISAME( 4 ) = LDE( AS, AA, LAA )
1062 ISAME( 5 ) = LDE( XS, XX, LX )
1063 ISAME( 6 ) = INCXS.EQ.INCX
1064 ISAME( 7 ) = BLS.EQ.BETA
1065 IF( NULL )THEN
1066 ISAME( 8 ) = LDE( YS, YY, LY )
1067 ELSE
1068 ISAME( 8 ) = LDERES( 'ge', ' ', 1, N,
1069 $ YS, YY, ABS( INCY ) )
1070 END IF
1071 ISAME( 9 ) = INCYS.EQ.INCY
1072 END IF
1073 *
1074 * If data was incorrectly changed, report and
1075 * return.
1076 *
1077 SAME = .TRUE.
1078 DO 40 I = 1, NARGS
1079 SAME = SAME.AND.ISAME( I )
1080 IF( .NOT.ISAME( I ) )
1081 $ WRITE( NOUT, FMT = 9998 )I
1082 40 CONTINUE
1083 IF( .NOT.SAME )THEN
1084 FATAL = .TRUE.
1085 GO TO 120
1086 END IF
1087 *
1088 IF( .NOT.NULL )THEN
1089 *
1090 * Check the result.
1091 *
1092 CALL DMVCH( 'N', N, N, ALPHA, A, NMAX, X,
1093 $ INCX, BETA, Y, INCY, YT, G,
1094 $ YY, EPS, ERR, FATAL, NOUT,
1095 $ .TRUE. )
1096 ERRMAX = MAX( ERRMAX, ERR )
1097 * If got really bad answer, report and
1098 * return.
1099 IF( FATAL )
1100 $ GO TO 120
1101 ELSE
1102 * Avoid repeating tests with N.le.0
1103 GO TO 110
1104 END IF
1105 *
1106 50 CONTINUE
1107 *
1108 60 CONTINUE
1109 *
1110 70 CONTINUE
1111 *
1112 80 CONTINUE
1113 *
1114 90 CONTINUE
1115 *
1116 100 CONTINUE
1117 *
1118 110 CONTINUE
1119 *
1120 * Report result.
1121 *
1122 IF( ERRMAX.LT.THRESH )THEN
1123 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
1124 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
1125 ELSE
1126 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
1127 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
1128 END IF
1129 GO TO 130
1130 *
1131 120 CONTINUE
1132 WRITE( NOUT, FMT = 9996 )SNAME
1133 IF( FULL )THEN
1134 WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, LDA, INCX,
1135 $ BETA, INCY
1136 ELSE IF( BANDED )THEN
1137 WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, K, ALPHA, LDA,
1138 $ INCX, BETA, INCY
1139 ELSE IF( PACKED )THEN
1140 WRITE( NOUT, FMT = 9995 )NC, SNAME, CUPLO, N, ALPHA, INCX,
1141 $ BETA, INCY
1142 END IF
1143 *
1144 130 CONTINUE
1145 RETURN
1146 *
1147 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1148 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1149 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1150 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1151 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1152 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1153 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1154 $ ' (', I6, ' CALL', 'S)' )
1155 10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1156 $ ' (', I6, ' CALL', 'S)' )
1157 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1158 $ 'ANGED INCORRECTLY *******' )
1159 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1160 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1161 $ ' - SUSPECT *******' )
1162 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' )
1163 9995 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', AP',
1164 $ ', X,', I2, ',', F4.1, ', Y,', I2, ') .' )
1165 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 2( I3, ',' ), F4.1,
1166 $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2,
1167 $ ') .' )
1168 9993 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', A,',
1169 $ I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' )
1170 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1171 $ '******' )
1172 *
1173 * End of DCHK2.
1174 *
1175 END
1176 SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1177 $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX,
1178 $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z, IORDER )
1179 *
1180 * Tests DTRMV, DTBMV, DTPMV, DTRSV, DTBSV and DTPSV.
1181 *
1182 * Auxiliary routine for test program for Level 2 Blas.
1183 *
1184 * -- Written on 10-August-1987.
1185 * Richard Hanson, Sandia National Labs.
1186 * Jeremy Du Croz, NAG Central Office.
1187 *
1188 * .. Parameters ..
1189 DOUBLE PRECISION ZERO, HALF, ONE
1190 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
1191 * .. Scalar Arguments ..
1192 DOUBLE PRECISION EPS, THRESH
1193 INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA,
1194 $ IORDER
1195 LOGICAL FATAL, REWI, TRACE
1196 CHARACTER*12 SNAME
1197 * .. Array Arguments ..
1198 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ),
1199 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1200 $ XS( NMAX*INCMAX ), XT( NMAX ),
1201 $ XX( NMAX*INCMAX ), Z( NMAX )
1202 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
1203 * .. Local Scalars ..
1204 DOUBLE PRECISION ERR, ERRMAX, TRANSL
1205 INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K,
1206 $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS
1207 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
1208 CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS
1209 CHARACTER*14 CUPLO,CTRANS,CDIAG
1210 CHARACTER*2 ICHD, ICHU
1211 CHARACTER*3 ICHT
1212 * .. Local Arrays ..
1213 LOGICAL ISAME( 13 )
1214 * .. External Functions ..
1215 LOGICAL LDE, LDERES
1216 EXTERNAL LDE, LDERES
1217 * .. External Subroutines ..
1218 EXTERNAL DMAKE, DMVCH, CDTBMV, CDTBSV, CDTPMV,
1219 $ CDTPSV, CDTRMV, CDTRSV
1220 * .. Intrinsic Functions ..
1221 INTRINSIC ABS, MAX
1222 * .. Scalars in Common ..
1223 INTEGER INFOT, NOUTC
1224 LOGICAL OK
1225 * .. Common blocks ..
1226 COMMON /INFOC/INFOT, NOUTC, OK
1227 * .. Data statements ..
1228 DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/
1229 * .. Executable Statements ..
1230 FULL = SNAME( 9: 9 ).EQ.'r'
1231 BANDED = SNAME( 9: 9 ).EQ.'b'
1232 PACKED = SNAME( 9: 9 ).EQ.'p'
1233 * Define the number of arguments.
1234 IF( FULL )THEN
1235 NARGS = 8
1236 ELSE IF( BANDED )THEN
1237 NARGS = 9
1238 ELSE IF( PACKED )THEN
1239 NARGS = 7
1240 END IF
1241 *
1242 NC = 0
1243 RESET = .TRUE.
1244 ERRMAX = ZERO
1245 * Set up zero vector for DMVCH.
1246 DO 10 I = 1, NMAX
1247 Z( I ) = ZERO
1248 10 CONTINUE
1249 *
1250 DO 110 IN = 1, NIDIM
1251 N = IDIM( IN )
1252 *
1253 IF( BANDED )THEN
1254 NK = NKB
1255 ELSE
1256 NK = 1
1257 END IF
1258 DO 100 IK = 1, NK
1259 IF( BANDED )THEN
1260 K = KB( IK )
1261 ELSE
1262 K = N - 1
1263 END IF
1264 * Set LDA to 1 more than minimum value if room.
1265 IF( BANDED )THEN
1266 LDA = K + 1
1267 ELSE
1268 LDA = N
1269 END IF
1270 IF( LDA.LT.NMAX )
1271 $ LDA = LDA + 1
1272 * Skip tests if not enough room.
1273 IF( LDA.GT.NMAX )
1274 $ GO TO 100
1275 IF( PACKED )THEN
1276 LAA = ( N*( N + 1 ) )/2
1277 ELSE
1278 LAA = LDA*N
1279 END IF
1280 NULL = N.LE.0
1281 *
1282 DO 90 ICU = 1, 2
1283 UPLO = ICHU( ICU: ICU )
1284 IF (UPLO.EQ.'U')THEN
1285 CUPLO = ' CblasUpper'
1286 ELSE
1287 CUPLO = ' CblasLower'
1288 END IF
1289 *
1290 DO 80 ICT = 1, 3
1291 TRANS = ICHT( ICT: ICT )
1292 IF (TRANS.EQ.'N')THEN
1293 CTRANS = ' CblasNoTrans'
1294 ELSE IF (TRANS.EQ.'T')THEN
1295 CTRANS = ' CblasTrans'
1296 ELSE
1297 CTRANS = 'CblasConjTrans'
1298 END IF
1299 *
1300 DO 70 ICD = 1, 2
1301 DIAG = ICHD( ICD: ICD )
1302 IF (DIAG.EQ.'N')THEN
1303 CDIAG = ' CblasNonUnit'
1304 ELSE
1305 CDIAG = ' CblasUnit'
1306 END IF
1307 *
1308 * Generate the matrix A.
1309 *
1310 TRANSL = ZERO
1311 CALL DMAKE( SNAME( 8: 9 ), UPLO, DIAG, N, N, A,
1312 $ NMAX, AA, LDA, K, K, RESET, TRANSL )
1313 *
1314 DO 60 IX = 1, NINC
1315 INCX = INC( IX )
1316 LX = ABS( INCX )*N
1317 *
1318 * Generate the vector X.
1319 *
1320 TRANSL = HALF
1321 CALL DMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX,
1322 $ ABS( INCX ), 0, N - 1, RESET,
1323 $ TRANSL )
1324 IF( N.GT.1 )THEN
1325 X( N/2 ) = ZERO
1326 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
1327 END IF
1328 *
1329 NC = NC + 1
1330 *
1331 * Save every datum before calling the subroutine.
1332 *
1333 UPLOS = UPLO
1334 TRANSS = TRANS
1335 DIAGS = DIAG
1336 NS = N
1337 KS = K
1338 DO 20 I = 1, LAA
1339 AS( I ) = AA( I )
1340 20 CONTINUE
1341 LDAS = LDA
1342 DO 30 I = 1, LX
1343 XS( I ) = XX( I )
1344 30 CONTINUE
1345 INCXS = INCX
1346 *
1347 * Call the subroutine.
1348 *
1349 IF( SNAME( 10: 11 ).EQ.'mv' )THEN
1350 IF( FULL )THEN
1351 IF( TRACE )
1352 $ WRITE( NTRA, FMT = 9993 )NC, SNAME,
1353 $ CUPLO, CTRANS, CDIAG, N, LDA, INCX
1354 IF( REWI )
1355 $ REWIND NTRA
1356 CALL CDTRMV( IORDER, UPLO, TRANS, DIAG,
1357 $ N, AA, LDA, XX, INCX )
1358 ELSE IF( BANDED )THEN
1359 IF( TRACE )
1360 $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
1361 $ CUPLO, CTRANS, CDIAG, N, K, LDA, INCX
1362 IF( REWI )
1363 $ REWIND NTRA
1364 CALL CDTBMV( IORDER, UPLO, TRANS, DIAG,
1365 $ N, K, AA, LDA, XX, INCX )
1366 ELSE IF( PACKED )THEN
1367 IF( TRACE )
1368 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1369 $ CUPLO, CTRANS, CDIAG, N, INCX
1370 IF( REWI )
1371 $ REWIND NTRA
1372 CALL CDTPMV( IORDER, UPLO, TRANS, DIAG,
1373 $ N, AA, XX, INCX )
1374 END IF
1375 ELSE IF( SNAME( 10: 11 ).EQ.'sv' )THEN
1376 IF( FULL )THEN
1377 IF( TRACE )
1378 $ WRITE( NTRA, FMT = 9993 )NC, SNAME,
1379 $ CUPLO, CTRANS, CDIAG, N, LDA, INCX
1380 IF( REWI )
1381 $ REWIND NTRA
1382 CALL CDTRSV( IORDER, UPLO, TRANS, DIAG,
1383 $ N, AA, LDA, XX, INCX )
1384 ELSE IF( BANDED )THEN
1385 IF( TRACE )
1386 $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
1387 $ CUPLO, CTRANS, CDIAG, N, K, LDA, INCX
1388 IF( REWI )
1389 $ REWIND NTRA
1390 CALL CDTBSV( IORDER, UPLO, TRANS, DIAG,
1391 $ N, K, AA, LDA, XX, INCX )
1392 ELSE IF( PACKED )THEN
1393 IF( TRACE )
1394 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1395 $ CUPLO, CTRANS, CDIAG, N, INCX
1396 IF( REWI )
1397 $ REWIND NTRA
1398 CALL CDTPSV( IORDER, UPLO, TRANS, DIAG,
1399 $ N, AA, XX, INCX )
1400 END IF
1401 END IF
1402 *
1403 * Check if error-exit was taken incorrectly.
1404 *
1405 IF( .NOT.OK )THEN
1406 WRITE( NOUT, FMT = 9992 )
1407 FATAL = .TRUE.
1408 GO TO 120
1409 END IF
1410 *
1411 * See what data changed inside subroutines.
1412 *
1413 ISAME( 1 ) = UPLO.EQ.UPLOS
1414 ISAME( 2 ) = TRANS.EQ.TRANSS
1415 ISAME( 3 ) = DIAG.EQ.DIAGS
1416 ISAME( 4 ) = NS.EQ.N
1417 IF( FULL )THEN
1418 ISAME( 5 ) = LDE( AS, AA, LAA )
1419 ISAME( 6 ) = LDAS.EQ.LDA
1420 IF( NULL )THEN
1421 ISAME( 7 ) = LDE( XS, XX, LX )
1422 ELSE
1423 ISAME( 7 ) = LDERES( 'ge', ' ', 1, N, XS,
1424 $ XX, ABS( INCX ) )
1425 END IF
1426 ISAME( 8 ) = INCXS.EQ.INCX
1427 ELSE IF( BANDED )THEN
1428 ISAME( 5 ) = KS.EQ.K
1429 ISAME( 6 ) = LDE( AS, AA, LAA )
1430 ISAME( 7 ) = LDAS.EQ.LDA
1431 IF( NULL )THEN
1432 ISAME( 8 ) = LDE( XS, XX, LX )
1433 ELSE
1434 ISAME( 8 ) = LDERES( 'ge', ' ', 1, N, XS,
1435 $ XX, ABS( INCX ) )
1436 END IF
1437 ISAME( 9 ) = INCXS.EQ.INCX
1438 ELSE IF( PACKED )THEN
1439 ISAME( 5 ) = LDE( AS, AA, LAA )
1440 IF( NULL )THEN
1441 ISAME( 6 ) = LDE( XS, XX, LX )
1442 ELSE
1443 ISAME( 6 ) = LDERES( 'ge', ' ', 1, N, XS,
1444 $ XX, ABS( INCX ) )
1445 END IF
1446 ISAME( 7 ) = INCXS.EQ.INCX
1447 END IF
1448 *
1449 * If data was incorrectly changed, report and
1450 * return.
1451 *
1452 SAME = .TRUE.
1453 DO 40 I = 1, NARGS
1454 SAME = SAME.AND.ISAME( I )
1455 IF( .NOT.ISAME( I ) )
1456 $ WRITE( NOUT, FMT = 9998 )I
1457 40 CONTINUE
1458 IF( .NOT.SAME )THEN
1459 FATAL = .TRUE.
1460 GO TO 120
1461 END IF
1462 *
1463 IF( .NOT.NULL )THEN
1464 IF( SNAME( 10: 11 ).EQ.'mv' )THEN
1465 *
1466 * Check the result.
1467 *
1468 CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X,
1469 $ INCX, ZERO, Z, INCX, XT, G,
1470 $ XX, EPS, ERR, FATAL, NOUT,
1471 $ .TRUE. )
1472 ELSE IF( SNAME( 10: 11 ).EQ.'sv' )THEN
1473 *
1474 * Compute approximation to original vector.
1475 *
1476 DO 50 I = 1, N
1477 Z( I ) = XX( 1 + ( I - 1 )*
1478 $ ABS( INCX ) )
1479 XX( 1 + ( I - 1 )*ABS( INCX ) )
1480 $ = X( I )
1481 50 CONTINUE
1482 CALL DMVCH( TRANS, N, N, ONE, A, NMAX, Z,
1483 $ INCX, ZERO, X, INCX, XT, G,
1484 $ XX, EPS, ERR, FATAL, NOUT,
1485 $ .FALSE. )
1486 END IF
1487 ERRMAX = MAX( ERRMAX, ERR )
1488 * If got really bad answer, report and return.
1489 IF( FATAL )
1490 $ GO TO 120
1491 ELSE
1492 * Avoid repeating tests with N.le.0.
1493 GO TO 110
1494 END IF
1495 *
1496 60 CONTINUE
1497 *
1498 70 CONTINUE
1499 *
1500 80 CONTINUE
1501 *
1502 90 CONTINUE
1503 *
1504 100 CONTINUE
1505 *
1506 110 CONTINUE
1507 *
1508 * Report result.
1509 *
1510 IF( ERRMAX.LT.THRESH )THEN
1511 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
1512 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
1513 ELSE
1514 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
1515 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
1516 END IF
1517 GO TO 130
1518 *
1519 120 CONTINUE
1520 WRITE( NOUT, FMT = 9996 )SNAME
1521 IF( FULL )THEN
1522 WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, CTRANS, CDIAG, N,
1523 $ LDA, INCX
1524 ELSE IF( BANDED )THEN
1525 WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, CTRANS, CDIAG, N, K,
1526 $ LDA, INCX
1527 ELSE IF( PACKED )THEN
1528 WRITE( NOUT, FMT = 9995 )NC, SNAME, CUPLO, CTRANS, CDIAG, N,
1529 $ INCX
1530 END IF
1531 *
1532 130 CONTINUE
1533 RETURN
1534 *
1535 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1536 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1537 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1538 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1539 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1540 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1541 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1542 $ ' (', I6, ' CALL', 'S)' )
1543 10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1544 $ ' (', I6, ' CALL', 'S)' )
1545 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1546 $ 'ANGED INCORRECTLY *******' )
1547 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1548 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1549 $ ' - SUSPECT *******' )
1550 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' )
1551 9995 FORMAT( 1X, I6, ': ',A12, '(', 3( A14,',' ),/ 10x, I3, ', AP, ',
1552 $ 'X,', I2, ') .' )
1553 9994 FORMAT( 1X, I6, ': ',A12, '(', 3( A14,',' ),/ 10x, 2( I3, ',' ),
1554 $ ' A,', I3, ', X,', I2, ') .' )
1555 9993 FORMAT( 1X, I6, ': ',A12, '(', 3( A14,',' ),/ 10x, I3, ', A,',
1556 $ I3, ', X,', I2, ') .' )
1557 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1558 $ '******' )
1559 *
1560 * End of DCHK3.
1561 *
1562 END
1563 SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1564 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
1565 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
1566 $ Z, IORDER )
1567 *
1568 * Tests DGER.
1569 *
1570 * Auxiliary routine for test program for Level 2 Blas.
1571 *
1572 * -- Written on 10-August-1987.
1573 * Richard Hanson, Sandia National Labs.
1574 * Jeremy Du Croz, NAG Central Office.
1575 *
1576 * .. Parameters ..
1577 DOUBLE PRECISION ZERO, HALF, ONE
1578 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
1579 * .. Scalar Arguments ..
1580 DOUBLE PRECISION EPS, THRESH
1581 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA,
1582 $ IORDER
1583 LOGICAL FATAL, REWI, TRACE
1584 CHARACTER*12 SNAME
1585 * .. Array Arguments ..
1586 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1587 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1588 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
1589 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
1590 $ YY( NMAX*INCMAX ), Z( NMAX )
1591 INTEGER IDIM( NIDIM ), INC( NINC )
1592 * .. Local Scalars ..
1593 DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL
1594 INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX,
1595 $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS,
1596 $ NC, ND, NS
1597 LOGICAL NULL, RESET, SAME
1598 * .. Local Arrays ..
1599 DOUBLE PRECISION W( 1 )
1600 LOGICAL ISAME( 13 )
1601 * .. External Functions ..
1602 LOGICAL LDE, LDERES
1603 EXTERNAL LDE, LDERES
1604 * .. External Subroutines ..
1605 EXTERNAL DGER, DMAKE, DMVCH
1606 * .. Intrinsic Functions ..
1607 INTRINSIC ABS, MAX, MIN
1608 * .. Scalars in Common ..
1609 INTEGER INFOT, NOUTC
1610 LOGICAL OK
1611 * .. Common blocks ..
1612 COMMON /INFOC/INFOT, NOUTC, OK
1613 * .. Executable Statements ..
1614 * Define the number of arguments.
1615 NARGS = 9
1616 *
1617 NC = 0
1618 RESET = .TRUE.
1619 ERRMAX = ZERO
1620 *
1621 DO 120 IN = 1, NIDIM
1622 N = IDIM( IN )
1623 ND = N/2 + 1
1624 *
1625 DO 110 IM = 1, 2
1626 IF( IM.EQ.1 )
1627 $ M = MAX( N - ND, 0 )
1628 IF( IM.EQ.2 )
1629 $ M = MIN( N + ND, NMAX )
1630 *
1631 * Set LDA to 1 more than minimum value if room.
1632 LDA = M
1633 IF( LDA.LT.NMAX )
1634 $ LDA = LDA + 1
1635 * Skip tests if not enough room.
1636 IF( LDA.GT.NMAX )
1637 $ GO TO 110
1638 LAA = LDA*N
1639 NULL = N.LE.0.OR.M.LE.0
1640 *
1641 DO 100 IX = 1, NINC
1642 INCX = INC( IX )
1643 LX = ABS( INCX )*M
1644 *
1645 * Generate the vector X.
1646 *
1647 TRANSL = HALF
1648 CALL DMAKE( 'ge', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ),
1649 $ 0, M - 1, RESET, TRANSL )
1650 IF( M.GT.1 )THEN
1651 X( M/2 ) = ZERO
1652 XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO
1653 END IF
1654 *
1655 DO 90 IY = 1, NINC
1656 INCY = INC( IY )
1657 LY = ABS( INCY )*N
1658 *
1659 * Generate the vector Y.
1660 *
1661 TRANSL = ZERO
1662 CALL DMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY,
1663 $ ABS( INCY ), 0, N - 1, RESET, TRANSL )
1664 IF( N.GT.1 )THEN
1665 Y( N/2 ) = ZERO
1666 YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
1667 END IF
1668 *
1669 DO 80 IA = 1, NALF
1670 ALPHA = ALF( IA )
1671 *
1672 * Generate the matrix A.
1673 *
1674 TRANSL = ZERO
1675 CALL DMAKE( SNAME( 8: 9 ), ' ', ' ', M, N, A, NMAX,
1676 $ AA, LDA, M - 1, N - 1, RESET, TRANSL )
1677 *
1678 NC = NC + 1
1679 *
1680 * Save every datum before calling the subroutine.
1681 *
1682 MS = M
1683 NS = N
1684 ALS = ALPHA
1685 DO 10 I = 1, LAA
1686 AS( I ) = AA( I )
1687 10 CONTINUE
1688 LDAS = LDA
1689 DO 20 I = 1, LX
1690 XS( I ) = XX( I )
1691 20 CONTINUE
1692 INCXS = INCX
1693 DO 30 I = 1, LY
1694 YS( I ) = YY( I )
1695 30 CONTINUE
1696 INCYS = INCY
1697 *
1698 * Call the subroutine.
1699 *
1700 IF( TRACE )
1701 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N,
1702 $ ALPHA, INCX, INCY, LDA
1703 IF( REWI )
1704 $ REWIND NTRA
1705 CALL CDGER( IORDER, M, N, ALPHA, XX, INCX, YY,
1706 $ INCY, AA, LDA )
1707 *
1708 * Check if error-exit was taken incorrectly.
1709 *
1710 IF( .NOT.OK )THEN
1711 WRITE( NOUT, FMT = 9993 )
1712 FATAL = .TRUE.
1713 GO TO 140
1714 END IF
1715 *
1716 * See what data changed inside subroutine.
1717 *
1718 ISAME( 1 ) = MS.EQ.M
1719 ISAME( 2 ) = NS.EQ.N
1720 ISAME( 3 ) = ALS.EQ.ALPHA
1721 ISAME( 4 ) = LDE( XS, XX, LX )
1722 ISAME( 5 ) = INCXS.EQ.INCX
1723 ISAME( 6 ) = LDE( YS, YY, LY )
1724 ISAME( 7 ) = INCYS.EQ.INCY
1725 IF( NULL )THEN
1726 ISAME( 8 ) = LDE( AS, AA, LAA )
1727 ELSE
1728 ISAME( 8 ) = LDERES( 'ge', ' ', M, N, AS, AA,
1729 $ LDA )
1730 END IF
1731 ISAME( 9 ) = LDAS.EQ.LDA
1732 *
1733 * If data was incorrectly changed, report and return.
1734 *
1735 SAME = .TRUE.
1736 DO 40 I = 1, NARGS
1737 SAME = SAME.AND.ISAME( I )
1738 IF( .NOT.ISAME( I ) )
1739 $ WRITE( NOUT, FMT = 9998 )I
1740 40 CONTINUE
1741 IF( .NOT.SAME )THEN
1742 FATAL = .TRUE.
1743 GO TO 140
1744 END IF
1745 *
1746 IF( .NOT.NULL )THEN
1747 *
1748 * Check the result column by column.
1749 *
1750 IF( INCX.GT.0 )THEN
1751 DO 50 I = 1, M
1752 Z( I ) = X( I )
1753 50 CONTINUE
1754 ELSE
1755 DO 60 I = 1, M
1756 Z( I ) = X( M - I + 1 )
1757 60 CONTINUE
1758 END IF
1759 DO 70 J = 1, N
1760 IF( INCY.GT.0 )THEN
1761 W( 1 ) = Y( J )
1762 ELSE
1763 W( 1 ) = Y( N - J + 1 )
1764 END IF
1765 CALL DMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1,
1766 $ ONE, A( 1, J ), 1, YT, G,
1767 $ AA( 1 + ( J - 1 )*LDA ), EPS,
1768 $ ERR, FATAL, NOUT, .TRUE. )
1769 ERRMAX = MAX( ERRMAX, ERR )
1770 * If got really bad answer, report and return.
1771 IF( FATAL )
1772 $ GO TO 130
1773 70 CONTINUE
1774 ELSE
1775 * Avoid repeating tests with M.le.0 or N.le.0.
1776 GO TO 110
1777 END IF
1778 *
1779 80 CONTINUE
1780 *
1781 90 CONTINUE
1782 *
1783 100 CONTINUE
1784 *
1785 110 CONTINUE
1786 *
1787 120 CONTINUE
1788 *
1789 * Report result.
1790 *
1791 IF( ERRMAX.LT.THRESH )THEN
1792 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
1793 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
1794 ELSE
1795 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
1796 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
1797 END IF
1798 GO TO 150
1799 *
1800 130 CONTINUE
1801 WRITE( NOUT, FMT = 9995 )J
1802 *
1803 140 CONTINUE
1804 WRITE( NOUT, FMT = 9996 )SNAME
1805 WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA
1806 *
1807 150 CONTINUE
1808 RETURN
1809 *
1810 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1811 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1812 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1813 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1814 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1815 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1816 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1817 $ ' (', I6, ' CALL', 'S)' )
1818 10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1819 $ ' (', I6, ' CALL', 'S)' )
1820 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1821 $ 'ANGED INCORRECTLY *******' )
1822 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1823 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1824 $ ' - SUSPECT *******' )
1825 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' )
1826 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
1827 9994 FORMAT( 1X, I6, ': ',A12, '(', 2( I3, ',' ), F4.1, ', X,', I2,
1828 $ ', Y,', I2, ', A,', I3, ') .' )
1829 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1830 $ '******' )
1831 *
1832 * End of DCHK4.
1833 *
1834 END
1835 SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1836 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
1837 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
1838 $ Z, IORDER )
1839 *
1840 * Tests DSYR and DSPR.
1841 *
1842 * Auxiliary routine for test program for Level 2 Blas.
1843 *
1844 * -- Written on 10-August-1987.
1845 * Richard Hanson, Sandia National Labs.
1846 * Jeremy Du Croz, NAG Central Office.
1847 *
1848 * .. Parameters ..
1849 DOUBLE PRECISION ZERO, HALF, ONE
1850 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
1851 * .. Scalar Arguments ..
1852 DOUBLE PRECISION EPS, THRESH
1853 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA,
1854 $ IORDER
1855 LOGICAL FATAL, REWI, TRACE
1856 CHARACTER*12 SNAME
1857 * .. Array Arguments ..
1858 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1859 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1860 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
1861 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
1862 $ YY( NMAX*INCMAX ), Z( NMAX )
1863 INTEGER IDIM( NIDIM ), INC( NINC )
1864 * .. Local Scalars ..
1865 DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL
1866 INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA,
1867 $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS
1868 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
1869 CHARACTER*1 UPLO, UPLOS
1870 CHARACTER*14 CUPLO
1871 CHARACTER*2 ICH
1872 * .. Local Arrays ..
1873 DOUBLE PRECISION W( 1 )
1874 LOGICAL ISAME( 13 )
1875 * .. External Functions ..
1876 LOGICAL LDE, LDERES
1877 EXTERNAL LDE, LDERES
1878 * .. External Subroutines ..
1879 EXTERNAL DMAKE, DMVCH, CDSPR, CDSYR
1880 * .. Intrinsic Functions ..
1881 INTRINSIC ABS, MAX
1882 * .. Scalars in Common ..
1883 INTEGER INFOT, NOUTC
1884 LOGICAL OK
1885 * .. Common blocks ..
1886 COMMON /INFOC/INFOT, NOUTC, OK
1887 * .. Data statements ..
1888 DATA ICH/'UL'/
1889 * .. Executable Statements ..
1890 FULL = SNAME( 9: 9 ).EQ.'y'
1891 PACKED = SNAME( 9: 9 ).EQ.'p'
1892 * Define the number of arguments.
1893 IF( FULL )THEN
1894 NARGS = 7
1895 ELSE IF( PACKED )THEN
1896 NARGS = 6
1897 END IF
1898 *
1899 NC = 0
1900 RESET = .TRUE.
1901 ERRMAX = ZERO
1902 *
1903 DO 100 IN = 1, NIDIM
1904 N = IDIM( IN )
1905 * Set LDA to 1 more than minimum value if room.
1906 LDA = N
1907 IF( LDA.LT.NMAX )
1908 $ LDA = LDA + 1
1909 * Skip tests if not enough room.
1910 IF( LDA.GT.NMAX )
1911 $ GO TO 100
1912 IF( PACKED )THEN
1913 LAA = ( N*( N + 1 ) )/2
1914 ELSE
1915 LAA = LDA*N
1916 END IF
1917 *
1918 DO 90 IC = 1, 2
1919 UPLO = ICH( IC: IC )
1920 IF (UPLO.EQ.'U')THEN
1921 CUPLO = ' CblasUpper'
1922 ELSE
1923 CUPLO = ' CblasLower'
1924 END IF
1925 UPPER = UPLO.EQ.'U'
1926 *
1927 DO 80 IX = 1, NINC
1928 INCX = INC( IX )
1929 LX = ABS( INCX )*N
1930 *
1931 * Generate the vector X.
1932 *
1933 TRANSL = HALF
1934 CALL DMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
1935 $ 0, N - 1, RESET, TRANSL )
1936 IF( N.GT.1 )THEN
1937 X( N/2 ) = ZERO
1938 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
1939 END IF
1940 *
1941 DO 70 IA = 1, NALF
1942 ALPHA = ALF( IA )
1943 NULL = N.LE.0.OR.ALPHA.EQ.ZERO
1944 *
1945 * Generate the matrix A.
1946 *
1947 TRANSL = ZERO
1948 CALL DMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A, NMAX,
1949 $ AA, LDA, N - 1, N - 1, RESET, TRANSL )
1950 *
1951 NC = NC + 1
1952 *
1953 * Save every datum before calling the subroutine.
1954 *
1955 UPLOS = UPLO
1956 NS = N
1957 ALS = ALPHA
1958 DO 10 I = 1, LAA
1959 AS( I ) = AA( I )
1960 10 CONTINUE
1961 LDAS = LDA
1962 DO 20 I = 1, LX
1963 XS( I ) = XX( I )
1964 20 CONTINUE
1965 INCXS = INCX
1966 *
1967 * Call the subroutine.
1968 *
1969 IF( FULL )THEN
1970 IF( TRACE )
1971 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, CUPLO, N,
1972 $ ALPHA, INCX, LDA
1973 IF( REWI )
1974 $ REWIND NTRA
1975 CALL CDSYR( IORDER, UPLO, N, ALPHA, XX, INCX,
1976 $ AA, LDA )
1977 ELSE IF( PACKED )THEN
1978 IF( TRACE )
1979 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, CUPLO, N,
1980 $ ALPHA, INCX
1981 IF( REWI )
1982 $ REWIND NTRA
1983 CALL CDSPR( IORDER, UPLO, N, ALPHA, XX, INCX, AA )
1984 END IF
1985 *
1986 * Check if error-exit was taken incorrectly.
1987 *
1988 IF( .NOT.OK )THEN
1989 WRITE( NOUT, FMT = 9992 )
1990 FATAL = .TRUE.
1991 GO TO 120
1992 END IF
1993 *
1994 * See what data changed inside subroutines.
1995 *
1996 ISAME( 1 ) = UPLO.EQ.UPLOS
1997 ISAME( 2 ) = NS.EQ.N
1998 ISAME( 3 ) = ALS.EQ.ALPHA
1999 ISAME( 4 ) = LDE( XS, XX, LX )
2000 ISAME( 5 ) = INCXS.EQ.INCX
2001 IF( NULL )THEN
2002 ISAME( 6 ) = LDE( AS, AA, LAA )
2003 ELSE
2004 ISAME( 6 ) = LDERES( SNAME( 8: 9 ), UPLO, N, N, AS,
2005 $ AA, LDA )
2006 END IF
2007 IF( .NOT.PACKED )THEN
2008 ISAME( 7 ) = LDAS.EQ.LDA
2009 END IF
2010 *
2011 * If data was incorrectly changed, report and return.
2012 *
2013 SAME = .TRUE.
2014 DO 30 I = 1, NARGS
2015 SAME = SAME.AND.ISAME( I )
2016 IF( .NOT.ISAME( I ) )
2017 $ WRITE( NOUT, FMT = 9998 )I
2018 30 CONTINUE
2019 IF( .NOT.SAME )THEN
2020 FATAL = .TRUE.
2021 GO TO 120
2022 END IF
2023 *
2024 IF( .NOT.NULL )THEN
2025 *
2026 * Check the result column by column.
2027 *
2028 IF( INCX.GT.0 )THEN
2029 DO 40 I = 1, N
2030 Z( I ) = X( I )
2031 40 CONTINUE
2032 ELSE
2033 DO 50 I = 1, N
2034 Z( I ) = X( N - I + 1 )
2035 50 CONTINUE
2036 END IF
2037 JA = 1
2038 DO 60 J = 1, N
2039 W( 1 ) = Z( J )
2040 IF( UPPER )THEN
2041 JJ = 1
2042 LJ = J
2043 ELSE
2044 JJ = J
2045 LJ = N - J + 1
2046 END IF
2047 CALL DMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W,
2048 $ 1, ONE, A( JJ, J ), 1, YT, G,
2049 $ AA( JA ), EPS, ERR, FATAL, NOUT,
2050 $ .TRUE. )
2051 IF( FULL )THEN
2052 IF( UPPER )THEN
2053 JA = JA + LDA
2054 ELSE
2055 JA = JA + LDA + 1
2056 END IF
2057 ELSE
2058 JA = JA + LJ
2059 END IF
2060 ERRMAX = MAX( ERRMAX, ERR )
2061 * If got really bad answer, report and return.
2062 IF( FATAL )
2063 $ GO TO 110
2064 60 CONTINUE
2065 ELSE
2066 * Avoid repeating tests if N.le.0.
2067 IF( N.LE.0 )
2068 $ GO TO 100
2069 END IF
2070 *
2071 70 CONTINUE
2072 *
2073 80 CONTINUE
2074 *
2075 90 CONTINUE
2076 *
2077 100 CONTINUE
2078 *
2079 * Report result.
2080 *
2081 IF( ERRMAX.LT.THRESH )THEN
2082 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
2083 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
2084 ELSE
2085 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
2086 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
2087 END IF
2088 GO TO 130
2089 *
2090 110 CONTINUE
2091 WRITE( NOUT, FMT = 9995 )J
2092 *
2093 120 CONTINUE
2094 WRITE( NOUT, FMT = 9996 )SNAME
2095 IF( FULL )THEN
2096 WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, INCX, LDA
2097 ELSE IF( PACKED )THEN
2098 WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, ALPHA, INCX
2099 END IF
2100 *
2101 130 CONTINUE
2102 RETURN
2103 *
2104 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2105 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2106 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
2107 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2108 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2109 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
2110 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2111 $ ' (', I6, ' CALL', 'S)' )
2112 10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
2113 $ ' (', I6, ' CALL', 'S)' )
2114 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
2115 $ 'ANGED INCORRECTLY *******' )
2116 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
2117 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
2118 $ ' - SUSPECT *******' )
2119 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' )
2120 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
2121 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,',
2122 $ I2, ', AP) .' )
2123 9993 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,',
2124 $ I2, ', A,', I3, ') .' )
2125 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2126 $ '******' )
2127 *
2128 * End of DCHK5.
2129 *
2130 END
2131 SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
2132 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
2133 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
2134 $ Z, IORDER )
2135 *
2136 * Tests DSYR2 and DSPR2.
2137 *
2138 * Auxiliary routine for test program for Level 2 Blas.
2139 *
2140 * -- Written on 10-August-1987.
2141 * Richard Hanson, Sandia National Labs.
2142 * Jeremy Du Croz, NAG Central Office.
2143 *
2144 * .. Parameters ..
2145 DOUBLE PRECISION ZERO, HALF, ONE
2146 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
2147 * .. Scalar Arguments ..
2148 DOUBLE PRECISION EPS, THRESH
2149 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA,
2150 $ IORDER
2151 LOGICAL FATAL, REWI, TRACE
2152 CHARACTER*12 SNAME
2153 * .. Array Arguments ..
2154 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
2155 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
2156 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
2157 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
2158 $ YY( NMAX*INCMAX ), Z( NMAX, 2 )
2159 INTEGER IDIM( NIDIM ), INC( NINC )
2160 * .. Local Scalars ..
2161 DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL
2162 INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX,
2163 $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N,
2164 $ NARGS, NC, NS
2165 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
2166 CHARACTER*1 UPLO, UPLOS
2167 CHARACTER*14 CUPLO
2168 CHARACTER*2 ICH
2169 * .. Local Arrays ..
2170 DOUBLE PRECISION W( 2 )
2171 LOGICAL ISAME( 13 )
2172 * .. External Functions ..
2173 LOGICAL LDE, LDERES
2174 EXTERNAL LDE, LDERES
2175 * .. External Subroutines ..
2176 EXTERNAL DMAKE, DMVCH, CDSPR2, CDSYR2
2177 * .. Intrinsic Functions ..
2178 INTRINSIC ABS, MAX
2179 * .. Scalars in Common ..
2180 INTEGER INFOT, NOUTC
2181 LOGICAL OK
2182 * .. Common blocks ..
2183 COMMON /INFOC/INFOT, NOUTC, OK
2184 * .. Data statements ..
2185 DATA ICH/'UL'/
2186 * .. Executable Statements ..
2187 FULL = SNAME( 9: 9 ).EQ.'y'
2188 PACKED = SNAME( 9: 9 ).EQ.'p'
2189 * Define the number of arguments.
2190 IF( FULL )THEN
2191 NARGS = 9
2192 ELSE IF( PACKED )THEN
2193 NARGS = 8
2194 END IF
2195 *
2196 NC = 0
2197 RESET = .TRUE.
2198 ERRMAX = ZERO
2199 *
2200 DO 140 IN = 1, NIDIM
2201 N = IDIM( IN )
2202 * Set LDA to 1 more than minimum value if room.
2203 LDA = N
2204 IF( LDA.LT.NMAX )
2205 $ LDA = LDA + 1
2206 * Skip tests if not enough room.
2207 IF( LDA.GT.NMAX )
2208 $ GO TO 140
2209 IF( PACKED )THEN
2210 LAA = ( N*( N + 1 ) )/2
2211 ELSE
2212 LAA = LDA*N
2213 END IF
2214 *
2215 DO 130 IC = 1, 2
2216 UPLO = ICH( IC: IC )
2217 IF (UPLO.EQ.'U')THEN
2218 CUPLO = ' CblasUpper'
2219 ELSE
2220 CUPLO = ' CblasLower'
2221 END IF
2222 UPPER = UPLO.EQ.'U'
2223 *
2224 DO 120 IX = 1, NINC
2225 INCX = INC( IX )
2226 LX = ABS( INCX )*N
2227 *
2228 * Generate the vector X.
2229 *
2230 TRANSL = HALF
2231 CALL DMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
2232 $ 0, N - 1, RESET, TRANSL )
2233 IF( N.GT.1 )THEN
2234 X( N/2 ) = ZERO
2235 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
2236 END IF
2237 *
2238 DO 110 IY = 1, NINC
2239 INCY = INC( IY )
2240 LY = ABS( INCY )*N
2241 *
2242 * Generate the vector Y.
2243 *
2244 TRANSL = ZERO
2245 CALL DMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY,
2246 $ ABS( INCY ), 0, N - 1, RESET, TRANSL )
2247 IF( N.GT.1 )THEN
2248 Y( N/2 ) = ZERO
2249 YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
2250 END IF
2251 *
2252 DO 100 IA = 1, NALF
2253 ALPHA = ALF( IA )
2254 NULL = N.LE.0.OR.ALPHA.EQ.ZERO
2255 *
2256 * Generate the matrix A.
2257 *
2258 TRANSL = ZERO
2259 CALL DMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A,
2260 $ NMAX, AA, LDA, N - 1, N - 1, RESET,
2261 $ TRANSL )
2262 *
2263 NC = NC + 1
2264 *
2265 * Save every datum before calling the subroutine.
2266 *
2267 UPLOS = UPLO
2268 NS = N
2269 ALS = ALPHA
2270 DO 10 I = 1, LAA
2271 AS( I ) = AA( I )
2272 10 CONTINUE
2273 LDAS = LDA
2274 DO 20 I = 1, LX
2275 XS( I ) = XX( I )
2276 20 CONTINUE
2277 INCXS = INCX
2278 DO 30 I = 1, LY
2279 YS( I ) = YY( I )
2280 30 CONTINUE
2281 INCYS = INCY
2282 *
2283 * Call the subroutine.
2284 *
2285 IF( FULL )THEN
2286 IF( TRACE )
2287 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, CUPLO, N,
2288 $ ALPHA, INCX, INCY, LDA
2289 IF( REWI )
2290 $ REWIND NTRA
2291 CALL CDSYR2( IORDER, UPLO, N, ALPHA, XX, INCX,
2292 $ YY, INCY, AA, LDA )
2293 ELSE IF( PACKED )THEN
2294 IF( TRACE )
2295 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, CUPLO, N,
2296 $ ALPHA, INCX, INCY
2297 IF( REWI )
2298 $ REWIND NTRA
2299 CALL CDSPR2( IORDER, UPLO, N, ALPHA, XX, INCX,
2300 $ YY, INCY, AA )
2301 END IF
2302 *
2303 * Check if error-exit was taken incorrectly.
2304 *
2305 IF( .NOT.OK )THEN
2306 WRITE( NOUT, FMT = 9992 )
2307 FATAL = .TRUE.
2308 GO TO 160
2309 END IF
2310 *
2311 * See what data changed inside subroutines.
2312 *
2313 ISAME( 1 ) = UPLO.EQ.UPLOS
2314 ISAME( 2 ) = NS.EQ.N
2315 ISAME( 3 ) = ALS.EQ.ALPHA
2316 ISAME( 4 ) = LDE( XS, XX, LX )
2317 ISAME( 5 ) = INCXS.EQ.INCX
2318 ISAME( 6 ) = LDE( YS, YY, LY )
2319 ISAME( 7 ) = INCYS.EQ.INCY
2320 IF( NULL )THEN
2321 ISAME( 8 ) = LDE( AS, AA, LAA )
2322 ELSE
2323 ISAME( 8 ) = LDERES( SNAME( 8: 9 ), UPLO, N, N,
2324 $ AS, AA, LDA )
2325 END IF
2326 IF( .NOT.PACKED )THEN
2327 ISAME( 9 ) = LDAS.EQ.LDA
2328 END IF
2329 *
2330 * If data was incorrectly changed, report and return.
2331 *
2332 SAME = .TRUE.
2333 DO 40 I = 1, NARGS
2334 SAME = SAME.AND.ISAME( I )
2335 IF( .NOT.ISAME( I ) )
2336 $ WRITE( NOUT, FMT = 9998 )I
2337 40 CONTINUE
2338 IF( .NOT.SAME )THEN
2339 FATAL = .TRUE.
2340 GO TO 160
2341 END IF
2342 *
2343 IF( .NOT.NULL )THEN
2344 *
2345 * Check the result column by column.
2346 *
2347 IF( INCX.GT.0 )THEN
2348 DO 50 I = 1, N
2349 Z( I, 1 ) = X( I )
2350 50 CONTINUE
2351 ELSE
2352 DO 60 I = 1, N
2353 Z( I, 1 ) = X( N - I + 1 )
2354 60 CONTINUE
2355 END IF
2356 IF( INCY.GT.0 )THEN
2357 DO 70 I = 1, N
2358 Z( I, 2 ) = Y( I )
2359 70 CONTINUE
2360 ELSE
2361 DO 80 I = 1, N
2362 Z( I, 2 ) = Y( N - I + 1 )
2363 80 CONTINUE
2364 END IF
2365 JA = 1
2366 DO 90 J = 1, N
2367 W( 1 ) = Z( J, 2 )
2368 W( 2 ) = Z( J, 1 )
2369 IF( UPPER )THEN
2370 JJ = 1
2371 LJ = J
2372 ELSE
2373 JJ = J
2374 LJ = N - J + 1
2375 END IF
2376 CALL DMVCH( 'N', LJ, 2, ALPHA, Z( JJ, 1 ),
2377 $ NMAX, W, 1, ONE, A( JJ, J ), 1,
2378 $ YT, G, AA( JA ), EPS, ERR, FATAL,
2379 $ NOUT, .TRUE. )
2380 IF( FULL )THEN
2381 IF( UPPER )THEN
2382 JA = JA + LDA
2383 ELSE
2384 JA = JA + LDA + 1
2385 END IF
2386 ELSE
2387 JA = JA + LJ
2388 END IF
2389 ERRMAX = MAX( ERRMAX, ERR )
2390 * If got really bad answer, report and return.
2391 IF( FATAL )
2392 $ GO TO 150
2393 90 CONTINUE
2394 ELSE
2395 * Avoid repeating tests with N.le.0.
2396 IF( N.LE.0 )
2397 $ GO TO 140
2398 END IF
2399 *
2400 100 CONTINUE
2401 *
2402 110 CONTINUE
2403 *
2404 120 CONTINUE
2405 *
2406 130 CONTINUE
2407 *
2408 140 CONTINUE
2409 *
2410 * Report result.
2411 *
2412 IF( ERRMAX.LT.THRESH )THEN
2413 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
2414 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
2415 ELSE
2416 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
2417 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
2418 END IF
2419 GO TO 170
2420 *
2421 150 CONTINUE
2422 WRITE( NOUT, FMT = 9995 )J
2423 *
2424 160 CONTINUE
2425 WRITE( NOUT, FMT = 9996 )SNAME
2426 IF( FULL )THEN
2427 WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, INCX,
2428 $ INCY, LDA
2429 ELSE IF( PACKED )THEN
2430 WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, ALPHA, INCX, INCY
2431 END IF
2432 *
2433 170 CONTINUE
2434 RETURN
2435 *
2436 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2437 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2438 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
2439 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2440 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2441 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
2442 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2443 $ ' (', I6, ' CALL', 'S)' )
2444 10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
2445 $ ' (', I6, ' CALL', 'S)' )
2446 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
2447 $ 'ANGED INCORRECTLY *******' )
2448 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
2449 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
2450 $ ' - SUSPECT *******' )
2451 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' )
2452 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
2453 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,',
2454 $ I2, ', Y,', I2, ', AP) .' )
2455 9993 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,',
2456 $ I2, ', Y,', I2, ', A,', I3, ') .' )
2457 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2458 $ '******' )
2459 *
2460 * End of DCHK6.
2461 *
2462 END
2463 SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL,
2464 $ KU, RESET, TRANSL )
2465 *
2466 * Generates values for an M by N matrix A within the bandwidth
2467 * defined by KL and KU.
2468 * Stores the values in the array AA in the data structure required
2469 * by the routine, with unwanted elements set to rogue value.
2470 *
2471 * TYPE is 'ge', 'gb', 'sy', 'sb', 'sp', 'tr', 'tb' OR 'tp'.
2472 *
2473 * Auxiliary routine for test program for Level 2 Blas.
2474 *
2475 * -- Written on 10-August-1987.
2476 * Richard Hanson, Sandia National Labs.
2477 * Jeremy Du Croz, NAG Central Office.
2478 *
2479 * .. Parameters ..
2480 DOUBLE PRECISION ZERO, ONE
2481 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
2482 DOUBLE PRECISION ROGUE
2483 PARAMETER ( ROGUE = -1.0D10 )
2484 * .. Scalar Arguments ..
2485 DOUBLE PRECISION TRANSL
2486 INTEGER KL, KU, LDA, M, N, NMAX
2487 LOGICAL RESET
2488 CHARACTER*1 DIAG, UPLO
2489 CHARACTER*2 TYPE
2490 * .. Array Arguments ..
2491 DOUBLE PRECISION A( NMAX, * ), AA( * )
2492 * .. Local Scalars ..
2493 INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, KK
2494 LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
2495 * .. External Functions ..
2496 DOUBLE PRECISION DBEG
2497 EXTERNAL DBEG
2498 * .. Intrinsic Functions ..
2499 INTRINSIC MAX, MIN
2500 * .. Executable Statements ..
2501 GEN = TYPE( 1: 1 ).EQ.'g'
2502 SYM = TYPE( 1: 1 ).EQ.'s'
2503 TRI = TYPE( 1: 1 ).EQ.'t'
2504 UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U'
2505 LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L'
2506 UNIT = TRI.AND.DIAG.EQ.'U'
2507 *
2508 * Generate data in array A.
2509 *
2510 DO 20 J = 1, N
2511 DO 10 I = 1, M
2512 IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
2513 $ THEN
2514 IF( ( I.LE.J.AND.J - I.LE.KU ).OR.
2515 $ ( I.GE.J.AND.I - J.LE.KL ) )THEN
2516 A( I, J ) = DBEG( RESET ) + TRANSL
2517 ELSE
2518 A( I, J ) = ZERO
2519 END IF
2520 IF( I.NE.J )THEN
2521 IF( SYM )THEN
2522 A( J, I ) = A( I, J )
2523 ELSE IF( TRI )THEN
2524 A( J, I ) = ZERO
2525 END IF
2526 END IF
2527 END IF
2528 10 CONTINUE
2529 IF( TRI )
2530 $ A( J, J ) = A( J, J ) + ONE
2531 IF( UNIT )
2532 $ A( J, J ) = ONE
2533 20 CONTINUE
2534 *
2535 * Store elements in array AS in data structure required by routine.
2536 *
2537 IF( TYPE.EQ.'ge' )THEN
2538 DO 50 J = 1, N
2539 DO 30 I = 1, M
2540 AA( I + ( J - 1 )*LDA ) = A( I, J )
2541 30 CONTINUE
2542 DO 40 I = M + 1, LDA
2543 AA( I + ( J - 1 )*LDA ) = ROGUE
2544 40 CONTINUE
2545 50 CONTINUE
2546 ELSE IF( TYPE.EQ.'gb' )THEN
2547 DO 90 J = 1, N
2548 DO 60 I1 = 1, KU + 1 - J
2549 AA( I1 + ( J - 1 )*LDA ) = ROGUE
2550 60 CONTINUE
2551 DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J )
2552 AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J )
2553 70 CONTINUE
2554 DO 80 I3 = I2, LDA
2555 AA( I3 + ( J - 1 )*LDA ) = ROGUE
2556 80 CONTINUE
2557 90 CONTINUE
2558 ELSE IF( TYPE.EQ.'sy'.OR.TYPE.EQ.'tr' )THEN
2559 DO 130 J = 1, N
2560 IF( UPPER )THEN
2561 IBEG = 1
2562 IF( UNIT )THEN
2563 IEND = J - 1
2564 ELSE
2565 IEND = J
2566 END IF
2567 ELSE
2568 IF( UNIT )THEN
2569 IBEG = J + 1
2570 ELSE
2571 IBEG = J
2572 END IF
2573 IEND = N
2574 END IF
2575 DO 100 I = 1, IBEG - 1
2576 AA( I + ( J - 1 )*LDA ) = ROGUE
2577 100 CONTINUE
2578 DO 110 I = IBEG, IEND
2579 AA( I + ( J - 1 )*LDA ) = A( I, J )
2580 110 CONTINUE
2581 DO 120 I = IEND + 1, LDA
2582 AA( I + ( J - 1 )*LDA ) = ROGUE
2583 120 CONTINUE
2584 130 CONTINUE
2585 ELSE IF( TYPE.EQ.'sb'.OR.TYPE.EQ.'tb' )THEN
2586 DO 170 J = 1, N
2587 IF( UPPER )THEN
2588 KK = KL + 1
2589 IBEG = MAX( 1, KL + 2 - J )
2590 IF( UNIT )THEN
2591 IEND = KL
2592 ELSE
2593 IEND = KL + 1
2594 END IF
2595 ELSE
2596 KK = 1
2597 IF( UNIT )THEN
2598 IBEG = 2
2599 ELSE
2600 IBEG = 1
2601 END IF
2602 IEND = MIN( KL + 1, 1 + M - J )
2603 END IF
2604 DO 140 I = 1, IBEG - 1
2605 AA( I + ( J - 1 )*LDA ) = ROGUE
2606 140 CONTINUE
2607 DO 150 I = IBEG, IEND
2608 AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J )
2609 150 CONTINUE
2610 DO 160 I = IEND + 1, LDA
2611 AA( I + ( J - 1 )*LDA ) = ROGUE
2612 160 CONTINUE
2613 170 CONTINUE
2614 ELSE IF( TYPE.EQ.'sp'.OR.TYPE.EQ.'tp' )THEN
2615 IOFF = 0
2616 DO 190 J = 1, N
2617 IF( UPPER )THEN
2618 IBEG = 1
2619 IEND = J
2620 ELSE
2621 IBEG = J
2622 IEND = N
2623 END IF
2624 DO 180 I = IBEG, IEND
2625 IOFF = IOFF + 1
2626 AA( IOFF ) = A( I, J )
2627 IF( I.EQ.J )THEN
2628 IF( UNIT )
2629 $ AA( IOFF ) = ROGUE
2630 END IF
2631 180 CONTINUE
2632 190 CONTINUE
2633 END IF
2634 RETURN
2635 *
2636 * End of DMAKE.
2637 *
2638 END
2639 SUBROUTINE DMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y,
2640 $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV )
2641 *
2642 * Checks the results of the computational tests.
2643 *
2644 * Auxiliary routine for test program for Level 2 Blas.
2645 *
2646 * -- Written on 10-August-1987.
2647 * Richard Hanson, Sandia National Labs.
2648 * Jeremy Du Croz, NAG Central Office.
2649 *
2650 * .. Parameters ..
2651 DOUBLE PRECISION ZERO, ONE
2652 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
2653 * .. Scalar Arguments ..
2654 DOUBLE PRECISION ALPHA, BETA, EPS, ERR
2655 INTEGER INCX, INCY, M, N, NMAX, NOUT
2656 LOGICAL FATAL, MV
2657 CHARACTER*1 TRANS
2658 * .. Array Arguments ..
2659 DOUBLE PRECISION A( NMAX, * ), G( * ), X( * ), Y( * ), YT( * ),
2660 $ YY( * )
2661 * .. Local Scalars ..
2662 DOUBLE PRECISION ERRI
2663 INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL
2664 LOGICAL TRAN
2665 * .. Intrinsic Functions ..
2666 INTRINSIC ABS, MAX, SQRT
2667 * .. Executable Statements ..
2668 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
2669 IF( TRAN )THEN
2670 ML = N
2671 NL = M
2672 ELSE
2673 ML = M
2674 NL = N
2675 END IF
2676 IF( INCX.LT.0 )THEN
2677 KX = NL
2678 INCXL = -1
2679 ELSE
2680 KX = 1
2681 INCXL = 1
2682 END IF
2683 IF( INCY.LT.0 )THEN
2684 KY = ML
2685 INCYL = -1
2686 ELSE
2687 KY = 1
2688 INCYL = 1
2689 END IF
2690 *
2691 * Compute expected result in YT using data in A, X and Y.
2692 * Compute gauges in G.
2693 *
2694 IY = KY
2695 DO 30 I = 1, ML
2696 YT( IY ) = ZERO
2697 G( IY ) = ZERO
2698 JX = KX
2699 IF( TRAN )THEN
2700 DO 10 J = 1, NL
2701 YT( IY ) = YT( IY ) + A( J, I )*X( JX )
2702 G( IY ) = G( IY ) + ABS( A( J, I )*X( JX ) )
2703 JX = JX + INCXL
2704 10 CONTINUE
2705 ELSE
2706 DO 20 J = 1, NL
2707 YT( IY ) = YT( IY ) + A( I, J )*X( JX )
2708 G( IY ) = G( IY ) + ABS( A( I, J )*X( JX ) )
2709 JX = JX + INCXL
2710 20 CONTINUE
2711 END IF
2712 YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY )
2713 G( IY ) = ABS( ALPHA )*G( IY ) + ABS( BETA*Y( IY ) )
2714 IY = IY + INCYL
2715 30 CONTINUE
2716 *
2717 * Compute the error ratio for this result.
2718 *
2719 ERR = ZERO
2720 DO 40 I = 1, ML
2721 ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS
2722 IF( G( I ).NE.ZERO )
2723 $ ERRI = ERRI/G( I )
2724 ERR = MAX( ERR, ERRI )
2725 IF( ERR*SQRT( EPS ).GE.ONE )
2726 $ GO TO 50
2727 40 CONTINUE
2728 * If the loop completes, all results are at least half accurate.
2729 GO TO 70
2730 *
2731 * Report fatal error.
2732 *
2733 50 FATAL = .TRUE.
2734 WRITE( NOUT, FMT = 9999 )
2735 DO 60 I = 1, ML
2736 IF( MV )THEN
2737 WRITE( NOUT, FMT = 9998 )I, YT( I ),
2738 $ YY( 1 + ( I - 1 )*ABS( INCY ) )
2739 ELSE
2740 WRITE( NOUT, FMT = 9998 )I,
2741 $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT(I)
2742 END IF
2743 60 CONTINUE
2744 *
2745 70 CONTINUE
2746 RETURN
2747 *
2748 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2749 $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
2750 $ 'TED RESULT' )
2751 9998 FORMAT( 1X, I7, 2G18.6 )
2752 *
2753 * End of DMVCH.
2754 *
2755 END
2756 LOGICAL FUNCTION LDE( RI, RJ, LR )
2757 *
2758 * Tests if two arrays are identical.
2759 *
2760 * Auxiliary routine for test program for Level 2 Blas.
2761 *
2762 * -- Written on 10-August-1987.
2763 * Richard Hanson, Sandia National Labs.
2764 * Jeremy Du Croz, NAG Central Office.
2765 *
2766 * .. Scalar Arguments ..
2767 INTEGER LR
2768 * .. Array Arguments ..
2769 DOUBLE PRECISION RI( * ), RJ( * )
2770 * .. Local Scalars ..
2771 INTEGER I
2772 * .. Executable Statements ..
2773 DO 10 I = 1, LR
2774 IF( RI( I ).NE.RJ( I ) )
2775 $ GO TO 20
2776 10 CONTINUE
2777 LDE = .TRUE.
2778 GO TO 30
2779 20 CONTINUE
2780 LDE = .FALSE.
2781 30 RETURN
2782 *
2783 * End of LDE.
2784 *
2785 END
2786 LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA )
2787 *
2788 * Tests if selected elements in two arrays are equal.
2789 *
2790 * TYPE is 'ge', 'sy' or 'sp'.
2791 *
2792 * Auxiliary routine for test program for Level 2 Blas.
2793 *
2794 * -- Written on 10-August-1987.
2795 * Richard Hanson, Sandia National Labs.
2796 * Jeremy Du Croz, NAG Central Office.
2797 *
2798 * .. Scalar Arguments ..
2799 INTEGER LDA, M, N
2800 CHARACTER*1 UPLO
2801 CHARACTER*2 TYPE
2802 * .. Array Arguments ..
2803 DOUBLE PRECISION AA( LDA, * ), AS( LDA, * )
2804 * .. Local Scalars ..
2805 INTEGER I, IBEG, IEND, J
2806 LOGICAL UPPER
2807 * .. Executable Statements ..
2808 UPPER = UPLO.EQ.'U'
2809 IF( TYPE.EQ.'ge' )THEN
2810 DO 20 J = 1, N
2811 DO 10 I = M + 1, LDA
2812 IF( AA( I, J ).NE.AS( I, J ) )
2813 $ GO TO 70
2814 10 CONTINUE
2815 20 CONTINUE
2816 ELSE IF( TYPE.EQ.'sy' )THEN
2817 DO 50 J = 1, N
2818 IF( UPPER )THEN
2819 IBEG = 1
2820 IEND = J
2821 ELSE
2822 IBEG = J
2823 IEND = N
2824 END IF
2825 DO 30 I = 1, IBEG - 1
2826 IF( AA( I, J ).NE.AS( I, J ) )
2827 $ GO TO 70
2828 30 CONTINUE
2829 DO 40 I = IEND + 1, LDA
2830 IF( AA( I, J ).NE.AS( I, J ) )
2831 $ GO TO 70
2832 40 CONTINUE
2833 50 CONTINUE
2834 END IF
2835 *
2836 60 CONTINUE
2837 LDERES = .TRUE.
2838 GO TO 80
2839 70 CONTINUE
2840 LDERES = .FALSE.
2841 80 RETURN
2842 *
2843 * End of LDERES.
2844 *
2845 END
2846 DOUBLE PRECISION FUNCTION DBEG( RESET )
2847 *
2848 * Generates random numbers uniformly distributed between -0.5 and 0.5.
2849 *
2850 * Auxiliary routine for test program for Level 2 Blas.
2851 *
2852 * -- Written on 10-August-1987.
2853 * Richard Hanson, Sandia National Labs.
2854 * Jeremy Du Croz, NAG Central Office.
2855 *
2856 * .. Scalar Arguments ..
2857 LOGICAL RESET
2858 * .. Local Scalars ..
2859 INTEGER I, IC, MI
2860 * .. Save statement ..
2861 SAVE I, IC, MI
2862 * .. Intrinsic Functions ..
2863 INTRINSIC DBLE
2864 * .. Executable Statements ..
2865 IF( RESET )THEN
2866 * Initialize local variables.
2867 MI = 891
2868 I = 7
2869 IC = 0
2870 RESET = .FALSE.
2871 END IF
2872 *
2873 * The sequence of values of I is bounded between 1 and 999.
2874 * If initial I = 1,2,3,6,7 or 9, the period will be 50.
2875 * If initial I = 4 or 8, the period will be 25.
2876 * If initial I = 5, the period will be 10.
2877 * IC is used to break up the period by skipping 1 value of I in 6.
2878 *
2879 IC = IC + 1
2880 10 I = I*MI
2881 I = I - 1000*( I/1000 )
2882 IF( IC.GE.5 )THEN
2883 IC = 0
2884 GO TO 10
2885 END IF
2886 DBEG = DBLE( I - 500 )/1001.0D0
2887 RETURN
2888 *
2889 * End of DBEG.
2890 *
2891 END
2892 DOUBLE PRECISION FUNCTION DDIFF( X, Y )
2893 *
2894 * Auxiliary routine for test program for Level 2 Blas.
2895 *
2896 * -- Written on 10-August-1987.
2897 * Richard Hanson, Sandia National Labs.
2898 *
2899 * .. Scalar Arguments ..
2900 DOUBLE PRECISION X, Y
2901 * .. Executable Statements ..
2902 DDIFF = X - Y
2903 RETURN
2904 *
2905 * End of DDIFF.
2906 *
2907 END
2 *
3 * Test program for the DOUBLE PRECISION Level 2 Blas.
4 *
5 * The program must be driven by a short data file. The first 17 records
6 * of the file are read using list-directed input, the last 16 records
7 * are read using the format ( A12, L2 ). An annotated example of a data
8 * file can be obtained by deleting the first 3 characters from the
9 * following 33 lines:
10 * 'DBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE
11 * -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
12 * F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
13 * F LOGICAL FLAG, T TO STOP ON FAILURES.
14 * T LOGICAL FLAG, T TO TEST ERROR EXITS.
15 * 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH
16 * 16.0 THRESHOLD VALUE OF TEST RATIO
17 * 6 NUMBER OF VALUES OF N
18 * 0 1 2 3 5 9 VALUES OF N
19 * 4 NUMBER OF VALUES OF K
20 * 0 1 2 4 VALUES OF K
21 * 4 NUMBER OF VALUES OF INCX AND INCY
22 * 1 2 -1 -2 VALUES OF INCX AND INCY
23 * 3 NUMBER OF VALUES OF ALPHA
24 * 0.0 1.0 0.7 VALUES OF ALPHA
25 * 3 NUMBER OF VALUES OF BETA
26 * 0.0 1.0 0.9 VALUES OF BETA
27 * cblas_dgemv T PUT F FOR NO TEST. SAME COLUMNS.
28 * cblas_dgbmv T PUT F FOR NO TEST. SAME COLUMNS.
29 * cblas_dsymv T PUT F FOR NO TEST. SAME COLUMNS.
30 * cblas_dsbmv T PUT F FOR NO TEST. SAME COLUMNS.
31 * cblas_dspmv T PUT F FOR NO TEST. SAME COLUMNS.
32 * cblas_dtrmv T PUT F FOR NO TEST. SAME COLUMNS.
33 * cblas_dtbmv T PUT F FOR NO TEST. SAME COLUMNS.
34 * cblas_dtpmv T PUT F FOR NO TEST. SAME COLUMNS.
35 * cblas_dtrsv T PUT F FOR NO TEST. SAME COLUMNS.
36 * cblas_dtbsv T PUT F FOR NO TEST. SAME COLUMNS.
37 * cblas_dtpsv T PUT F FOR NO TEST. SAME COLUMNS.
38 * cblas_dger T PUT F FOR NO TEST. SAME COLUMNS.
39 * cblas_dsyr T PUT F FOR NO TEST. SAME COLUMNS.
40 * cblas_dspr T PUT F FOR NO TEST. SAME COLUMNS.
41 * cblas_dsyr2 T PUT F FOR NO TEST. SAME COLUMNS.
42 * cblas_dspr2 T PUT F FOR NO TEST. SAME COLUMNS.
43 *
44 * See:
45 *
46 * Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J..
47 * An extended set of Fortran Basic Linear Algebra Subprograms.
48 *
49 * Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics
50 * and Computer Science Division, Argonne National Laboratory,
51 * 9700 South Cass Avenue, Argonne, Illinois 60439, US.
52 *
53 * Or
54 *
55 * NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms
56 * Group Ltd., NAG Central Office, 256 Banbury Road, Oxford
57 * OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st
58 * Street, Suite 100, Downers Grove, Illinois 60515-1263, USA.
59 *
60 *
61 * -- Written on 10-August-1987.
62 * Richard Hanson, Sandia National Labs.
63 * Jeremy Du Croz, NAG Central Office.
64 *
65 * .. Parameters ..
66 INTEGER NIN, NOUT
67 PARAMETER ( NIN = 5, NOUT = 6 )
68 INTEGER NSUBS
69 PARAMETER ( NSUBS = 16 )
70 DOUBLE PRECISION ZERO, HALF, ONE
71 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
72 INTEGER NMAX, INCMAX
73 PARAMETER ( NMAX = 65, INCMAX = 2 )
74 INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX
75 PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7,
76 $ NALMAX = 7, NBEMAX = 7 )
77 * .. Local Scalars ..
78 DOUBLE PRECISION EPS, ERR, THRESH
79 INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB,
80 $ NTRA, LAYOUT
81 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
82 $ TSTERR, CORDER, RORDER
83 CHARACTER*1 TRANS
84 CHARACTER*12 SNAMET
85 CHARACTER*32 SNAPS
86 * .. Local Arrays ..
87 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ),
88 $ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ),
89 $ G( NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
90 $ XX( NMAX*INCMAX ), Y( NMAX ),
91 $ YS( NMAX*INCMAX ), YT( NMAX ),
92 $ YY( NMAX*INCMAX ), Z( 2*NMAX )
93 INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX )
94 LOGICAL LTEST( NSUBS )
95 CHARACTER*12 SNAMES( NSUBS )
96 * .. External Functions ..
97 DOUBLE PRECISION DDIFF
98 LOGICAL LDE
99 EXTERNAL DDIFF, LDE
100 * .. External Subroutines ..
101 EXTERNAL DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, DCHK6,
102 $ CD2CHKE, DMVCH
103 * .. Intrinsic Functions ..
104 INTRINSIC ABS, MAX, MIN
105 * .. Scalars in Common ..
106 INTEGER INFOT, NOUTC
107 LOGICAL OK
108 CHARACTER*12 SRNAMT
109 * .. Common blocks ..
110 COMMON /INFOC/INFOT, NOUTC, OK
111 COMMON /SRNAMC/SRNAMT
112 * .. Data statements ..
113 DATA SNAMES/'cblas_dgemv ', 'cblas_dgbmv ',
114 $ 'cblas_dsymv ','cblas_dsbmv ','cblas_dspmv ',
115 $ 'cblas_dtrmv ','cblas_dtbmv ','cblas_dtpmv ',
116 $ 'cblas_dtrsv ','cblas_dtbsv ','cblas_dtpsv ',
117 $ 'cblas_dger ','cblas_dsyr ','cblas_dspr ',
118 $ 'cblas_dsyr2 ','cblas_dspr2 '/
119 * .. Executable Statements ..
120 *
121 NOUTC = NOUT
122 *
123 * Read name and unit number for snapshot output file and open file.
124 *
125 READ( NIN, FMT = * )SNAPS
126 READ( NIN, FMT = * )NTRA
127 TRACE = NTRA.GE.0
128 IF( TRACE )THEN
129 OPEN( NTRA, FILE = SNAPS )
130 END IF
131 * Read the flag that directs rewinding of the snapshot file.
132 READ( NIN, FMT = * )REWI
133 REWI = REWI.AND.TRACE
134 * Read the flag that directs stopping on any failure.
135 READ( NIN, FMT = * )SFATAL
136 * Read the flag that indicates whether error exits are to be tested.
137 READ( NIN, FMT = * )TSTERR
138 * Read the flag that indicates whether row-major data layout to be tested.
139 READ( NIN, FMT = * )LAYOUT
140 * Read the threshold value of the test ratio
141 READ( NIN, FMT = * )THRESH
142 *
143 * Read and check the parameter values for the tests.
144 *
145 * Values of N
146 READ( NIN, FMT = * )NIDIM
147 IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
148 WRITE( NOUT, FMT = 9997 )'N', NIDMAX
149 GO TO 230
150 END IF
151 READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
152 DO 10 I = 1, NIDIM
153 IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
154 WRITE( NOUT, FMT = 9996 )NMAX
155 GO TO 230
156 END IF
157 10 CONTINUE
158 * Values of K
159 READ( NIN, FMT = * )NKB
160 IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN
161 WRITE( NOUT, FMT = 9997 )'K', NKBMAX
162 GO TO 230
163 END IF
164 READ( NIN, FMT = * )( KB( I ), I = 1, NKB )
165 DO 20 I = 1, NKB
166 IF( KB( I ).LT.0 )THEN
167 WRITE( NOUT, FMT = 9995 )
168 GO TO 230
169 END IF
170 20 CONTINUE
171 * Values of INCX and INCY
172 READ( NIN, FMT = * )NINC
173 IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN
174 WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX
175 GO TO 230
176 END IF
177 READ( NIN, FMT = * )( INC( I ), I = 1, NINC )
178 DO 30 I = 1, NINC
179 IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN
180 WRITE( NOUT, FMT = 9994 )INCMAX
181 GO TO 230
182 END IF
183 30 CONTINUE
184 * Values of ALPHA
185 READ( NIN, FMT = * )NALF
186 IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
187 WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
188 GO TO 230
189 END IF
190 READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
191 * Values of BETA
192 READ( NIN, FMT = * )NBET
193 IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
194 WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
195 GO TO 230
196 END IF
197 READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
198 *
199 * Report values of parameters.
200 *
201 WRITE( NOUT, FMT = 9993 )
202 WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM )
203 WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB )
204 WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC )
205 WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF )
206 WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET )
207 IF( .NOT.TSTERR )THEN
208 WRITE( NOUT, FMT = * )
209 WRITE( NOUT, FMT = 9980 )
210 END IF
211 WRITE( NOUT, FMT = * )
212 WRITE( NOUT, FMT = 9999 )THRESH
213 WRITE( NOUT, FMT = * )
214
215 RORDER = .FALSE.
216 CORDER = .FALSE.
217 IF (LAYOUT.EQ.2) THEN
218 RORDER = .TRUE.
219 CORDER = .TRUE.
220 WRITE( *, FMT = 10002 )
221 ELSE IF (LAYOUT.EQ.1) THEN
222 RORDER = .TRUE.
223 WRITE( *, FMT = 10001 )
224 ELSE IF (LAYOUT.EQ.0) THEN
225 CORDER = .TRUE.
226 WRITE( *, FMT = 10000 )
227 END IF
228 WRITE( *, FMT = * )
229 *
230 * Read names of subroutines and flags which indicate
231 * whether they are to be tested.
232 *
233 DO 40 I = 1, NSUBS
234 LTEST( I ) = .FALSE.
235 40 CONTINUE
236 50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT
237 DO 60 I = 1, NSUBS
238 IF( SNAMET.EQ.SNAMES( I ) )
239 $ GO TO 70
240 60 CONTINUE
241 WRITE( NOUT, FMT = 9986 )SNAMET
242 STOP
243 70 LTEST( I ) = LTESTT
244 GO TO 50
245 *
246 80 CONTINUE
247 CLOSE ( NIN )
248 *
249 * Compute EPS (the machine precision).
250 *
251 EPS = ONE
252 90 CONTINUE
253 IF( DDIFF( ONE + EPS, ONE ).EQ.ZERO )
254 $ GO TO 100
255 EPS = HALF*EPS
256 GO TO 90
257 100 CONTINUE
258 EPS = EPS + EPS
259 WRITE( NOUT, FMT = 9998 )EPS
260 *
261 * Check the reliability of DMVCH using exact data.
262 *
263 N = MIN( 32, NMAX )
264 DO 120 J = 1, N
265 DO 110 I = 1, N
266 A( I, J ) = MAX( I - J + 1, 0 )
267 110 CONTINUE
268 X( J ) = J
269 Y( J ) = ZERO
270 120 CONTINUE
271 DO 130 J = 1, N
272 YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
273 130 CONTINUE
274 * YY holds the exact result. On exit from DMVCH YT holds
275 * the result computed by DMVCH.
276 TRANS = 'N'
277 CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G,
278 $ YY, EPS, ERR, FATAL, NOUT, .TRUE. )
279 SAME = LDE( YY, YT, N )
280 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
281 WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
282 STOP
283 END IF
284 TRANS = 'T'
285 CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G,
286 $ YY, EPS, ERR, FATAL, NOUT, .TRUE. )
287 SAME = LDE( YY, YT, N )
288 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
289 WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
290 STOP
291 END IF
292 *
293 * Test each subroutine in turn.
294 *
295 DO 210 ISNUM = 1, NSUBS
296 WRITE( NOUT, FMT = * )
297 IF( .NOT.LTEST( ISNUM ) )THEN
298 * Subprogram is not to be tested.
299 WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM )
300 ELSE
301 SRNAMT = SNAMES( ISNUM )
302 * Test error exits.
303 IF( TSTERR )THEN
304 CALL CD2CHKE( SNAMES( ISNUM ) )
305 WRITE( NOUT, FMT = * )
306 END IF
307 * Test computations.
308 INFOT = 0
309 OK = .TRUE.
310 FATAL = .FALSE.
311 GO TO ( 140, 140, 150, 150, 150, 160, 160,
312 $ 160, 160, 160, 160, 170, 180, 180,
313 $ 190, 190 )ISNUM
314 * Test DGEMV, 01, and DGBMV, 02.
315 140 IF (CORDER) THEN
316 CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
317 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
318 $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
319 $ X, XX, XS, Y, YY, YS, YT, G, 0 )
320 END IF
321 IF (RORDER) THEN
322 CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
323 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
324 $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
325 $ X, XX, XS, Y, YY, YS, YT, G, 1 )
326 END IF
327 GO TO 200
328 * Test DSYMV, 03, DSBMV, 04, and DSPMV, 05.
329 150 IF (CORDER) THEN
330 CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
331 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
332 $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
333 $ X, XX, XS, Y, YY, YS, YT, G, 0 )
334 END IF
335 IF (RORDER) THEN
336 CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
337 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
338 $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
339 $ X, XX, XS, Y, YY, YS, YT, G, 1 )
340 END IF
341 GO TO 200
342 * Test DTRMV, 06, DTBMV, 07, DTPMV, 08,
343 * DTRSV, 09, DTBSV, 10, and DTPSV, 11.
344 160 IF (CORDER) THEN
345 CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
346 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC,
347 $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z,
348 $ 0 )
349 END IF
350 IF (RORDER) THEN
351 CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
352 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC,
353 $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z,
354 $ 1 )
355 END IF
356 GO TO 200
357 * Test DGER, 12.
358 170 IF (CORDER) THEN
359 CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
360 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
361 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
362 $ YT, G, Z, 0 )
363 END IF
364 IF (RORDER) THEN
365 CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
366 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
367 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
368 $ YT, G, Z, 1 )
369 END IF
370 GO TO 200
371 * Test DSYR, 13, and DSPR, 14.
372 180 IF (CORDER) THEN
373 CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
374 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
375 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
376 $ YT, G, Z, 0 )
377 END IF
378 IF (RORDER) THEN
379 CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
380 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
381 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
382 $ YT, G, Z, 1 )
383 END IF
384 GO TO 200
385 * Test DSYR2, 15, and DSPR2, 16.
386 190 IF (CORDER) THEN
387 CALL DCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
388 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
389 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
390 $ YT, G, Z, 0 )
391 END IF
392 IF (RORDER) THEN
393 CALL DCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
394 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
395 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
396 $ YT, G, Z, 1 )
397 END IF
398 *
399 200 IF( FATAL.AND.SFATAL )
400 $ GO TO 220
401 END IF
402 210 CONTINUE
403 WRITE( NOUT, FMT = 9982 )
404 GO TO 240
405 *
406 220 CONTINUE
407 WRITE( NOUT, FMT = 9981 )
408 GO TO 240
409 *
410 230 CONTINUE
411 WRITE( NOUT, FMT = 9987 )
412 *
413 240 CONTINUE
414 IF( TRACE )
415 $ CLOSE ( NTRA )
416 CLOSE ( NOUT )
417 STOP
418 *
419 10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' )
420 10001 FORMAT( ' ROW-MAJOR DATA LAYOUT IS TESTED' )
421 10000 FORMAT( ' COLUMN-MAJOR DATA LAYOUT IS TESTED' )
422 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
423 $ 'S THAN', F8.2 )
424 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 )
425 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
426 $ 'THAN ', I2 )
427 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
428 9995 FORMAT( ' VALUE OF K IS LESS THAN 0' )
429 9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ',
430 $ I2 )
431 9993 FORMAT( ' TESTS OF THE DOUBLE PRECISION LEVEL 2 BLAS', //' THE F',
432 $ 'OLLOWING PARAMETER VALUES WILL BE USED:' )
433 9992 FORMAT( ' FOR N ', 9I6 )
434 9991 FORMAT( ' FOR K ', 7I6 )
435 9990 FORMAT( ' FOR INCX AND INCY ', 7I6 )
436 9989 FORMAT( ' FOR ALPHA ', 7F6.1 )
437 9988 FORMAT( ' FOR BETA ', 7F6.1 )
438 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
439 $ /' ******* TESTS ABANDONED *******' )
440 9986 FORMAT( ' SUBPROGRAM NAME ',A12, ' NOT RECOGNIZED', /' ******* T',
441 $ 'ESTS ABANDONED *******' )
442 9985 FORMAT( ' ERROR IN DMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
443 $ 'ATED WRONGLY.', /' DMVCH WAS CALLED WITH TRANS = ', A1,
444 $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', /
445 $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.'
446 $ , /' ******* TESTS ABANDONED *******' )
447 9984 FORMAT(A12, L2 )
448 9983 FORMAT( 1X,A12, ' WAS NOT TESTED' )
449 9982 FORMAT( /' END OF TESTS' )
450 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
451 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
452 *
453 * End of DBLAT2.
454 *
455 END
456 SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
457 $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
458 $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
459 $ XS, Y, YY, YS, YT, G, IORDER )
460 *
461 * Tests DGEMV and DGBMV.
462 *
463 * Auxiliary routine for test program for Level 2 Blas.
464 *
465 * -- Written on 10-August-1987.
466 * Richard Hanson, Sandia National Labs.
467 * Jeremy Du Croz, NAG Central Office.
468 *
469 * .. Parameters ..
470 DOUBLE PRECISION ZERO, HALF
471 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0 )
472 * .. Scalar Arguments ..
473 DOUBLE PRECISION EPS, THRESH
474 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
475 $ NOUT, NTRA, IORDER
476 LOGICAL FATAL, REWI, TRACE
477 CHARACTER*12 SNAME
478 * .. Array Arguments ..
479 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
480 $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ),
481 $ X( NMAX ), XS( NMAX*INCMAX ),
482 $ XX( NMAX*INCMAX ), Y( NMAX ),
483 $ YS( NMAX*INCMAX ), YT( NMAX ),
484 $ YY( NMAX*INCMAX )
485 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
486 * .. Local Scalars ..
487 DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL
488 INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY,
489 $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA,
490 $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK,
491 $ NL, NS
492 LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN
493 CHARACTER*1 TRANS, TRANSS
494 CHARACTER*14 CTRANS
495 CHARACTER*3 ICH
496 * .. Local Arrays ..
497 LOGICAL ISAME( 13 )
498 * .. External Functions ..
499 LOGICAL LDE, LDERES
500 EXTERNAL LDE, LDERES
501 * .. External Subroutines ..
502 EXTERNAL CDGBMV, CDGEMV, DMAKE, DMVCH
503 * .. Intrinsic Functions ..
504 INTRINSIC ABS, MAX, MIN
505 * .. Scalars in Common ..
506 INTEGER INFOT, NOUTC
507 LOGICAL OK
508 * .. Common blocks ..
509 COMMON /INFOC/INFOT, NOUTC, OK
510 * .. Data statements ..
511 DATA ICH/'NTC'/
512 * .. Executable Statements ..
513 FULL = SNAME( 9: 9 ).EQ.'e'
514 BANDED = SNAME( 9: 9 ).EQ.'b'
515 * Define the number of arguments.
516 IF( FULL )THEN
517 NARGS = 11
518 ELSE IF( BANDED )THEN
519 NARGS = 13
520 END IF
521 *
522 NC = 0
523 RESET = .TRUE.
524 ERRMAX = ZERO
525 *
526 DO 120 IN = 1, NIDIM
527 N = IDIM( IN )
528 ND = N/2 + 1
529 *
530 DO 110 IM = 1, 2
531 IF( IM.EQ.1 )
532 $ M = MAX( N - ND, 0 )
533 IF( IM.EQ.2 )
534 $ M = MIN( N + ND, NMAX )
535 *
536 IF( BANDED )THEN
537 NK = NKB
538 ELSE
539 NK = 1
540 END IF
541 DO 100 IKU = 1, NK
542 IF( BANDED )THEN
543 KU = KB( IKU )
544 KL = MAX( KU - 1, 0 )
545 ELSE
546 KU = N - 1
547 KL = M - 1
548 END IF
549 * Set LDA to 1 more than minimum value if room.
550 IF( BANDED )THEN
551 LDA = KL + KU + 1
552 ELSE
553 LDA = M
554 END IF
555 IF( LDA.LT.NMAX )
556 $ LDA = LDA + 1
557 * Skip tests if not enough room.
558 IF( LDA.GT.NMAX )
559 $ GO TO 100
560 LAA = LDA*N
561 NULL = N.LE.0.OR.M.LE.0
562 *
563 * Generate the matrix A.
564 *
565 TRANSL = ZERO
566 CALL DMAKE( SNAME( 8: 9 ), ' ', ' ', M, N, A, NMAX, AA,
567 $ LDA, KL, KU, RESET, TRANSL )
568 *
569 DO 90 IC = 1, 3
570 TRANS = ICH( IC: IC )
571 IF (TRANS.EQ.'N')THEN
572 CTRANS = ' CblasNoTrans'
573 ELSE IF (TRANS.EQ.'T')THEN
574 CTRANS = ' CblasTrans'
575 ELSE
576 CTRANS = 'CblasConjTrans'
577 END IF
578 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
579 *
580 IF( TRAN )THEN
581 ML = N
582 NL = M
583 ELSE
584 ML = M
585 NL = N
586 END IF
587 *
588 DO 80 IX = 1, NINC
589 INCX = INC( IX )
590 LX = ABS( INCX )*NL
591 *
592 * Generate the vector X.
593 *
594 TRANSL = HALF
595 CALL DMAKE( 'ge', ' ', ' ', 1, NL, X, 1, XX,
596 $ ABS( INCX ), 0, NL - 1, RESET, TRANSL )
597 IF( NL.GT.1 )THEN
598 X( NL/2 ) = ZERO
599 XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO
600 END IF
601 *
602 DO 70 IY = 1, NINC
603 INCY = INC( IY )
604 LY = ABS( INCY )*ML
605 *
606 DO 60 IA = 1, NALF
607 ALPHA = ALF( IA )
608 *
609 DO 50 IB = 1, NBET
610 BETA = BET( IB )
611 *
612 * Generate the vector Y.
613 *
614 TRANSL = ZERO
615 CALL DMAKE( 'ge', ' ', ' ', 1, ML, Y, 1,
616 $ YY, ABS( INCY ), 0, ML - 1,
617 $ RESET, TRANSL )
618 *
619 NC = NC + 1
620 *
621 * Save every datum before calling the
622 * subroutine.
623 *
624 TRANSS = TRANS
625 MS = M
626 NS = N
627 KLS = KL
628 KUS = KU
629 ALS = ALPHA
630 DO 10 I = 1, LAA
631 AS( I ) = AA( I )
632 10 CONTINUE
633 LDAS = LDA
634 DO 20 I = 1, LX
635 XS( I ) = XX( I )
636 20 CONTINUE
637 INCXS = INCX
638 BLS = BETA
639 DO 30 I = 1, LY
640 YS( I ) = YY( I )
641 30 CONTINUE
642 INCYS = INCY
643 *
644 * Call the subroutine.
645 *
646 IF( FULL )THEN
647 IF( TRACE )
648 $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
649 $ CTRANS, M, N, ALPHA, LDA, INCX,
650 $ BETA, INCY
651 IF( REWI )
652 $ REWIND NTRA
653 CALL CDGEMV( IORDER, TRANS, M, N,
654 $ ALPHA, AA, LDA, XX, INCX,
655 $ BETA, YY, INCY )
656 ELSE IF( BANDED )THEN
657 IF( TRACE )
658 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
659 $ CTRANS, M, N, KL, KU, ALPHA, LDA,
660 $ INCX, BETA, INCY
661 IF( REWI )
662 $ REWIND NTRA
663 CALL CDGBMV( IORDER, TRANS, M, N, KL,
664 $ KU, ALPHA, AA, LDA, XX,
665 $ INCX, BETA, YY, INCY )
666 END IF
667 *
668 * Check if error-exit was taken incorrectly.
669 *
670 IF( .NOT.OK )THEN
671 WRITE( NOUT, FMT = 9993 )
672 FATAL = .TRUE.
673 GO TO 130
674 END IF
675 *
676 * See what data changed inside subroutines.
677 *
678 ISAME( 1 ) = TRANS.EQ.TRANSS
679 ISAME( 2 ) = MS.EQ.M
680 ISAME( 3 ) = NS.EQ.N
681 IF( FULL )THEN
682 ISAME( 4 ) = ALS.EQ.ALPHA
683 ISAME( 5 ) = LDE( AS, AA, LAA )
684 ISAME( 6 ) = LDAS.EQ.LDA
685 ISAME( 7 ) = LDE( XS, XX, LX )
686 ISAME( 8 ) = INCXS.EQ.INCX
687 ISAME( 9 ) = BLS.EQ.BETA
688 IF( NULL )THEN
689 ISAME( 10 ) = LDE( YS, YY, LY )
690 ELSE
691 ISAME( 10 ) = LDERES( 'ge', ' ', 1,
692 $ ML, YS, YY,
693 $ ABS( INCY ) )
694 END IF
695 ISAME( 11 ) = INCYS.EQ.INCY
696 ELSE IF( BANDED )THEN
697 ISAME( 4 ) = KLS.EQ.KL
698 ISAME( 5 ) = KUS.EQ.KU
699 ISAME( 6 ) = ALS.EQ.ALPHA
700 ISAME( 7 ) = LDE( AS, AA, LAA )
701 ISAME( 8 ) = LDAS.EQ.LDA
702 ISAME( 9 ) = LDE( XS, XX, LX )
703 ISAME( 10 ) = INCXS.EQ.INCX
704 ISAME( 11 ) = BLS.EQ.BETA
705 IF( NULL )THEN
706 ISAME( 12 ) = LDE( YS, YY, LY )
707 ELSE
708 ISAME( 12 ) = LDERES( 'ge', ' ', 1,
709 $ ML, YS, YY,
710 $ ABS( INCY ) )
711 END IF
712 ISAME( 13 ) = INCYS.EQ.INCY
713 END IF
714 *
715 * If data was incorrectly changed, report
716 * and return.
717 *
718 SAME = .TRUE.
719 DO 40 I = 1, NARGS
720 SAME = SAME.AND.ISAME( I )
721 IF( .NOT.ISAME( I ) )
722 $ WRITE( NOUT, FMT = 9998 )I
723 40 CONTINUE
724 IF( .NOT.SAME )THEN
725 FATAL = .TRUE.
726 GO TO 130
727 END IF
728 *
729 IF( .NOT.NULL )THEN
730 *
731 * Check the result.
732 *
733 CALL DMVCH( TRANS, M, N, ALPHA, A,
734 $ NMAX, X, INCX, BETA, Y,
735 $ INCY, YT, G, YY, EPS, ERR,
736 $ FATAL, NOUT, .TRUE. )
737 ERRMAX = MAX( ERRMAX, ERR )
738 * If got really bad answer, report and
739 * return.
740 IF( FATAL )
741 $ GO TO 130
742 ELSE
743 * Avoid repeating tests with M.le.0 or
744 * N.le.0.
745 GO TO 110
746 END IF
747 *
748 50 CONTINUE
749 *
750 60 CONTINUE
751 *
752 70 CONTINUE
753 *
754 80 CONTINUE
755 *
756 90 CONTINUE
757 *
758 100 CONTINUE
759 *
760 110 CONTINUE
761 *
762 120 CONTINUE
763 *
764 * Report result.
765 *
766 IF( ERRMAX.LT.THRESH )THEN
767 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
768 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
769 ELSE
770 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
771 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
772 END IF
773 GO TO 140
774 *
775 130 CONTINUE
776 WRITE( NOUT, FMT = 9996 )SNAME
777 IF( FULL )THEN
778 WRITE( NOUT, FMT = 9994 )NC, SNAME, CTRANS, M, N, ALPHA, LDA,
779 $ INCX, BETA, INCY
780 ELSE IF( BANDED )THEN
781 WRITE( NOUT, FMT = 9995 )NC, SNAME, CTRANS, M, N, KL, KU,
782 $ ALPHA, LDA, INCX, BETA, INCY
783 END IF
784 *
785 140 CONTINUE
786 RETURN
787 *
788 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
789 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
790 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
791 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
792 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
793 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
794 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
795 $ ' (', I6, ' CALL', 'S)' )
796 10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
797 $ ' (', I6, ' CALL', 'S)' )
798 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
799 $ 'ANGED INCORRECTLY *******' )
800 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
801 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
802 $ ' - SUSPECT *******' )
803 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' )
804 9995 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 4( I3, ',' ), F4.1,
805 $ ', A,', I3, ',',/ 10x,'X,', I2, ',', F4.1, ', Y,',
806 $ I2, ') .' )
807 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 2( I3, ',' ), F4.1,
808 $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2,
809 $ ') .' )
810 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
811 $ '******' )
812 *
813 * End of DCHK1.
814 *
815 END
816 SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
817 $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
818 $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
819 $ XS, Y, YY, YS, YT, G, IORDER )
820 *
821 * Tests DSYMV, DSBMV and DSPMV.
822 *
823 * Auxiliary routine for test program for Level 2 Blas.
824 *
825 * -- Written on 10-August-1987.
826 * Richard Hanson, Sandia National Labs.
827 * Jeremy Du Croz, NAG Central Office.
828 *
829 * .. Parameters ..
830 DOUBLE PRECISION ZERO, HALF
831 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0 )
832 * .. Scalar Arguments ..
833 DOUBLE PRECISION EPS, THRESH
834 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
835 $ NOUT, NTRA, IORDER
836 LOGICAL FATAL, REWI, TRACE
837 CHARACTER*12 SNAME
838 * .. Array Arguments ..
839 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
840 $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ),
841 $ X( NMAX ), XS( NMAX*INCMAX ),
842 $ XX( NMAX*INCMAX ), Y( NMAX ),
843 $ YS( NMAX*INCMAX ), YT( NMAX ),
844 $ YY( NMAX*INCMAX )
845 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
846 * .. Local Scalars ..
847 DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL
848 INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY,
849 $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY,
850 $ N, NARGS, NC, NK, NS
851 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
852 CHARACTER*1 UPLO, UPLOS
853 CHARACTER*14 CUPLO
854 CHARACTER*2 ICH
855 * .. Local Arrays ..
856 LOGICAL ISAME( 13 )
857 * .. External Functions ..
858 LOGICAL LDE, LDERES
859 EXTERNAL LDE, LDERES
860 * .. External Subroutines ..
861 EXTERNAL DMAKE, DMVCH, CDSBMV, CDSPMV, CDSYMV
862 * .. Intrinsic Functions ..
863 INTRINSIC ABS, MAX
864 * .. Scalars in Common ..
865 INTEGER INFOT, NOUTC
866 LOGICAL OK
867 * .. Common blocks ..
868 COMMON /INFOC/INFOT, NOUTC, OK
869 * .. Data statements ..
870 DATA ICH/'UL'/
871 * .. Executable Statements ..
872 FULL = SNAME( 9: 9 ).EQ.'y'
873 BANDED = SNAME( 9: 9 ).EQ.'b'
874 PACKED = SNAME( 9: 9 ).EQ.'p'
875 * Define the number of arguments.
876 IF( FULL )THEN
877 NARGS = 10
878 ELSE IF( BANDED )THEN
879 NARGS = 11
880 ELSE IF( PACKED )THEN
881 NARGS = 9
882 END IF
883 *
884 NC = 0
885 RESET = .TRUE.
886 ERRMAX = ZERO
887 *
888 DO 110 IN = 1, NIDIM
889 N = IDIM( IN )
890 *
891 IF( BANDED )THEN
892 NK = NKB
893 ELSE
894 NK = 1
895 END IF
896 DO 100 IK = 1, NK
897 IF( BANDED )THEN
898 K = KB( IK )
899 ELSE
900 K = N - 1
901 END IF
902 * Set LDA to 1 more than minimum value if room.
903 IF( BANDED )THEN
904 LDA = K + 1
905 ELSE
906 LDA = N
907 END IF
908 IF( LDA.LT.NMAX )
909 $ LDA = LDA + 1
910 * Skip tests if not enough room.
911 IF( LDA.GT.NMAX )
912 $ GO TO 100
913 IF( PACKED )THEN
914 LAA = ( N*( N + 1 ) )/2
915 ELSE
916 LAA = LDA*N
917 END IF
918 NULL = N.LE.0
919 *
920 DO 90 IC = 1, 2
921 UPLO = ICH( IC: IC )
922 IF (UPLO.EQ.'U')THEN
923 CUPLO = ' CblasUpper'
924 ELSE
925 CUPLO = ' CblasLower'
926 END IF
927 *
928 * Generate the matrix A.
929 *
930 TRANSL = ZERO
931 CALL DMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A, NMAX, AA,
932 $ LDA, K, K, RESET, TRANSL )
933 *
934 DO 80 IX = 1, NINC
935 INCX = INC( IX )
936 LX = ABS( INCX )*N
937 *
938 * Generate the vector X.
939 *
940 TRANSL = HALF
941 CALL DMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX,
942 $ ABS( INCX ), 0, N - 1, RESET, TRANSL )
943 IF( N.GT.1 )THEN
944 X( N/2 ) = ZERO
945 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
946 END IF
947 *
948 DO 70 IY = 1, NINC
949 INCY = INC( IY )
950 LY = ABS( INCY )*N
951 *
952 DO 60 IA = 1, NALF
953 ALPHA = ALF( IA )
954 *
955 DO 50 IB = 1, NBET
956 BETA = BET( IB )
957 *
958 * Generate the vector Y.
959 *
960 TRANSL = ZERO
961 CALL DMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY,
962 $ ABS( INCY ), 0, N - 1, RESET,
963 $ TRANSL )
964 *
965 NC = NC + 1
966 *
967 * Save every datum before calling the
968 * subroutine.
969 *
970 UPLOS = UPLO
971 NS = N
972 KS = K
973 ALS = ALPHA
974 DO 10 I = 1, LAA
975 AS( I ) = AA( I )
976 10 CONTINUE
977 LDAS = LDA
978 DO 20 I = 1, LX
979 XS( I ) = XX( I )
980 20 CONTINUE
981 INCXS = INCX
982 BLS = BETA
983 DO 30 I = 1, LY
984 YS( I ) = YY( I )
985 30 CONTINUE
986 INCYS = INCY
987 *
988 * Call the subroutine.
989 *
990 IF( FULL )THEN
991 IF( TRACE )
992 $ WRITE( NTRA, FMT = 9993 )NC, SNAME,
993 $ CUPLO, N, ALPHA, LDA, INCX, BETA, INCY
994 IF( REWI )
995 $ REWIND NTRA
996 CALL CDSYMV( IORDER, UPLO, N, ALPHA, AA,
997 $ LDA, XX, INCX, BETA, YY, INCY )
998 ELSE IF( BANDED )THEN
999 IF( TRACE )
1000 $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
1001 $ CUPLO, N, K, ALPHA, LDA, INCX, BETA,
1002 $ INCY
1003 IF( REWI )
1004 $ REWIND NTRA
1005 CALL CDSBMV( IORDER, UPLO, N, K, ALPHA,
1006 $ AA, LDA, XX, INCX, BETA, YY,
1007 $ INCY )
1008 ELSE IF( PACKED )THEN
1009 IF( TRACE )
1010 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1011 $ CUPLO, N, ALPHA, INCX, BETA, INCY
1012 IF( REWI )
1013 $ REWIND NTRA
1014 CALL CDSPMV( IORDER, UPLO, N, ALPHA, AA,
1015 $ XX, INCX, BETA, YY, INCY )
1016 END IF
1017 *
1018 * Check if error-exit was taken incorrectly.
1019 *
1020 IF( .NOT.OK )THEN
1021 WRITE( NOUT, FMT = 9992 )
1022 FATAL = .TRUE.
1023 GO TO 120
1024 END IF
1025 *
1026 * See what data changed inside subroutines.
1027 *
1028 ISAME( 1 ) = UPLO.EQ.UPLOS
1029 ISAME( 2 ) = NS.EQ.N
1030 IF( FULL )THEN
1031 ISAME( 3 ) = ALS.EQ.ALPHA
1032 ISAME( 4 ) = LDE( AS, AA, LAA )
1033 ISAME( 5 ) = LDAS.EQ.LDA
1034 ISAME( 6 ) = LDE( XS, XX, LX )
1035 ISAME( 7 ) = INCXS.EQ.INCX
1036 ISAME( 8 ) = BLS.EQ.BETA
1037 IF( NULL )THEN
1038 ISAME( 9 ) = LDE( YS, YY, LY )
1039 ELSE
1040 ISAME( 9 ) = LDERES( 'ge', ' ', 1, N,
1041 $ YS, YY, ABS( INCY ) )
1042 END IF
1043 ISAME( 10 ) = INCYS.EQ.INCY
1044 ELSE IF( BANDED )THEN
1045 ISAME( 3 ) = KS.EQ.K
1046 ISAME( 4 ) = ALS.EQ.ALPHA
1047 ISAME( 5 ) = LDE( AS, AA, LAA )
1048 ISAME( 6 ) = LDAS.EQ.LDA
1049 ISAME( 7 ) = LDE( XS, XX, LX )
1050 ISAME( 8 ) = INCXS.EQ.INCX
1051 ISAME( 9 ) = BLS.EQ.BETA
1052 IF( NULL )THEN
1053 ISAME( 10 ) = LDE( YS, YY, LY )
1054 ELSE
1055 ISAME( 10 ) = LDERES( 'ge', ' ', 1, N,
1056 $ YS, YY, ABS( INCY ) )
1057 END IF
1058 ISAME( 11 ) = INCYS.EQ.INCY
1059 ELSE IF( PACKED )THEN
1060 ISAME( 3 ) = ALS.EQ.ALPHA
1061 ISAME( 4 ) = LDE( AS, AA, LAA )
1062 ISAME( 5 ) = LDE( XS, XX, LX )
1063 ISAME( 6 ) = INCXS.EQ.INCX
1064 ISAME( 7 ) = BLS.EQ.BETA
1065 IF( NULL )THEN
1066 ISAME( 8 ) = LDE( YS, YY, LY )
1067 ELSE
1068 ISAME( 8 ) = LDERES( 'ge', ' ', 1, N,
1069 $ YS, YY, ABS( INCY ) )
1070 END IF
1071 ISAME( 9 ) = INCYS.EQ.INCY
1072 END IF
1073 *
1074 * If data was incorrectly changed, report and
1075 * return.
1076 *
1077 SAME = .TRUE.
1078 DO 40 I = 1, NARGS
1079 SAME = SAME.AND.ISAME( I )
1080 IF( .NOT.ISAME( I ) )
1081 $ WRITE( NOUT, FMT = 9998 )I
1082 40 CONTINUE
1083 IF( .NOT.SAME )THEN
1084 FATAL = .TRUE.
1085 GO TO 120
1086 END IF
1087 *
1088 IF( .NOT.NULL )THEN
1089 *
1090 * Check the result.
1091 *
1092 CALL DMVCH( 'N', N, N, ALPHA, A, NMAX, X,
1093 $ INCX, BETA, Y, INCY, YT, G,
1094 $ YY, EPS, ERR, FATAL, NOUT,
1095 $ .TRUE. )
1096 ERRMAX = MAX( ERRMAX, ERR )
1097 * If got really bad answer, report and
1098 * return.
1099 IF( FATAL )
1100 $ GO TO 120
1101 ELSE
1102 * Avoid repeating tests with N.le.0
1103 GO TO 110
1104 END IF
1105 *
1106 50 CONTINUE
1107 *
1108 60 CONTINUE
1109 *
1110 70 CONTINUE
1111 *
1112 80 CONTINUE
1113 *
1114 90 CONTINUE
1115 *
1116 100 CONTINUE
1117 *
1118 110 CONTINUE
1119 *
1120 * Report result.
1121 *
1122 IF( ERRMAX.LT.THRESH )THEN
1123 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
1124 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
1125 ELSE
1126 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
1127 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
1128 END IF
1129 GO TO 130
1130 *
1131 120 CONTINUE
1132 WRITE( NOUT, FMT = 9996 )SNAME
1133 IF( FULL )THEN
1134 WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, LDA, INCX,
1135 $ BETA, INCY
1136 ELSE IF( BANDED )THEN
1137 WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, K, ALPHA, LDA,
1138 $ INCX, BETA, INCY
1139 ELSE IF( PACKED )THEN
1140 WRITE( NOUT, FMT = 9995 )NC, SNAME, CUPLO, N, ALPHA, INCX,
1141 $ BETA, INCY
1142 END IF
1143 *
1144 130 CONTINUE
1145 RETURN
1146 *
1147 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1148 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1149 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1150 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1151 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1152 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1153 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1154 $ ' (', I6, ' CALL', 'S)' )
1155 10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1156 $ ' (', I6, ' CALL', 'S)' )
1157 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1158 $ 'ANGED INCORRECTLY *******' )
1159 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1160 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1161 $ ' - SUSPECT *******' )
1162 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' )
1163 9995 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', AP',
1164 $ ', X,', I2, ',', F4.1, ', Y,', I2, ') .' )
1165 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 2( I3, ',' ), F4.1,
1166 $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2,
1167 $ ') .' )
1168 9993 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', A,',
1169 $ I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' )
1170 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1171 $ '******' )
1172 *
1173 * End of DCHK2.
1174 *
1175 END
1176 SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1177 $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX,
1178 $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z, IORDER )
1179 *
1180 * Tests DTRMV, DTBMV, DTPMV, DTRSV, DTBSV and DTPSV.
1181 *
1182 * Auxiliary routine for test program for Level 2 Blas.
1183 *
1184 * -- Written on 10-August-1987.
1185 * Richard Hanson, Sandia National Labs.
1186 * Jeremy Du Croz, NAG Central Office.
1187 *
1188 * .. Parameters ..
1189 DOUBLE PRECISION ZERO, HALF, ONE
1190 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
1191 * .. Scalar Arguments ..
1192 DOUBLE PRECISION EPS, THRESH
1193 INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA,
1194 $ IORDER
1195 LOGICAL FATAL, REWI, TRACE
1196 CHARACTER*12 SNAME
1197 * .. Array Arguments ..
1198 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ),
1199 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1200 $ XS( NMAX*INCMAX ), XT( NMAX ),
1201 $ XX( NMAX*INCMAX ), Z( NMAX )
1202 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
1203 * .. Local Scalars ..
1204 DOUBLE PRECISION ERR, ERRMAX, TRANSL
1205 INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K,
1206 $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS
1207 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
1208 CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS
1209 CHARACTER*14 CUPLO,CTRANS,CDIAG
1210 CHARACTER*2 ICHD, ICHU
1211 CHARACTER*3 ICHT
1212 * .. Local Arrays ..
1213 LOGICAL ISAME( 13 )
1214 * .. External Functions ..
1215 LOGICAL LDE, LDERES
1216 EXTERNAL LDE, LDERES
1217 * .. External Subroutines ..
1218 EXTERNAL DMAKE, DMVCH, CDTBMV, CDTBSV, CDTPMV,
1219 $ CDTPSV, CDTRMV, CDTRSV
1220 * .. Intrinsic Functions ..
1221 INTRINSIC ABS, MAX
1222 * .. Scalars in Common ..
1223 INTEGER INFOT, NOUTC
1224 LOGICAL OK
1225 * .. Common blocks ..
1226 COMMON /INFOC/INFOT, NOUTC, OK
1227 * .. Data statements ..
1228 DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/
1229 * .. Executable Statements ..
1230 FULL = SNAME( 9: 9 ).EQ.'r'
1231 BANDED = SNAME( 9: 9 ).EQ.'b'
1232 PACKED = SNAME( 9: 9 ).EQ.'p'
1233 * Define the number of arguments.
1234 IF( FULL )THEN
1235 NARGS = 8
1236 ELSE IF( BANDED )THEN
1237 NARGS = 9
1238 ELSE IF( PACKED )THEN
1239 NARGS = 7
1240 END IF
1241 *
1242 NC = 0
1243 RESET = .TRUE.
1244 ERRMAX = ZERO
1245 * Set up zero vector for DMVCH.
1246 DO 10 I = 1, NMAX
1247 Z( I ) = ZERO
1248 10 CONTINUE
1249 *
1250 DO 110 IN = 1, NIDIM
1251 N = IDIM( IN )
1252 *
1253 IF( BANDED )THEN
1254 NK = NKB
1255 ELSE
1256 NK = 1
1257 END IF
1258 DO 100 IK = 1, NK
1259 IF( BANDED )THEN
1260 K = KB( IK )
1261 ELSE
1262 K = N - 1
1263 END IF
1264 * Set LDA to 1 more than minimum value if room.
1265 IF( BANDED )THEN
1266 LDA = K + 1
1267 ELSE
1268 LDA = N
1269 END IF
1270 IF( LDA.LT.NMAX )
1271 $ LDA = LDA + 1
1272 * Skip tests if not enough room.
1273 IF( LDA.GT.NMAX )
1274 $ GO TO 100
1275 IF( PACKED )THEN
1276 LAA = ( N*( N + 1 ) )/2
1277 ELSE
1278 LAA = LDA*N
1279 END IF
1280 NULL = N.LE.0
1281 *
1282 DO 90 ICU = 1, 2
1283 UPLO = ICHU( ICU: ICU )
1284 IF (UPLO.EQ.'U')THEN
1285 CUPLO = ' CblasUpper'
1286 ELSE
1287 CUPLO = ' CblasLower'
1288 END IF
1289 *
1290 DO 80 ICT = 1, 3
1291 TRANS = ICHT( ICT: ICT )
1292 IF (TRANS.EQ.'N')THEN
1293 CTRANS = ' CblasNoTrans'
1294 ELSE IF (TRANS.EQ.'T')THEN
1295 CTRANS = ' CblasTrans'
1296 ELSE
1297 CTRANS = 'CblasConjTrans'
1298 END IF
1299 *
1300 DO 70 ICD = 1, 2
1301 DIAG = ICHD( ICD: ICD )
1302 IF (DIAG.EQ.'N')THEN
1303 CDIAG = ' CblasNonUnit'
1304 ELSE
1305 CDIAG = ' CblasUnit'
1306 END IF
1307 *
1308 * Generate the matrix A.
1309 *
1310 TRANSL = ZERO
1311 CALL DMAKE( SNAME( 8: 9 ), UPLO, DIAG, N, N, A,
1312 $ NMAX, AA, LDA, K, K, RESET, TRANSL )
1313 *
1314 DO 60 IX = 1, NINC
1315 INCX = INC( IX )
1316 LX = ABS( INCX )*N
1317 *
1318 * Generate the vector X.
1319 *
1320 TRANSL = HALF
1321 CALL DMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX,
1322 $ ABS( INCX ), 0, N - 1, RESET,
1323 $ TRANSL )
1324 IF( N.GT.1 )THEN
1325 X( N/2 ) = ZERO
1326 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
1327 END IF
1328 *
1329 NC = NC + 1
1330 *
1331 * Save every datum before calling the subroutine.
1332 *
1333 UPLOS = UPLO
1334 TRANSS = TRANS
1335 DIAGS = DIAG
1336 NS = N
1337 KS = K
1338 DO 20 I = 1, LAA
1339 AS( I ) = AA( I )
1340 20 CONTINUE
1341 LDAS = LDA
1342 DO 30 I = 1, LX
1343 XS( I ) = XX( I )
1344 30 CONTINUE
1345 INCXS = INCX
1346 *
1347 * Call the subroutine.
1348 *
1349 IF( SNAME( 10: 11 ).EQ.'mv' )THEN
1350 IF( FULL )THEN
1351 IF( TRACE )
1352 $ WRITE( NTRA, FMT = 9993 )NC, SNAME,
1353 $ CUPLO, CTRANS, CDIAG, N, LDA, INCX
1354 IF( REWI )
1355 $ REWIND NTRA
1356 CALL CDTRMV( IORDER, UPLO, TRANS, DIAG,
1357 $ N, AA, LDA, XX, INCX )
1358 ELSE IF( BANDED )THEN
1359 IF( TRACE )
1360 $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
1361 $ CUPLO, CTRANS, CDIAG, N, K, LDA, INCX
1362 IF( REWI )
1363 $ REWIND NTRA
1364 CALL CDTBMV( IORDER, UPLO, TRANS, DIAG,
1365 $ N, K, AA, LDA, XX, INCX )
1366 ELSE IF( PACKED )THEN
1367 IF( TRACE )
1368 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1369 $ CUPLO, CTRANS, CDIAG, N, INCX
1370 IF( REWI )
1371 $ REWIND NTRA
1372 CALL CDTPMV( IORDER, UPLO, TRANS, DIAG,
1373 $ N, AA, XX, INCX )
1374 END IF
1375 ELSE IF( SNAME( 10: 11 ).EQ.'sv' )THEN
1376 IF( FULL )THEN
1377 IF( TRACE )
1378 $ WRITE( NTRA, FMT = 9993 )NC, SNAME,
1379 $ CUPLO, CTRANS, CDIAG, N, LDA, INCX
1380 IF( REWI )
1381 $ REWIND NTRA
1382 CALL CDTRSV( IORDER, UPLO, TRANS, DIAG,
1383 $ N, AA, LDA, XX, INCX )
1384 ELSE IF( BANDED )THEN
1385 IF( TRACE )
1386 $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
1387 $ CUPLO, CTRANS, CDIAG, N, K, LDA, INCX
1388 IF( REWI )
1389 $ REWIND NTRA
1390 CALL CDTBSV( IORDER, UPLO, TRANS, DIAG,
1391 $ N, K, AA, LDA, XX, INCX )
1392 ELSE IF( PACKED )THEN
1393 IF( TRACE )
1394 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1395 $ CUPLO, CTRANS, CDIAG, N, INCX
1396 IF( REWI )
1397 $ REWIND NTRA
1398 CALL CDTPSV( IORDER, UPLO, TRANS, DIAG,
1399 $ N, AA, XX, INCX )
1400 END IF
1401 END IF
1402 *
1403 * Check if error-exit was taken incorrectly.
1404 *
1405 IF( .NOT.OK )THEN
1406 WRITE( NOUT, FMT = 9992 )
1407 FATAL = .TRUE.
1408 GO TO 120
1409 END IF
1410 *
1411 * See what data changed inside subroutines.
1412 *
1413 ISAME( 1 ) = UPLO.EQ.UPLOS
1414 ISAME( 2 ) = TRANS.EQ.TRANSS
1415 ISAME( 3 ) = DIAG.EQ.DIAGS
1416 ISAME( 4 ) = NS.EQ.N
1417 IF( FULL )THEN
1418 ISAME( 5 ) = LDE( AS, AA, LAA )
1419 ISAME( 6 ) = LDAS.EQ.LDA
1420 IF( NULL )THEN
1421 ISAME( 7 ) = LDE( XS, XX, LX )
1422 ELSE
1423 ISAME( 7 ) = LDERES( 'ge', ' ', 1, N, XS,
1424 $ XX, ABS( INCX ) )
1425 END IF
1426 ISAME( 8 ) = INCXS.EQ.INCX
1427 ELSE IF( BANDED )THEN
1428 ISAME( 5 ) = KS.EQ.K
1429 ISAME( 6 ) = LDE( AS, AA, LAA )
1430 ISAME( 7 ) = LDAS.EQ.LDA
1431 IF( NULL )THEN
1432 ISAME( 8 ) = LDE( XS, XX, LX )
1433 ELSE
1434 ISAME( 8 ) = LDERES( 'ge', ' ', 1, N, XS,
1435 $ XX, ABS( INCX ) )
1436 END IF
1437 ISAME( 9 ) = INCXS.EQ.INCX
1438 ELSE IF( PACKED )THEN
1439 ISAME( 5 ) = LDE( AS, AA, LAA )
1440 IF( NULL )THEN
1441 ISAME( 6 ) = LDE( XS, XX, LX )
1442 ELSE
1443 ISAME( 6 ) = LDERES( 'ge', ' ', 1, N, XS,
1444 $ XX, ABS( INCX ) )
1445 END IF
1446 ISAME( 7 ) = INCXS.EQ.INCX
1447 END IF
1448 *
1449 * If data was incorrectly changed, report and
1450 * return.
1451 *
1452 SAME = .TRUE.
1453 DO 40 I = 1, NARGS
1454 SAME = SAME.AND.ISAME( I )
1455 IF( .NOT.ISAME( I ) )
1456 $ WRITE( NOUT, FMT = 9998 )I
1457 40 CONTINUE
1458 IF( .NOT.SAME )THEN
1459 FATAL = .TRUE.
1460 GO TO 120
1461 END IF
1462 *
1463 IF( .NOT.NULL )THEN
1464 IF( SNAME( 10: 11 ).EQ.'mv' )THEN
1465 *
1466 * Check the result.
1467 *
1468 CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X,
1469 $ INCX, ZERO, Z, INCX, XT, G,
1470 $ XX, EPS, ERR, FATAL, NOUT,
1471 $ .TRUE. )
1472 ELSE IF( SNAME( 10: 11 ).EQ.'sv' )THEN
1473 *
1474 * Compute approximation to original vector.
1475 *
1476 DO 50 I = 1, N
1477 Z( I ) = XX( 1 + ( I - 1 )*
1478 $ ABS( INCX ) )
1479 XX( 1 + ( I - 1 )*ABS( INCX ) )
1480 $ = X( I )
1481 50 CONTINUE
1482 CALL DMVCH( TRANS, N, N, ONE, A, NMAX, Z,
1483 $ INCX, ZERO, X, INCX, XT, G,
1484 $ XX, EPS, ERR, FATAL, NOUT,
1485 $ .FALSE. )
1486 END IF
1487 ERRMAX = MAX( ERRMAX, ERR )
1488 * If got really bad answer, report and return.
1489 IF( FATAL )
1490 $ GO TO 120
1491 ELSE
1492 * Avoid repeating tests with N.le.0.
1493 GO TO 110
1494 END IF
1495 *
1496 60 CONTINUE
1497 *
1498 70 CONTINUE
1499 *
1500 80 CONTINUE
1501 *
1502 90 CONTINUE
1503 *
1504 100 CONTINUE
1505 *
1506 110 CONTINUE
1507 *
1508 * Report result.
1509 *
1510 IF( ERRMAX.LT.THRESH )THEN
1511 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
1512 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
1513 ELSE
1514 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
1515 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
1516 END IF
1517 GO TO 130
1518 *
1519 120 CONTINUE
1520 WRITE( NOUT, FMT = 9996 )SNAME
1521 IF( FULL )THEN
1522 WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, CTRANS, CDIAG, N,
1523 $ LDA, INCX
1524 ELSE IF( BANDED )THEN
1525 WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, CTRANS, CDIAG, N, K,
1526 $ LDA, INCX
1527 ELSE IF( PACKED )THEN
1528 WRITE( NOUT, FMT = 9995 )NC, SNAME, CUPLO, CTRANS, CDIAG, N,
1529 $ INCX
1530 END IF
1531 *
1532 130 CONTINUE
1533 RETURN
1534 *
1535 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1536 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1537 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1538 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1539 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1540 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1541 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1542 $ ' (', I6, ' CALL', 'S)' )
1543 10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1544 $ ' (', I6, ' CALL', 'S)' )
1545 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1546 $ 'ANGED INCORRECTLY *******' )
1547 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1548 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1549 $ ' - SUSPECT *******' )
1550 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' )
1551 9995 FORMAT( 1X, I6, ': ',A12, '(', 3( A14,',' ),/ 10x, I3, ', AP, ',
1552 $ 'X,', I2, ') .' )
1553 9994 FORMAT( 1X, I6, ': ',A12, '(', 3( A14,',' ),/ 10x, 2( I3, ',' ),
1554 $ ' A,', I3, ', X,', I2, ') .' )
1555 9993 FORMAT( 1X, I6, ': ',A12, '(', 3( A14,',' ),/ 10x, I3, ', A,',
1556 $ I3, ', X,', I2, ') .' )
1557 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1558 $ '******' )
1559 *
1560 * End of DCHK3.
1561 *
1562 END
1563 SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1564 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
1565 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
1566 $ Z, IORDER )
1567 *
1568 * Tests DGER.
1569 *
1570 * Auxiliary routine for test program for Level 2 Blas.
1571 *
1572 * -- Written on 10-August-1987.
1573 * Richard Hanson, Sandia National Labs.
1574 * Jeremy Du Croz, NAG Central Office.
1575 *
1576 * .. Parameters ..
1577 DOUBLE PRECISION ZERO, HALF, ONE
1578 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
1579 * .. Scalar Arguments ..
1580 DOUBLE PRECISION EPS, THRESH
1581 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA,
1582 $ IORDER
1583 LOGICAL FATAL, REWI, TRACE
1584 CHARACTER*12 SNAME
1585 * .. Array Arguments ..
1586 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1587 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1588 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
1589 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
1590 $ YY( NMAX*INCMAX ), Z( NMAX )
1591 INTEGER IDIM( NIDIM ), INC( NINC )
1592 * .. Local Scalars ..
1593 DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL
1594 INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX,
1595 $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS,
1596 $ NC, ND, NS
1597 LOGICAL NULL, RESET, SAME
1598 * .. Local Arrays ..
1599 DOUBLE PRECISION W( 1 )
1600 LOGICAL ISAME( 13 )
1601 * .. External Functions ..
1602 LOGICAL LDE, LDERES
1603 EXTERNAL LDE, LDERES
1604 * .. External Subroutines ..
1605 EXTERNAL DGER, DMAKE, DMVCH
1606 * .. Intrinsic Functions ..
1607 INTRINSIC ABS, MAX, MIN
1608 * .. Scalars in Common ..
1609 INTEGER INFOT, NOUTC
1610 LOGICAL OK
1611 * .. Common blocks ..
1612 COMMON /INFOC/INFOT, NOUTC, OK
1613 * .. Executable Statements ..
1614 * Define the number of arguments.
1615 NARGS = 9
1616 *
1617 NC = 0
1618 RESET = .TRUE.
1619 ERRMAX = ZERO
1620 *
1621 DO 120 IN = 1, NIDIM
1622 N = IDIM( IN )
1623 ND = N/2 + 1
1624 *
1625 DO 110 IM = 1, 2
1626 IF( IM.EQ.1 )
1627 $ M = MAX( N - ND, 0 )
1628 IF( IM.EQ.2 )
1629 $ M = MIN( N + ND, NMAX )
1630 *
1631 * Set LDA to 1 more than minimum value if room.
1632 LDA = M
1633 IF( LDA.LT.NMAX )
1634 $ LDA = LDA + 1
1635 * Skip tests if not enough room.
1636 IF( LDA.GT.NMAX )
1637 $ GO TO 110
1638 LAA = LDA*N
1639 NULL = N.LE.0.OR.M.LE.0
1640 *
1641 DO 100 IX = 1, NINC
1642 INCX = INC( IX )
1643 LX = ABS( INCX )*M
1644 *
1645 * Generate the vector X.
1646 *
1647 TRANSL = HALF
1648 CALL DMAKE( 'ge', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ),
1649 $ 0, M - 1, RESET, TRANSL )
1650 IF( M.GT.1 )THEN
1651 X( M/2 ) = ZERO
1652 XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO
1653 END IF
1654 *
1655 DO 90 IY = 1, NINC
1656 INCY = INC( IY )
1657 LY = ABS( INCY )*N
1658 *
1659 * Generate the vector Y.
1660 *
1661 TRANSL = ZERO
1662 CALL DMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY,
1663 $ ABS( INCY ), 0, N - 1, RESET, TRANSL )
1664 IF( N.GT.1 )THEN
1665 Y( N/2 ) = ZERO
1666 YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
1667 END IF
1668 *
1669 DO 80 IA = 1, NALF
1670 ALPHA = ALF( IA )
1671 *
1672 * Generate the matrix A.
1673 *
1674 TRANSL = ZERO
1675 CALL DMAKE( SNAME( 8: 9 ), ' ', ' ', M, N, A, NMAX,
1676 $ AA, LDA, M - 1, N - 1, RESET, TRANSL )
1677 *
1678 NC = NC + 1
1679 *
1680 * Save every datum before calling the subroutine.
1681 *
1682 MS = M
1683 NS = N
1684 ALS = ALPHA
1685 DO 10 I = 1, LAA
1686 AS( I ) = AA( I )
1687 10 CONTINUE
1688 LDAS = LDA
1689 DO 20 I = 1, LX
1690 XS( I ) = XX( I )
1691 20 CONTINUE
1692 INCXS = INCX
1693 DO 30 I = 1, LY
1694 YS( I ) = YY( I )
1695 30 CONTINUE
1696 INCYS = INCY
1697 *
1698 * Call the subroutine.
1699 *
1700 IF( TRACE )
1701 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N,
1702 $ ALPHA, INCX, INCY, LDA
1703 IF( REWI )
1704 $ REWIND NTRA
1705 CALL CDGER( IORDER, M, N, ALPHA, XX, INCX, YY,
1706 $ INCY, AA, LDA )
1707 *
1708 * Check if error-exit was taken incorrectly.
1709 *
1710 IF( .NOT.OK )THEN
1711 WRITE( NOUT, FMT = 9993 )
1712 FATAL = .TRUE.
1713 GO TO 140
1714 END IF
1715 *
1716 * See what data changed inside subroutine.
1717 *
1718 ISAME( 1 ) = MS.EQ.M
1719 ISAME( 2 ) = NS.EQ.N
1720 ISAME( 3 ) = ALS.EQ.ALPHA
1721 ISAME( 4 ) = LDE( XS, XX, LX )
1722 ISAME( 5 ) = INCXS.EQ.INCX
1723 ISAME( 6 ) = LDE( YS, YY, LY )
1724 ISAME( 7 ) = INCYS.EQ.INCY
1725 IF( NULL )THEN
1726 ISAME( 8 ) = LDE( AS, AA, LAA )
1727 ELSE
1728 ISAME( 8 ) = LDERES( 'ge', ' ', M, N, AS, AA,
1729 $ LDA )
1730 END IF
1731 ISAME( 9 ) = LDAS.EQ.LDA
1732 *
1733 * If data was incorrectly changed, report and return.
1734 *
1735 SAME = .TRUE.
1736 DO 40 I = 1, NARGS
1737 SAME = SAME.AND.ISAME( I )
1738 IF( .NOT.ISAME( I ) )
1739 $ WRITE( NOUT, FMT = 9998 )I
1740 40 CONTINUE
1741 IF( .NOT.SAME )THEN
1742 FATAL = .TRUE.
1743 GO TO 140
1744 END IF
1745 *
1746 IF( .NOT.NULL )THEN
1747 *
1748 * Check the result column by column.
1749 *
1750 IF( INCX.GT.0 )THEN
1751 DO 50 I = 1, M
1752 Z( I ) = X( I )
1753 50 CONTINUE
1754 ELSE
1755 DO 60 I = 1, M
1756 Z( I ) = X( M - I + 1 )
1757 60 CONTINUE
1758 END IF
1759 DO 70 J = 1, N
1760 IF( INCY.GT.0 )THEN
1761 W( 1 ) = Y( J )
1762 ELSE
1763 W( 1 ) = Y( N - J + 1 )
1764 END IF
1765 CALL DMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1,
1766 $ ONE, A( 1, J ), 1, YT, G,
1767 $ AA( 1 + ( J - 1 )*LDA ), EPS,
1768 $ ERR, FATAL, NOUT, .TRUE. )
1769 ERRMAX = MAX( ERRMAX, ERR )
1770 * If got really bad answer, report and return.
1771 IF( FATAL )
1772 $ GO TO 130
1773 70 CONTINUE
1774 ELSE
1775 * Avoid repeating tests with M.le.0 or N.le.0.
1776 GO TO 110
1777 END IF
1778 *
1779 80 CONTINUE
1780 *
1781 90 CONTINUE
1782 *
1783 100 CONTINUE
1784 *
1785 110 CONTINUE
1786 *
1787 120 CONTINUE
1788 *
1789 * Report result.
1790 *
1791 IF( ERRMAX.LT.THRESH )THEN
1792 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
1793 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
1794 ELSE
1795 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
1796 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
1797 END IF
1798 GO TO 150
1799 *
1800 130 CONTINUE
1801 WRITE( NOUT, FMT = 9995 )J
1802 *
1803 140 CONTINUE
1804 WRITE( NOUT, FMT = 9996 )SNAME
1805 WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA
1806 *
1807 150 CONTINUE
1808 RETURN
1809 *
1810 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1811 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1812 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1813 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1814 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1815 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1816 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1817 $ ' (', I6, ' CALL', 'S)' )
1818 10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1819 $ ' (', I6, ' CALL', 'S)' )
1820 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1821 $ 'ANGED INCORRECTLY *******' )
1822 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1823 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1824 $ ' - SUSPECT *******' )
1825 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' )
1826 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
1827 9994 FORMAT( 1X, I6, ': ',A12, '(', 2( I3, ',' ), F4.1, ', X,', I2,
1828 $ ', Y,', I2, ', A,', I3, ') .' )
1829 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1830 $ '******' )
1831 *
1832 * End of DCHK4.
1833 *
1834 END
1835 SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1836 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
1837 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
1838 $ Z, IORDER )
1839 *
1840 * Tests DSYR and DSPR.
1841 *
1842 * Auxiliary routine for test program for Level 2 Blas.
1843 *
1844 * -- Written on 10-August-1987.
1845 * Richard Hanson, Sandia National Labs.
1846 * Jeremy Du Croz, NAG Central Office.
1847 *
1848 * .. Parameters ..
1849 DOUBLE PRECISION ZERO, HALF, ONE
1850 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
1851 * .. Scalar Arguments ..
1852 DOUBLE PRECISION EPS, THRESH
1853 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA,
1854 $ IORDER
1855 LOGICAL FATAL, REWI, TRACE
1856 CHARACTER*12 SNAME
1857 * .. Array Arguments ..
1858 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1859 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1860 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
1861 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
1862 $ YY( NMAX*INCMAX ), Z( NMAX )
1863 INTEGER IDIM( NIDIM ), INC( NINC )
1864 * .. Local Scalars ..
1865 DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL
1866 INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA,
1867 $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS
1868 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
1869 CHARACTER*1 UPLO, UPLOS
1870 CHARACTER*14 CUPLO
1871 CHARACTER*2 ICH
1872 * .. Local Arrays ..
1873 DOUBLE PRECISION W( 1 )
1874 LOGICAL ISAME( 13 )
1875 * .. External Functions ..
1876 LOGICAL LDE, LDERES
1877 EXTERNAL LDE, LDERES
1878 * .. External Subroutines ..
1879 EXTERNAL DMAKE, DMVCH, CDSPR, CDSYR
1880 * .. Intrinsic Functions ..
1881 INTRINSIC ABS, MAX
1882 * .. Scalars in Common ..
1883 INTEGER INFOT, NOUTC
1884 LOGICAL OK
1885 * .. Common blocks ..
1886 COMMON /INFOC/INFOT, NOUTC, OK
1887 * .. Data statements ..
1888 DATA ICH/'UL'/
1889 * .. Executable Statements ..
1890 FULL = SNAME( 9: 9 ).EQ.'y'
1891 PACKED = SNAME( 9: 9 ).EQ.'p'
1892 * Define the number of arguments.
1893 IF( FULL )THEN
1894 NARGS = 7
1895 ELSE IF( PACKED )THEN
1896 NARGS = 6
1897 END IF
1898 *
1899 NC = 0
1900 RESET = .TRUE.
1901 ERRMAX = ZERO
1902 *
1903 DO 100 IN = 1, NIDIM
1904 N = IDIM( IN )
1905 * Set LDA to 1 more than minimum value if room.
1906 LDA = N
1907 IF( LDA.LT.NMAX )
1908 $ LDA = LDA + 1
1909 * Skip tests if not enough room.
1910 IF( LDA.GT.NMAX )
1911 $ GO TO 100
1912 IF( PACKED )THEN
1913 LAA = ( N*( N + 1 ) )/2
1914 ELSE
1915 LAA = LDA*N
1916 END IF
1917 *
1918 DO 90 IC = 1, 2
1919 UPLO = ICH( IC: IC )
1920 IF (UPLO.EQ.'U')THEN
1921 CUPLO = ' CblasUpper'
1922 ELSE
1923 CUPLO = ' CblasLower'
1924 END IF
1925 UPPER = UPLO.EQ.'U'
1926 *
1927 DO 80 IX = 1, NINC
1928 INCX = INC( IX )
1929 LX = ABS( INCX )*N
1930 *
1931 * Generate the vector X.
1932 *
1933 TRANSL = HALF
1934 CALL DMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
1935 $ 0, N - 1, RESET, TRANSL )
1936 IF( N.GT.1 )THEN
1937 X( N/2 ) = ZERO
1938 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
1939 END IF
1940 *
1941 DO 70 IA = 1, NALF
1942 ALPHA = ALF( IA )
1943 NULL = N.LE.0.OR.ALPHA.EQ.ZERO
1944 *
1945 * Generate the matrix A.
1946 *
1947 TRANSL = ZERO
1948 CALL DMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A, NMAX,
1949 $ AA, LDA, N - 1, N - 1, RESET, TRANSL )
1950 *
1951 NC = NC + 1
1952 *
1953 * Save every datum before calling the subroutine.
1954 *
1955 UPLOS = UPLO
1956 NS = N
1957 ALS = ALPHA
1958 DO 10 I = 1, LAA
1959 AS( I ) = AA( I )
1960 10 CONTINUE
1961 LDAS = LDA
1962 DO 20 I = 1, LX
1963 XS( I ) = XX( I )
1964 20 CONTINUE
1965 INCXS = INCX
1966 *
1967 * Call the subroutine.
1968 *
1969 IF( FULL )THEN
1970 IF( TRACE )
1971 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, CUPLO, N,
1972 $ ALPHA, INCX, LDA
1973 IF( REWI )
1974 $ REWIND NTRA
1975 CALL CDSYR( IORDER, UPLO, N, ALPHA, XX, INCX,
1976 $ AA, LDA )
1977 ELSE IF( PACKED )THEN
1978 IF( TRACE )
1979 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, CUPLO, N,
1980 $ ALPHA, INCX
1981 IF( REWI )
1982 $ REWIND NTRA
1983 CALL CDSPR( IORDER, UPLO, N, ALPHA, XX, INCX, AA )
1984 END IF
1985 *
1986 * Check if error-exit was taken incorrectly.
1987 *
1988 IF( .NOT.OK )THEN
1989 WRITE( NOUT, FMT = 9992 )
1990 FATAL = .TRUE.
1991 GO TO 120
1992 END IF
1993 *
1994 * See what data changed inside subroutines.
1995 *
1996 ISAME( 1 ) = UPLO.EQ.UPLOS
1997 ISAME( 2 ) = NS.EQ.N
1998 ISAME( 3 ) = ALS.EQ.ALPHA
1999 ISAME( 4 ) = LDE( XS, XX, LX )
2000 ISAME( 5 ) = INCXS.EQ.INCX
2001 IF( NULL )THEN
2002 ISAME( 6 ) = LDE( AS, AA, LAA )
2003 ELSE
2004 ISAME( 6 ) = LDERES( SNAME( 8: 9 ), UPLO, N, N, AS,
2005 $ AA, LDA )
2006 END IF
2007 IF( .NOT.PACKED )THEN
2008 ISAME( 7 ) = LDAS.EQ.LDA
2009 END IF
2010 *
2011 * If data was incorrectly changed, report and return.
2012 *
2013 SAME = .TRUE.
2014 DO 30 I = 1, NARGS
2015 SAME = SAME.AND.ISAME( I )
2016 IF( .NOT.ISAME( I ) )
2017 $ WRITE( NOUT, FMT = 9998 )I
2018 30 CONTINUE
2019 IF( .NOT.SAME )THEN
2020 FATAL = .TRUE.
2021 GO TO 120
2022 END IF
2023 *
2024 IF( .NOT.NULL )THEN
2025 *
2026 * Check the result column by column.
2027 *
2028 IF( INCX.GT.0 )THEN
2029 DO 40 I = 1, N
2030 Z( I ) = X( I )
2031 40 CONTINUE
2032 ELSE
2033 DO 50 I = 1, N
2034 Z( I ) = X( N - I + 1 )
2035 50 CONTINUE
2036 END IF
2037 JA = 1
2038 DO 60 J = 1, N
2039 W( 1 ) = Z( J )
2040 IF( UPPER )THEN
2041 JJ = 1
2042 LJ = J
2043 ELSE
2044 JJ = J
2045 LJ = N - J + 1
2046 END IF
2047 CALL DMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W,
2048 $ 1, ONE, A( JJ, J ), 1, YT, G,
2049 $ AA( JA ), EPS, ERR, FATAL, NOUT,
2050 $ .TRUE. )
2051 IF( FULL )THEN
2052 IF( UPPER )THEN
2053 JA = JA + LDA
2054 ELSE
2055 JA = JA + LDA + 1
2056 END IF
2057 ELSE
2058 JA = JA + LJ
2059 END IF
2060 ERRMAX = MAX( ERRMAX, ERR )
2061 * If got really bad answer, report and return.
2062 IF( FATAL )
2063 $ GO TO 110
2064 60 CONTINUE
2065 ELSE
2066 * Avoid repeating tests if N.le.0.
2067 IF( N.LE.0 )
2068 $ GO TO 100
2069 END IF
2070 *
2071 70 CONTINUE
2072 *
2073 80 CONTINUE
2074 *
2075 90 CONTINUE
2076 *
2077 100 CONTINUE
2078 *
2079 * Report result.
2080 *
2081 IF( ERRMAX.LT.THRESH )THEN
2082 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
2083 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
2084 ELSE
2085 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
2086 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
2087 END IF
2088 GO TO 130
2089 *
2090 110 CONTINUE
2091 WRITE( NOUT, FMT = 9995 )J
2092 *
2093 120 CONTINUE
2094 WRITE( NOUT, FMT = 9996 )SNAME
2095 IF( FULL )THEN
2096 WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, INCX, LDA
2097 ELSE IF( PACKED )THEN
2098 WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, ALPHA, INCX
2099 END IF
2100 *
2101 130 CONTINUE
2102 RETURN
2103 *
2104 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2105 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2106 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
2107 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2108 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2109 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
2110 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2111 $ ' (', I6, ' CALL', 'S)' )
2112 10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
2113 $ ' (', I6, ' CALL', 'S)' )
2114 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
2115 $ 'ANGED INCORRECTLY *******' )
2116 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
2117 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
2118 $ ' - SUSPECT *******' )
2119 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' )
2120 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
2121 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,',
2122 $ I2, ', AP) .' )
2123 9993 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,',
2124 $ I2, ', A,', I3, ') .' )
2125 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2126 $ '******' )
2127 *
2128 * End of DCHK5.
2129 *
2130 END
2131 SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
2132 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
2133 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
2134 $ Z, IORDER )
2135 *
2136 * Tests DSYR2 and DSPR2.
2137 *
2138 * Auxiliary routine for test program for Level 2 Blas.
2139 *
2140 * -- Written on 10-August-1987.
2141 * Richard Hanson, Sandia National Labs.
2142 * Jeremy Du Croz, NAG Central Office.
2143 *
2144 * .. Parameters ..
2145 DOUBLE PRECISION ZERO, HALF, ONE
2146 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
2147 * .. Scalar Arguments ..
2148 DOUBLE PRECISION EPS, THRESH
2149 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA,
2150 $ IORDER
2151 LOGICAL FATAL, REWI, TRACE
2152 CHARACTER*12 SNAME
2153 * .. Array Arguments ..
2154 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
2155 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
2156 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
2157 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
2158 $ YY( NMAX*INCMAX ), Z( NMAX, 2 )
2159 INTEGER IDIM( NIDIM ), INC( NINC )
2160 * .. Local Scalars ..
2161 DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL
2162 INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX,
2163 $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N,
2164 $ NARGS, NC, NS
2165 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
2166 CHARACTER*1 UPLO, UPLOS
2167 CHARACTER*14 CUPLO
2168 CHARACTER*2 ICH
2169 * .. Local Arrays ..
2170 DOUBLE PRECISION W( 2 )
2171 LOGICAL ISAME( 13 )
2172 * .. External Functions ..
2173 LOGICAL LDE, LDERES
2174 EXTERNAL LDE, LDERES
2175 * .. External Subroutines ..
2176 EXTERNAL DMAKE, DMVCH, CDSPR2, CDSYR2
2177 * .. Intrinsic Functions ..
2178 INTRINSIC ABS, MAX
2179 * .. Scalars in Common ..
2180 INTEGER INFOT, NOUTC
2181 LOGICAL OK
2182 * .. Common blocks ..
2183 COMMON /INFOC/INFOT, NOUTC, OK
2184 * .. Data statements ..
2185 DATA ICH/'UL'/
2186 * .. Executable Statements ..
2187 FULL = SNAME( 9: 9 ).EQ.'y'
2188 PACKED = SNAME( 9: 9 ).EQ.'p'
2189 * Define the number of arguments.
2190 IF( FULL )THEN
2191 NARGS = 9
2192 ELSE IF( PACKED )THEN
2193 NARGS = 8
2194 END IF
2195 *
2196 NC = 0
2197 RESET = .TRUE.
2198 ERRMAX = ZERO
2199 *
2200 DO 140 IN = 1, NIDIM
2201 N = IDIM( IN )
2202 * Set LDA to 1 more than minimum value if room.
2203 LDA = N
2204 IF( LDA.LT.NMAX )
2205 $ LDA = LDA + 1
2206 * Skip tests if not enough room.
2207 IF( LDA.GT.NMAX )
2208 $ GO TO 140
2209 IF( PACKED )THEN
2210 LAA = ( N*( N + 1 ) )/2
2211 ELSE
2212 LAA = LDA*N
2213 END IF
2214 *
2215 DO 130 IC = 1, 2
2216 UPLO = ICH( IC: IC )
2217 IF (UPLO.EQ.'U')THEN
2218 CUPLO = ' CblasUpper'
2219 ELSE
2220 CUPLO = ' CblasLower'
2221 END IF
2222 UPPER = UPLO.EQ.'U'
2223 *
2224 DO 120 IX = 1, NINC
2225 INCX = INC( IX )
2226 LX = ABS( INCX )*N
2227 *
2228 * Generate the vector X.
2229 *
2230 TRANSL = HALF
2231 CALL DMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
2232 $ 0, N - 1, RESET, TRANSL )
2233 IF( N.GT.1 )THEN
2234 X( N/2 ) = ZERO
2235 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
2236 END IF
2237 *
2238 DO 110 IY = 1, NINC
2239 INCY = INC( IY )
2240 LY = ABS( INCY )*N
2241 *
2242 * Generate the vector Y.
2243 *
2244 TRANSL = ZERO
2245 CALL DMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY,
2246 $ ABS( INCY ), 0, N - 1, RESET, TRANSL )
2247 IF( N.GT.1 )THEN
2248 Y( N/2 ) = ZERO
2249 YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
2250 END IF
2251 *
2252 DO 100 IA = 1, NALF
2253 ALPHA = ALF( IA )
2254 NULL = N.LE.0.OR.ALPHA.EQ.ZERO
2255 *
2256 * Generate the matrix A.
2257 *
2258 TRANSL = ZERO
2259 CALL DMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A,
2260 $ NMAX, AA, LDA, N - 1, N - 1, RESET,
2261 $ TRANSL )
2262 *
2263 NC = NC + 1
2264 *
2265 * Save every datum before calling the subroutine.
2266 *
2267 UPLOS = UPLO
2268 NS = N
2269 ALS = ALPHA
2270 DO 10 I = 1, LAA
2271 AS( I ) = AA( I )
2272 10 CONTINUE
2273 LDAS = LDA
2274 DO 20 I = 1, LX
2275 XS( I ) = XX( I )
2276 20 CONTINUE
2277 INCXS = INCX
2278 DO 30 I = 1, LY
2279 YS( I ) = YY( I )
2280 30 CONTINUE
2281 INCYS = INCY
2282 *
2283 * Call the subroutine.
2284 *
2285 IF( FULL )THEN
2286 IF( TRACE )
2287 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, CUPLO, N,
2288 $ ALPHA, INCX, INCY, LDA
2289 IF( REWI )
2290 $ REWIND NTRA
2291 CALL CDSYR2( IORDER, UPLO, N, ALPHA, XX, INCX,
2292 $ YY, INCY, AA, LDA )
2293 ELSE IF( PACKED )THEN
2294 IF( TRACE )
2295 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, CUPLO, N,
2296 $ ALPHA, INCX, INCY
2297 IF( REWI )
2298 $ REWIND NTRA
2299 CALL CDSPR2( IORDER, UPLO, N, ALPHA, XX, INCX,
2300 $ YY, INCY, AA )
2301 END IF
2302 *
2303 * Check if error-exit was taken incorrectly.
2304 *
2305 IF( .NOT.OK )THEN
2306 WRITE( NOUT, FMT = 9992 )
2307 FATAL = .TRUE.
2308 GO TO 160
2309 END IF
2310 *
2311 * See what data changed inside subroutines.
2312 *
2313 ISAME( 1 ) = UPLO.EQ.UPLOS
2314 ISAME( 2 ) = NS.EQ.N
2315 ISAME( 3 ) = ALS.EQ.ALPHA
2316 ISAME( 4 ) = LDE( XS, XX, LX )
2317 ISAME( 5 ) = INCXS.EQ.INCX
2318 ISAME( 6 ) = LDE( YS, YY, LY )
2319 ISAME( 7 ) = INCYS.EQ.INCY
2320 IF( NULL )THEN
2321 ISAME( 8 ) = LDE( AS, AA, LAA )
2322 ELSE
2323 ISAME( 8 ) = LDERES( SNAME( 8: 9 ), UPLO, N, N,
2324 $ AS, AA, LDA )
2325 END IF
2326 IF( .NOT.PACKED )THEN
2327 ISAME( 9 ) = LDAS.EQ.LDA
2328 END IF
2329 *
2330 * If data was incorrectly changed, report and return.
2331 *
2332 SAME = .TRUE.
2333 DO 40 I = 1, NARGS
2334 SAME = SAME.AND.ISAME( I )
2335 IF( .NOT.ISAME( I ) )
2336 $ WRITE( NOUT, FMT = 9998 )I
2337 40 CONTINUE
2338 IF( .NOT.SAME )THEN
2339 FATAL = .TRUE.
2340 GO TO 160
2341 END IF
2342 *
2343 IF( .NOT.NULL )THEN
2344 *
2345 * Check the result column by column.
2346 *
2347 IF( INCX.GT.0 )THEN
2348 DO 50 I = 1, N
2349 Z( I, 1 ) = X( I )
2350 50 CONTINUE
2351 ELSE
2352 DO 60 I = 1, N
2353 Z( I, 1 ) = X( N - I + 1 )
2354 60 CONTINUE
2355 END IF
2356 IF( INCY.GT.0 )THEN
2357 DO 70 I = 1, N
2358 Z( I, 2 ) = Y( I )
2359 70 CONTINUE
2360 ELSE
2361 DO 80 I = 1, N
2362 Z( I, 2 ) = Y( N - I + 1 )
2363 80 CONTINUE
2364 END IF
2365 JA = 1
2366 DO 90 J = 1, N
2367 W( 1 ) = Z( J, 2 )
2368 W( 2 ) = Z( J, 1 )
2369 IF( UPPER )THEN
2370 JJ = 1
2371 LJ = J
2372 ELSE
2373 JJ = J
2374 LJ = N - J + 1
2375 END IF
2376 CALL DMVCH( 'N', LJ, 2, ALPHA, Z( JJ, 1 ),
2377 $ NMAX, W, 1, ONE, A( JJ, J ), 1,
2378 $ YT, G, AA( JA ), EPS, ERR, FATAL,
2379 $ NOUT, .TRUE. )
2380 IF( FULL )THEN
2381 IF( UPPER )THEN
2382 JA = JA + LDA
2383 ELSE
2384 JA = JA + LDA + 1
2385 END IF
2386 ELSE
2387 JA = JA + LJ
2388 END IF
2389 ERRMAX = MAX( ERRMAX, ERR )
2390 * If got really bad answer, report and return.
2391 IF( FATAL )
2392 $ GO TO 150
2393 90 CONTINUE
2394 ELSE
2395 * Avoid repeating tests with N.le.0.
2396 IF( N.LE.0 )
2397 $ GO TO 140
2398 END IF
2399 *
2400 100 CONTINUE
2401 *
2402 110 CONTINUE
2403 *
2404 120 CONTINUE
2405 *
2406 130 CONTINUE
2407 *
2408 140 CONTINUE
2409 *
2410 * Report result.
2411 *
2412 IF( ERRMAX.LT.THRESH )THEN
2413 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
2414 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
2415 ELSE
2416 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
2417 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
2418 END IF
2419 GO TO 170
2420 *
2421 150 CONTINUE
2422 WRITE( NOUT, FMT = 9995 )J
2423 *
2424 160 CONTINUE
2425 WRITE( NOUT, FMT = 9996 )SNAME
2426 IF( FULL )THEN
2427 WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, INCX,
2428 $ INCY, LDA
2429 ELSE IF( PACKED )THEN
2430 WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, ALPHA, INCX, INCY
2431 END IF
2432 *
2433 170 CONTINUE
2434 RETURN
2435 *
2436 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2437 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2438 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
2439 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2440 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2441 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
2442 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2443 $ ' (', I6, ' CALL', 'S)' )
2444 10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
2445 $ ' (', I6, ' CALL', 'S)' )
2446 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
2447 $ 'ANGED INCORRECTLY *******' )
2448 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
2449 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
2450 $ ' - SUSPECT *******' )
2451 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' )
2452 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
2453 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,',
2454 $ I2, ', Y,', I2, ', AP) .' )
2455 9993 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,',
2456 $ I2, ', Y,', I2, ', A,', I3, ') .' )
2457 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2458 $ '******' )
2459 *
2460 * End of DCHK6.
2461 *
2462 END
2463 SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL,
2464 $ KU, RESET, TRANSL )
2465 *
2466 * Generates values for an M by N matrix A within the bandwidth
2467 * defined by KL and KU.
2468 * Stores the values in the array AA in the data structure required
2469 * by the routine, with unwanted elements set to rogue value.
2470 *
2471 * TYPE is 'ge', 'gb', 'sy', 'sb', 'sp', 'tr', 'tb' OR 'tp'.
2472 *
2473 * Auxiliary routine for test program for Level 2 Blas.
2474 *
2475 * -- Written on 10-August-1987.
2476 * Richard Hanson, Sandia National Labs.
2477 * Jeremy Du Croz, NAG Central Office.
2478 *
2479 * .. Parameters ..
2480 DOUBLE PRECISION ZERO, ONE
2481 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
2482 DOUBLE PRECISION ROGUE
2483 PARAMETER ( ROGUE = -1.0D10 )
2484 * .. Scalar Arguments ..
2485 DOUBLE PRECISION TRANSL
2486 INTEGER KL, KU, LDA, M, N, NMAX
2487 LOGICAL RESET
2488 CHARACTER*1 DIAG, UPLO
2489 CHARACTER*2 TYPE
2490 * .. Array Arguments ..
2491 DOUBLE PRECISION A( NMAX, * ), AA( * )
2492 * .. Local Scalars ..
2493 INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, KK
2494 LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
2495 * .. External Functions ..
2496 DOUBLE PRECISION DBEG
2497 EXTERNAL DBEG
2498 * .. Intrinsic Functions ..
2499 INTRINSIC MAX, MIN
2500 * .. Executable Statements ..
2501 GEN = TYPE( 1: 1 ).EQ.'g'
2502 SYM = TYPE( 1: 1 ).EQ.'s'
2503 TRI = TYPE( 1: 1 ).EQ.'t'
2504 UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U'
2505 LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L'
2506 UNIT = TRI.AND.DIAG.EQ.'U'
2507 *
2508 * Generate data in array A.
2509 *
2510 DO 20 J = 1, N
2511 DO 10 I = 1, M
2512 IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
2513 $ THEN
2514 IF( ( I.LE.J.AND.J - I.LE.KU ).OR.
2515 $ ( I.GE.J.AND.I - J.LE.KL ) )THEN
2516 A( I, J ) = DBEG( RESET ) + TRANSL
2517 ELSE
2518 A( I, J ) = ZERO
2519 END IF
2520 IF( I.NE.J )THEN
2521 IF( SYM )THEN
2522 A( J, I ) = A( I, J )
2523 ELSE IF( TRI )THEN
2524 A( J, I ) = ZERO
2525 END IF
2526 END IF
2527 END IF
2528 10 CONTINUE
2529 IF( TRI )
2530 $ A( J, J ) = A( J, J ) + ONE
2531 IF( UNIT )
2532 $ A( J, J ) = ONE
2533 20 CONTINUE
2534 *
2535 * Store elements in array AS in data structure required by routine.
2536 *
2537 IF( TYPE.EQ.'ge' )THEN
2538 DO 50 J = 1, N
2539 DO 30 I = 1, M
2540 AA( I + ( J - 1 )*LDA ) = A( I, J )
2541 30 CONTINUE
2542 DO 40 I = M + 1, LDA
2543 AA( I + ( J - 1 )*LDA ) = ROGUE
2544 40 CONTINUE
2545 50 CONTINUE
2546 ELSE IF( TYPE.EQ.'gb' )THEN
2547 DO 90 J = 1, N
2548 DO 60 I1 = 1, KU + 1 - J
2549 AA( I1 + ( J - 1 )*LDA ) = ROGUE
2550 60 CONTINUE
2551 DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J )
2552 AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J )
2553 70 CONTINUE
2554 DO 80 I3 = I2, LDA
2555 AA( I3 + ( J - 1 )*LDA ) = ROGUE
2556 80 CONTINUE
2557 90 CONTINUE
2558 ELSE IF( TYPE.EQ.'sy'.OR.TYPE.EQ.'tr' )THEN
2559 DO 130 J = 1, N
2560 IF( UPPER )THEN
2561 IBEG = 1
2562 IF( UNIT )THEN
2563 IEND = J - 1
2564 ELSE
2565 IEND = J
2566 END IF
2567 ELSE
2568 IF( UNIT )THEN
2569 IBEG = J + 1
2570 ELSE
2571 IBEG = J
2572 END IF
2573 IEND = N
2574 END IF
2575 DO 100 I = 1, IBEG - 1
2576 AA( I + ( J - 1 )*LDA ) = ROGUE
2577 100 CONTINUE
2578 DO 110 I = IBEG, IEND
2579 AA( I + ( J - 1 )*LDA ) = A( I, J )
2580 110 CONTINUE
2581 DO 120 I = IEND + 1, LDA
2582 AA( I + ( J - 1 )*LDA ) = ROGUE
2583 120 CONTINUE
2584 130 CONTINUE
2585 ELSE IF( TYPE.EQ.'sb'.OR.TYPE.EQ.'tb' )THEN
2586 DO 170 J = 1, N
2587 IF( UPPER )THEN
2588 KK = KL + 1
2589 IBEG = MAX( 1, KL + 2 - J )
2590 IF( UNIT )THEN
2591 IEND = KL
2592 ELSE
2593 IEND = KL + 1
2594 END IF
2595 ELSE
2596 KK = 1
2597 IF( UNIT )THEN
2598 IBEG = 2
2599 ELSE
2600 IBEG = 1
2601 END IF
2602 IEND = MIN( KL + 1, 1 + M - J )
2603 END IF
2604 DO 140 I = 1, IBEG - 1
2605 AA( I + ( J - 1 )*LDA ) = ROGUE
2606 140 CONTINUE
2607 DO 150 I = IBEG, IEND
2608 AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J )
2609 150 CONTINUE
2610 DO 160 I = IEND + 1, LDA
2611 AA( I + ( J - 1 )*LDA ) = ROGUE
2612 160 CONTINUE
2613 170 CONTINUE
2614 ELSE IF( TYPE.EQ.'sp'.OR.TYPE.EQ.'tp' )THEN
2615 IOFF = 0
2616 DO 190 J = 1, N
2617 IF( UPPER )THEN
2618 IBEG = 1
2619 IEND = J
2620 ELSE
2621 IBEG = J
2622 IEND = N
2623 END IF
2624 DO 180 I = IBEG, IEND
2625 IOFF = IOFF + 1
2626 AA( IOFF ) = A( I, J )
2627 IF( I.EQ.J )THEN
2628 IF( UNIT )
2629 $ AA( IOFF ) = ROGUE
2630 END IF
2631 180 CONTINUE
2632 190 CONTINUE
2633 END IF
2634 RETURN
2635 *
2636 * End of DMAKE.
2637 *
2638 END
2639 SUBROUTINE DMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y,
2640 $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV )
2641 *
2642 * Checks the results of the computational tests.
2643 *
2644 * Auxiliary routine for test program for Level 2 Blas.
2645 *
2646 * -- Written on 10-August-1987.
2647 * Richard Hanson, Sandia National Labs.
2648 * Jeremy Du Croz, NAG Central Office.
2649 *
2650 * .. Parameters ..
2651 DOUBLE PRECISION ZERO, ONE
2652 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
2653 * .. Scalar Arguments ..
2654 DOUBLE PRECISION ALPHA, BETA, EPS, ERR
2655 INTEGER INCX, INCY, M, N, NMAX, NOUT
2656 LOGICAL FATAL, MV
2657 CHARACTER*1 TRANS
2658 * .. Array Arguments ..
2659 DOUBLE PRECISION A( NMAX, * ), G( * ), X( * ), Y( * ), YT( * ),
2660 $ YY( * )
2661 * .. Local Scalars ..
2662 DOUBLE PRECISION ERRI
2663 INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL
2664 LOGICAL TRAN
2665 * .. Intrinsic Functions ..
2666 INTRINSIC ABS, MAX, SQRT
2667 * .. Executable Statements ..
2668 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
2669 IF( TRAN )THEN
2670 ML = N
2671 NL = M
2672 ELSE
2673 ML = M
2674 NL = N
2675 END IF
2676 IF( INCX.LT.0 )THEN
2677 KX = NL
2678 INCXL = -1
2679 ELSE
2680 KX = 1
2681 INCXL = 1
2682 END IF
2683 IF( INCY.LT.0 )THEN
2684 KY = ML
2685 INCYL = -1
2686 ELSE
2687 KY = 1
2688 INCYL = 1
2689 END IF
2690 *
2691 * Compute expected result in YT using data in A, X and Y.
2692 * Compute gauges in G.
2693 *
2694 IY = KY
2695 DO 30 I = 1, ML
2696 YT( IY ) = ZERO
2697 G( IY ) = ZERO
2698 JX = KX
2699 IF( TRAN )THEN
2700 DO 10 J = 1, NL
2701 YT( IY ) = YT( IY ) + A( J, I )*X( JX )
2702 G( IY ) = G( IY ) + ABS( A( J, I )*X( JX ) )
2703 JX = JX + INCXL
2704 10 CONTINUE
2705 ELSE
2706 DO 20 J = 1, NL
2707 YT( IY ) = YT( IY ) + A( I, J )*X( JX )
2708 G( IY ) = G( IY ) + ABS( A( I, J )*X( JX ) )
2709 JX = JX + INCXL
2710 20 CONTINUE
2711 END IF
2712 YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY )
2713 G( IY ) = ABS( ALPHA )*G( IY ) + ABS( BETA*Y( IY ) )
2714 IY = IY + INCYL
2715 30 CONTINUE
2716 *
2717 * Compute the error ratio for this result.
2718 *
2719 ERR = ZERO
2720 DO 40 I = 1, ML
2721 ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS
2722 IF( G( I ).NE.ZERO )
2723 $ ERRI = ERRI/G( I )
2724 ERR = MAX( ERR, ERRI )
2725 IF( ERR*SQRT( EPS ).GE.ONE )
2726 $ GO TO 50
2727 40 CONTINUE
2728 * If the loop completes, all results are at least half accurate.
2729 GO TO 70
2730 *
2731 * Report fatal error.
2732 *
2733 50 FATAL = .TRUE.
2734 WRITE( NOUT, FMT = 9999 )
2735 DO 60 I = 1, ML
2736 IF( MV )THEN
2737 WRITE( NOUT, FMT = 9998 )I, YT( I ),
2738 $ YY( 1 + ( I - 1 )*ABS( INCY ) )
2739 ELSE
2740 WRITE( NOUT, FMT = 9998 )I,
2741 $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT(I)
2742 END IF
2743 60 CONTINUE
2744 *
2745 70 CONTINUE
2746 RETURN
2747 *
2748 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2749 $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
2750 $ 'TED RESULT' )
2751 9998 FORMAT( 1X, I7, 2G18.6 )
2752 *
2753 * End of DMVCH.
2754 *
2755 END
2756 LOGICAL FUNCTION LDE( RI, RJ, LR )
2757 *
2758 * Tests if two arrays are identical.
2759 *
2760 * Auxiliary routine for test program for Level 2 Blas.
2761 *
2762 * -- Written on 10-August-1987.
2763 * Richard Hanson, Sandia National Labs.
2764 * Jeremy Du Croz, NAG Central Office.
2765 *
2766 * .. Scalar Arguments ..
2767 INTEGER LR
2768 * .. Array Arguments ..
2769 DOUBLE PRECISION RI( * ), RJ( * )
2770 * .. Local Scalars ..
2771 INTEGER I
2772 * .. Executable Statements ..
2773 DO 10 I = 1, LR
2774 IF( RI( I ).NE.RJ( I ) )
2775 $ GO TO 20
2776 10 CONTINUE
2777 LDE = .TRUE.
2778 GO TO 30
2779 20 CONTINUE
2780 LDE = .FALSE.
2781 30 RETURN
2782 *
2783 * End of LDE.
2784 *
2785 END
2786 LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA )
2787 *
2788 * Tests if selected elements in two arrays are equal.
2789 *
2790 * TYPE is 'ge', 'sy' or 'sp'.
2791 *
2792 * Auxiliary routine for test program for Level 2 Blas.
2793 *
2794 * -- Written on 10-August-1987.
2795 * Richard Hanson, Sandia National Labs.
2796 * Jeremy Du Croz, NAG Central Office.
2797 *
2798 * .. Scalar Arguments ..
2799 INTEGER LDA, M, N
2800 CHARACTER*1 UPLO
2801 CHARACTER*2 TYPE
2802 * .. Array Arguments ..
2803 DOUBLE PRECISION AA( LDA, * ), AS( LDA, * )
2804 * .. Local Scalars ..
2805 INTEGER I, IBEG, IEND, J
2806 LOGICAL UPPER
2807 * .. Executable Statements ..
2808 UPPER = UPLO.EQ.'U'
2809 IF( TYPE.EQ.'ge' )THEN
2810 DO 20 J = 1, N
2811 DO 10 I = M + 1, LDA
2812 IF( AA( I, J ).NE.AS( I, J ) )
2813 $ GO TO 70
2814 10 CONTINUE
2815 20 CONTINUE
2816 ELSE IF( TYPE.EQ.'sy' )THEN
2817 DO 50 J = 1, N
2818 IF( UPPER )THEN
2819 IBEG = 1
2820 IEND = J
2821 ELSE
2822 IBEG = J
2823 IEND = N
2824 END IF
2825 DO 30 I = 1, IBEG - 1
2826 IF( AA( I, J ).NE.AS( I, J ) )
2827 $ GO TO 70
2828 30 CONTINUE
2829 DO 40 I = IEND + 1, LDA
2830 IF( AA( I, J ).NE.AS( I, J ) )
2831 $ GO TO 70
2832 40 CONTINUE
2833 50 CONTINUE
2834 END IF
2835 *
2836 60 CONTINUE
2837 LDERES = .TRUE.
2838 GO TO 80
2839 70 CONTINUE
2840 LDERES = .FALSE.
2841 80 RETURN
2842 *
2843 * End of LDERES.
2844 *
2845 END
2846 DOUBLE PRECISION FUNCTION DBEG( RESET )
2847 *
2848 * Generates random numbers uniformly distributed between -0.5 and 0.5.
2849 *
2850 * Auxiliary routine for test program for Level 2 Blas.
2851 *
2852 * -- Written on 10-August-1987.
2853 * Richard Hanson, Sandia National Labs.
2854 * Jeremy Du Croz, NAG Central Office.
2855 *
2856 * .. Scalar Arguments ..
2857 LOGICAL RESET
2858 * .. Local Scalars ..
2859 INTEGER I, IC, MI
2860 * .. Save statement ..
2861 SAVE I, IC, MI
2862 * .. Intrinsic Functions ..
2863 INTRINSIC DBLE
2864 * .. Executable Statements ..
2865 IF( RESET )THEN
2866 * Initialize local variables.
2867 MI = 891
2868 I = 7
2869 IC = 0
2870 RESET = .FALSE.
2871 END IF
2872 *
2873 * The sequence of values of I is bounded between 1 and 999.
2874 * If initial I = 1,2,3,6,7 or 9, the period will be 50.
2875 * If initial I = 4 or 8, the period will be 25.
2876 * If initial I = 5, the period will be 10.
2877 * IC is used to break up the period by skipping 1 value of I in 6.
2878 *
2879 IC = IC + 1
2880 10 I = I*MI
2881 I = I - 1000*( I/1000 )
2882 IF( IC.GE.5 )THEN
2883 IC = 0
2884 GO TO 10
2885 END IF
2886 DBEG = DBLE( I - 500 )/1001.0D0
2887 RETURN
2888 *
2889 * End of DBEG.
2890 *
2891 END
2892 DOUBLE PRECISION FUNCTION DDIFF( X, Y )
2893 *
2894 * Auxiliary routine for test program for Level 2 Blas.
2895 *
2896 * -- Written on 10-August-1987.
2897 * Richard Hanson, Sandia National Labs.
2898 *
2899 * .. Scalar Arguments ..
2900 DOUBLE PRECISION X, Y
2901 * .. Executable Statements ..
2902 DDIFF = X - Y
2903 RETURN
2904 *
2905 * End of DDIFF.
2906 *
2907 END