3 * Test program for the REAL Level 2 Blas.
5 * The program must be driven by a short data file. The first 18 records
6 * of the file are read using list-directed input, the last 16 records
7 * are read using the format ( A6, L2 ). An annotated example of a data
8 * file can be obtained by deleting the first 3 characters from the
10 * 'SBLAT2.SUMM' NAME OF SUMMARY OUTPUT FILE
11 * 6 UNIT NUMBER OF SUMMARY FILE
12 * 'SBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE
13 * -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
14 * F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
15 * F LOGICAL FLAG, T TO STOP ON FAILURES.
16 * T LOGICAL FLAG, T TO TEST ERROR EXITS.
17 * 16.0 THRESHOLD VALUE OF TEST RATIO
18 * 6 NUMBER OF VALUES OF N
19 * 0 1 2 3 5 9 VALUES OF N
20 * 4 NUMBER OF VALUES OF K
22 * 4 NUMBER OF VALUES OF INCX AND INCY
23 * 1 2 -1 -2 VALUES OF INCX AND INCY
24 * 3 NUMBER OF VALUES OF ALPHA
25 * 0.0 1.0 0.7 VALUES OF ALPHA
26 * 3 NUMBER OF VALUES OF BETA
27 * 0.0 1.0 0.9 VALUES OF BETA
28 * SGEMV T PUT F FOR NO TEST. SAME COLUMNS.
29 * SGBMV T PUT F FOR NO TEST. SAME COLUMNS.
30 * SSYMV T PUT F FOR NO TEST. SAME COLUMNS.
31 * SSBMV T PUT F FOR NO TEST. SAME COLUMNS.
32 * SSPMV T PUT F FOR NO TEST. SAME COLUMNS.
33 * STRMV T PUT F FOR NO TEST. SAME COLUMNS.
34 * STBMV T PUT F FOR NO TEST. SAME COLUMNS.
35 * STPMV T PUT F FOR NO TEST. SAME COLUMNS.
36 * STRSV T PUT F FOR NO TEST. SAME COLUMNS.
37 * STBSV T PUT F FOR NO TEST. SAME COLUMNS.
38 * STPSV T PUT F FOR NO TEST. SAME COLUMNS.
39 * SGER T PUT F FOR NO TEST. SAME COLUMNS.
40 * SSYR T PUT F FOR NO TEST. SAME COLUMNS.
41 * SSPR T PUT F FOR NO TEST. SAME COLUMNS.
42 * SSYR2 T PUT F FOR NO TEST. SAME COLUMNS.
43 * SSPR2 T PUT F FOR NO TEST. SAME COLUMNS.
47 * Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J..
48 * An extended set of Fortran Basic Linear Algebra Subprograms.
50 * Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics
51 * and Computer Science Division, Argonne National Laboratory,
52 * 9700 South Cass Avenue, Argonne, Illinois 60439, US.
56 * NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms
57 * Group Ltd., NAG Central Office, 256 Banbury Road, Oxford
58 * OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st
59 * Street, Suite 100, Downers Grove, Illinois 60515-1263, USA.
62 * -- Written on 10-August-1987.
63 * Richard Hanson, Sandia National Labs.
64 * Jeremy Du Croz, NAG Central Office.
70 PARAMETER ( NSUBS = 16 )
72 PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
74 PARAMETER ( NMAX = 65, INCMAX = 2 )
75 INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX
76 PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7,
77 $ NALMAX = 7, NBEMAX = 7 )
80 INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB,
82 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
86 CHARACTER*32 SNAPS, SUMMRY
88 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ),
89 $ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ),
90 $ G( NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
91 $ XX( NMAX*INCMAX ), Y( NMAX ),
92 $ YS( NMAX*INCMAX ), YT( NMAX ),
93 $ YY( NMAX*INCMAX ), Z( 2*NMAX )
94 INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX )
95 LOGICAL LTEST( NSUBS )
96 CHARACTER*6 SNAMES( NSUBS )
97 * .. External Functions ..
101 * .. External Subroutines ..
102 EXTERNAL SCHK1, SCHK2, SCHK3, SCHK4, SCHK5, SCHK6,
104 * .. Intrinsic Functions ..
105 INTRINSIC ABS, MAX, MIN
106 * .. Scalars in Common ..
110 * .. Common blocks ..
111 COMMON /INFOC/INFOT, NOUTC, OK, LERR
112 COMMON /SRNAMC/SRNAMT
113 * .. Data statements ..
114 DATA SNAMES/'SGEMV ', 'SGBMV ', 'SSYMV ', 'SSBMV ',
115 $ 'SSPMV ', 'STRMV ', 'STBMV ', 'STPMV ',
116 $ 'STRSV ', 'STBSV ', 'STPSV ', 'SGER ',
117 $ 'SSYR ', 'SSPR ', 'SSYR2 ', 'SSPR2 '/
118 * .. Executable Statements ..
120 * Read name and unit number for summary output file and open file.
122 READ( NIN, FMT = * )SUMMRY
123 READ( NIN, FMT = * )NOUT
124 OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' )
127 * Read name and unit number for snapshot output file and open file.
129 READ( NIN, FMT = * )SNAPS
130 READ( NIN, FMT = * )NTRA
133 OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' )
135 * Read the flag that directs rewinding of the snapshot file.
136 READ( NIN, FMT = * )REWI
137 REWI = REWI.AND.TRACE
138 * Read the flag that directs stopping on any failure.
139 READ( NIN, FMT = * )SFATAL
140 * Read the flag that indicates whether error exits are to be tested.
141 READ( NIN, FMT = * )TSTERR
142 * Read the threshold value of the test ratio
143 READ( NIN, FMT = * )THRESH
145 * Read and check the parameter values for the tests.
148 READ( NIN, FMT = * )NIDIM
149 IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
150 WRITE( NOUT, FMT = 9997 )'N', NIDMAX
153 READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
155 IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
156 WRITE( NOUT, FMT = 9996 )NMAX
161 READ( NIN, FMT = * )NKB
162 IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN
163 WRITE( NOUT, FMT = 9997 )'K', NKBMAX
166 READ( NIN, FMT = * )( KB( I ), I = 1, NKB )
168 IF( KB( I ).LT.0 )THEN
169 WRITE( NOUT, FMT = 9995 )
173 * Values of INCX and INCY
174 READ( NIN, FMT = * )NINC
175 IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN
176 WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX
179 READ( NIN, FMT = * )( INC( I ), I = 1, NINC )
181 IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN
182 WRITE( NOUT, FMT = 9994 )INCMAX
187 READ( NIN, FMT = * )NALF
188 IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
189 WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
192 READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
194 READ( NIN, FMT = * )NBET
195 IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
196 WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
199 READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
201 * Report values of parameters.
203 WRITE( NOUT, FMT = 9993 )
204 WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM )
205 WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB )
206 WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC )
207 WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF )
208 WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET )
209 IF( .NOT.TSTERR )THEN
210 WRITE( NOUT, FMT = * )
211 WRITE( NOUT, FMT = 9980 )
213 WRITE( NOUT, FMT = * )
214 WRITE( NOUT, FMT = 9999 )THRESH
215 WRITE( NOUT, FMT = * )
217 * Read names of subroutines and flags which indicate
218 * whether they are to be tested.
223 50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT
225 IF( SNAMET.EQ.SNAMES( I ) )
228 WRITE( NOUT, FMT = 9986 )SNAMET
230 70 LTEST( I ) = LTESTT
236 * Compute EPS (the machine precision).
240 IF( SDIFF( ONE + EPS, ONE ).EQ.ZERO )
246 WRITE( NOUT, FMT = 9998 )EPS
248 * Check the reliability of SMVCH using exact data.
253 A( I, J ) = MAX( I - J + 1, 0 )
259 YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
261 * YY holds the exact result. On exit from SMVCH YT holds
262 * the result computed by SMVCH.
264 CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G,
265 $ YY, EPS, ERR, FATAL, NOUT, .TRUE. )
266 SAME = LSE( YY, YT, N )
267 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
268 WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
272 CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G,
273 $ YY, EPS, ERR, FATAL, NOUT, .TRUE. )
274 SAME = LSE( YY, YT, N )
275 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
276 WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
280 * Test each subroutine in turn.
282 DO 210 ISNUM = 1, NSUBS
283 WRITE( NOUT, FMT = * )
284 IF( .NOT.LTEST( ISNUM ) )THEN
285 * Subprogram is not to be tested.
286 WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM )
288 SRNAMT = SNAMES( ISNUM )
291 CALL SCHKE( ISNUM, SNAMES( ISNUM ), NOUT )
292 WRITE( NOUT, FMT = * )
298 GO TO ( 140, 140, 150, 150, 150, 160, 160,
299 $ 160, 160, 160, 160, 170, 180, 180,
301 * Test SGEMV, 01, and SGBMV, 02.
302 140 CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
303 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
304 $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
305 $ X, XX, XS, Y, YY, YS, YT, G )
307 * Test SSYMV, 03, SSBMV, 04, and SSPMV, 05.
308 150 CALL SCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
309 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
310 $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
311 $ X, XX, XS, Y, YY, YS, YT, G )
313 * Test STRMV, 06, STBMV, 07, STPMV, 08,
314 * STRSV, 09, STBSV, 10, and STPSV, 11.
315 160 CALL SCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
316 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC,
317 $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z )
320 170 CALL SCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
321 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
322 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
325 * Test SSYR, 13, and SSPR, 14.
326 180 CALL SCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
327 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
328 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
331 * Test SSYR2, 15, and SSPR2, 16.
332 190 CALL SCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
333 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
334 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
337 200 IF( FATAL.AND.SFATAL )
341 WRITE( NOUT, FMT = 9982 )
345 WRITE( NOUT, FMT = 9981 )
349 WRITE( NOUT, FMT = 9987 )
357 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
359 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 )
360 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
362 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
363 9995 FORMAT( ' VALUE OF K IS LESS THAN 0' )
364 9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ',
366 9993 FORMAT( ' TESTS OF THE REAL LEVEL 2 BLAS', //' THE F',
367 $ 'OLLOWING PARAMETER VALUES WILL BE USED:' )
368 9992 FORMAT( ' FOR N ', 9I6 )
369 9991 FORMAT( ' FOR K ', 7I6 )
370 9990 FORMAT( ' FOR INCX AND INCY ', 7I6 )
371 9989 FORMAT( ' FOR ALPHA ', 7F6.1 )
372 9988 FORMAT( ' FOR BETA ', 7F6.1 )
373 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
374 $ /' ******* TESTS ABANDONED *******' )
375 9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T',
376 $ 'ESTS ABANDONED *******' )
377 9985 FORMAT( ' ERROR IN SMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
378 $ 'ATED WRONGLY.', /' SMVCH WAS CALLED WITH TRANS = ', A1,
379 $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', /
380 $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.'
381 $ , /' ******* TESTS ABANDONED *******' )
382 9984 FORMAT( A6, L2 )
383 9983 FORMAT( 1X, A6, ' WAS NOT TESTED' )
384 9982 FORMAT( /' END OF TESTS' )
385 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
386 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
391 SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
392 $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
393 $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
394 $ XS, Y, YY, YS, YT, G )
396 * Tests SGEMV and SGBMV.
398 * Auxiliary routine for test program for Level 2 Blas.
400 * -- Written on 10-August-1987.
401 * Richard Hanson, Sandia National Labs.
402 * Jeremy Du Croz, NAG Central Office.
406 PARAMETER ( ZERO = 0.0, HALF = 0.5 )
407 * .. Scalar Arguments ..
409 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
411 LOGICAL FATAL, REWI, TRACE
413 * .. Array Arguments ..
414 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
415 $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ),
416 $ X( NMAX ), XS( NMAX*INCMAX ),
417 $ XX( NMAX*INCMAX ), Y( NMAX ),
418 $ YS( NMAX*INCMAX ), YT( NMAX ),
420 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
421 * .. Local Scalars ..
422 REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL
423 INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY,
424 $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA,
425 $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK,
427 LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN
428 CHARACTER*1 TRANS, TRANSS
432 * .. External Functions ..
435 * .. External Subroutines ..
436 EXTERNAL SGBMV, SGEMV, SMAKE, SMVCH
437 * .. Intrinsic Functions ..
438 INTRINSIC ABS, MAX, MIN
439 * .. Scalars in Common ..
442 * .. Common blocks ..
443 COMMON /INFOC/INFOT, NOUTC, OK, LERR
444 * .. Data statements ..
446 * .. Executable Statements ..
447 FULL = SNAME( 3: 3 ).EQ.'E'
448 BANDED = SNAME( 3: 3 ).EQ.'B'
449 * Define the number of arguments.
452 ELSE IF( BANDED )THEN
466 $ M = MAX( N - ND, 0 )
468 $ M = MIN( N + ND, NMAX )
478 KL = MAX( KU - 1, 0 )
483 * Set LDA to 1 more than minimum value if room.
491 * Skip tests if not enough room.
495 NULL = N.LE.0.OR.M.LE.0
497 * Generate the matrix A.
500 CALL SMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA,
501 $ LDA, KL, KU, RESET, TRANSL )
504 TRANS = ICH( IC: IC )
505 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
519 * Generate the vector X.
522 CALL SMAKE( 'GE', ' ', ' ', 1, NL, X, 1, XX,
523 $ ABS( INCX ), 0, NL - 1, RESET, TRANSL )
526 XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO
539 * Generate the vector Y.
542 CALL SMAKE( 'GE', ' ', ' ', 1, ML, Y, 1,
543 $ YY, ABS( INCY ), 0, ML - 1,
548 * Save every datum before calling the
571 * Call the subroutine.
575 $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
576 $ TRANS, M, N, ALPHA, LDA, INCX, BETA,
580 CALL SGEMV( TRANS, M, N, ALPHA, AA,
581 $ LDA, XX, INCX, BETA, YY,
583 ELSE IF( BANDED )THEN
585 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
586 $ TRANS, M, N, KL, KU, ALPHA, LDA,
590 CALL SGBMV( TRANS, M, N, KL, KU, ALPHA,
591 $ AA, LDA, XX, INCX, BETA,
595 * Check if error-exit was taken incorrectly.
598 WRITE( NOUT, FMT = 9993 )
603 * See what data changed inside subroutines.
605 ISAME( 1 ) = TRANS.EQ.TRANSS
609 ISAME( 4 ) = ALS.EQ.ALPHA
610 ISAME( 5 ) = LSE( AS, AA, LAA )
611 ISAME( 6 ) = LDAS.EQ.LDA
612 ISAME( 7 ) = LSE( XS, XX, LX )
613 ISAME( 8 ) = INCXS.EQ.INCX
614 ISAME( 9 ) = BLS.EQ.BETA
616 ISAME( 10 ) = LSE( YS, YY, LY )
618 ISAME( 10 ) = LSERES( 'GE', ' ', 1,
622 ISAME( 11 ) = INCYS.EQ.INCY
623 ELSE IF( BANDED )THEN
624 ISAME( 4 ) = KLS.EQ.KL
625 ISAME( 5 ) = KUS.EQ.KU
626 ISAME( 6 ) = ALS.EQ.ALPHA
627 ISAME( 7 ) = LSE( AS, AA, LAA )
628 ISAME( 8 ) = LDAS.EQ.LDA
629 ISAME( 9 ) = LSE( XS, XX, LX )
630 ISAME( 10 ) = INCXS.EQ.INCX
631 ISAME( 11 ) = BLS.EQ.BETA
633 ISAME( 12 ) = LSE( YS, YY, LY )
635 ISAME( 12 ) = LSERES( 'GE', ' ', 1,
639 ISAME( 13 ) = INCYS.EQ.INCY
642 * If data was incorrectly changed, report
647 SAME = SAME.AND.ISAME( I )
648 IF( .NOT.ISAME( I ) )
649 $ WRITE( NOUT, FMT = 9998 )I
660 CALL SMVCH( TRANS, M, N, ALPHA, A,
661 $ NMAX, X, INCX, BETA, Y,
662 $ INCY, YT, G, YY, EPS, ERR,
663 $ FATAL, NOUT, .TRUE. )
664 ERRMAX = MAX( ERRMAX, ERR )
665 * If got really bad answer, report and
670 * Avoid repeating tests with M.le.0 or
693 IF( ERRMAX.LT.THRESH )THEN
694 WRITE( NOUT, FMT = 9999 )SNAME, NC
696 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
701 WRITE( NOUT, FMT = 9996 )SNAME
703 WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA,
705 ELSE IF( BANDED )THEN
706 WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU,
707 $ ALPHA, LDA, INCX, BETA, INCY
713 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
715 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
716 $ 'ANGED INCORRECTLY *******' )
717 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
718 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
719 $ ' - SUSPECT *******' )
720 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
721 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), F4.1,
722 $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' )
723 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1,
724 $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2,
726 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
732 SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
733 $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
734 $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
735 $ XS, Y, YY, YS, YT, G )
737 * Tests SSYMV, SSBMV and SSPMV.
739 * Auxiliary routine for test program for Level 2 Blas.
741 * -- Written on 10-August-1987.
742 * Richard Hanson, Sandia National Labs.
743 * Jeremy Du Croz, NAG Central Office.
747 PARAMETER ( ZERO = 0.0, HALF = 0.5 )
748 * .. Scalar Arguments ..
750 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
752 LOGICAL FATAL, REWI, TRACE
754 * .. Array Arguments ..
755 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
756 $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ),
757 $ X( NMAX ), XS( NMAX*INCMAX ),
758 $ XX( NMAX*INCMAX ), Y( NMAX ),
759 $ YS( NMAX*INCMAX ), YT( NMAX ),
761 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
762 * .. Local Scalars ..
763 REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL
764 INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY,
765 $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY,
766 $ N, NARGS, NC, NK, NS
767 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
768 CHARACTER*1 UPLO, UPLOS
772 * .. External Functions ..
775 * .. External Subroutines ..
776 EXTERNAL SMAKE, SMVCH, SSBMV, SSPMV, SSYMV
777 * .. Intrinsic Functions ..
779 * .. Scalars in Common ..
782 * .. Common blocks ..
783 COMMON /INFOC/INFOT, NOUTC, OK, LERR
784 * .. Data statements ..
786 * .. Executable Statements ..
787 FULL = SNAME( 3: 3 ).EQ.'Y'
788 BANDED = SNAME( 3: 3 ).EQ.'B'
789 PACKED = SNAME( 3: 3 ).EQ.'P'
790 * Define the number of arguments.
793 ELSE IF( BANDED )THEN
795 ELSE IF( PACKED )THEN
817 * Set LDA to 1 more than minimum value if room.
825 * Skip tests if not enough room.
829 LAA = ( N*( N + 1 ) )/2
838 * Generate the matrix A.
841 CALL SMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA,
842 $ LDA, K, K, RESET, TRANSL )
848 * Generate the vector X.
851 CALL SMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX,
852 $ ABS( INCX ), 0, N - 1, RESET, TRANSL )
855 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
868 * Generate the vector Y.
871 CALL SMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
872 $ ABS( INCY ), 0, N - 1, RESET,
877 * Save every datum before calling the
898 * Call the subroutine.
902 $ WRITE( NTRA, FMT = 9993 )NC, SNAME,
903 $ UPLO, N, ALPHA, LDA, INCX, BETA, INCY
906 CALL SSYMV( UPLO, N, ALPHA, AA, LDA, XX,
907 $ INCX, BETA, YY, INCY )
908 ELSE IF( BANDED )THEN
910 $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
911 $ UPLO, N, K, ALPHA, LDA, INCX, BETA,
915 CALL SSBMV( UPLO, N, K, ALPHA, AA, LDA,
916 $ XX, INCX, BETA, YY, INCY )
917 ELSE IF( PACKED )THEN
919 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
920 $ UPLO, N, ALPHA, INCX, BETA, INCY
923 CALL SSPMV( UPLO, N, ALPHA, AA, XX, INCX,
927 * Check if error-exit was taken incorrectly.
930 WRITE( NOUT, FMT = 9992 )
935 * See what data changed inside subroutines.
937 ISAME( 1 ) = UPLO.EQ.UPLOS
940 ISAME( 3 ) = ALS.EQ.ALPHA
941 ISAME( 4 ) = LSE( AS, AA, LAA )
942 ISAME( 5 ) = LDAS.EQ.LDA
943 ISAME( 6 ) = LSE( XS, XX, LX )
944 ISAME( 7 ) = INCXS.EQ.INCX
945 ISAME( 8 ) = BLS.EQ.BETA
947 ISAME( 9 ) = LSE( YS, YY, LY )
949 ISAME( 9 ) = LSERES( 'GE', ' ', 1, N,
950 $ YS, YY, ABS( INCY ) )
952 ISAME( 10 ) = INCYS.EQ.INCY
953 ELSE IF( BANDED )THEN
955 ISAME( 4 ) = ALS.EQ.ALPHA
956 ISAME( 5 ) = LSE( AS, AA, LAA )
957 ISAME( 6 ) = LDAS.EQ.LDA
958 ISAME( 7 ) = LSE( XS, XX, LX )
959 ISAME( 8 ) = INCXS.EQ.INCX
960 ISAME( 9 ) = BLS.EQ.BETA
962 ISAME( 10 ) = LSE( YS, YY, LY )
964 ISAME( 10 ) = LSERES( 'GE', ' ', 1, N,
965 $ YS, YY, ABS( INCY ) )
967 ISAME( 11 ) = INCYS.EQ.INCY
968 ELSE IF( PACKED )THEN
969 ISAME( 3 ) = ALS.EQ.ALPHA
970 ISAME( 4 ) = LSE( AS, AA, LAA )
971 ISAME( 5 ) = LSE( XS, XX, LX )
972 ISAME( 6 ) = INCXS.EQ.INCX
973 ISAME( 7 ) = BLS.EQ.BETA
975 ISAME( 8 ) = LSE( YS, YY, LY )
977 ISAME( 8 ) = LSERES( 'GE', ' ', 1, N,
978 $ YS, YY, ABS( INCY ) )
980 ISAME( 9 ) = INCYS.EQ.INCY
983 * If data was incorrectly changed, report and
988 SAME = SAME.AND.ISAME( I )
989 IF( .NOT.ISAME( I ) )
990 $ WRITE( NOUT, FMT = 9998 )I
1001 CALL SMVCH( 'N', N, N, ALPHA, A, NMAX, X,
1002 $ INCX, BETA, Y, INCY, YT, G,
1003 $ YY, EPS, ERR, FATAL, NOUT,
1005 ERRMAX = MAX( ERRMAX, ERR )
1006 * If got really bad answer, report and
1011 * Avoid repeating tests with N.le.0
1031 IF( ERRMAX.LT.THRESH )THEN
1032 WRITE( NOUT, FMT = 9999 )SNAME, NC
1034 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1039 WRITE( NOUT, FMT = 9996 )SNAME
1041 WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, LDA, INCX,
1043 ELSE IF( BANDED )THEN
1044 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, K, ALPHA, LDA,
1046 ELSE IF( PACKED )THEN
1047 WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, N, ALPHA, INCX,
1054 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1056 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1057 $ 'ANGED INCORRECTLY *******' )
1058 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1059 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1060 $ ' - SUSPECT *******' )
1061 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1062 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', AP',
1063 $ ', X,', I2, ',', F4.1, ', Y,', I2, ') .' )
1064 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1,
1065 $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2,
1067 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', A,',
1068 $ I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' )
1069 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1075 SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1076 $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX,
1077 $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z )
1079 * Tests STRMV, STBMV, STPMV, STRSV, STBSV and STPSV.
1081 * Auxiliary routine for test program for Level 2 Blas.
1083 * -- Written on 10-August-1987.
1084 * Richard Hanson, Sandia National Labs.
1085 * Jeremy Du Croz, NAG Central Office.
1088 REAL ZERO, HALF, ONE
1089 PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
1090 * .. Scalar Arguments ..
1092 INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA
1093 LOGICAL FATAL, REWI, TRACE
1095 * .. Array Arguments ..
1096 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ),
1097 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1098 $ XS( NMAX*INCMAX ), XT( NMAX ),
1099 $ XX( NMAX*INCMAX ), Z( NMAX )
1100 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
1101 * .. Local Scalars ..
1102 REAL ERR, ERRMAX, TRANSL
1103 INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K,
1104 $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS
1105 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
1106 CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS
1107 CHARACTER*2 ICHD, ICHU
1109 * .. Local Arrays ..
1111 * .. External Functions ..
1113 EXTERNAL LSE, LSERES
1114 * .. External Subroutines ..
1115 EXTERNAL SMAKE, SMVCH, STBMV, STBSV, STPMV, STPSV,
1117 * .. Intrinsic Functions ..
1119 * .. Scalars in Common ..
1120 INTEGER INFOT, NOUTC
1122 * .. Common blocks ..
1123 COMMON /INFOC/INFOT, NOUTC, OK, LERR
1124 * .. Data statements ..
1125 DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/
1126 * .. Executable Statements ..
1127 FULL = SNAME( 3: 3 ).EQ.'R'
1128 BANDED = SNAME( 3: 3 ).EQ.'B'
1129 PACKED = SNAME( 3: 3 ).EQ.'P'
1130 * Define the number of arguments.
1133 ELSE IF( BANDED )THEN
1135 ELSE IF( PACKED )THEN
1142 * Set up zero vector for SMVCH.
1147 DO 110 IN = 1, NIDIM
1161 * Set LDA to 1 more than minimum value if room.
1169 * Skip tests if not enough room.
1173 LAA = ( N*( N + 1 ) )/2
1180 UPLO = ICHU( ICU: ICU )
1183 TRANS = ICHT( ICT: ICT )
1186 DIAG = ICHD( ICD: ICD )
1188 * Generate the matrix A.
1191 CALL SMAKE( SNAME( 2: 3 ), UPLO, DIAG, N, N, A,
1192 $ NMAX, AA, LDA, K, K, RESET, TRANSL )
1198 * Generate the vector X.
1201 CALL SMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX,
1202 $ ABS( INCX ), 0, N - 1, RESET,
1206 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
1211 * Save every datum before calling the subroutine.
1227 * Call the subroutine.
1229 IF( SNAME( 4: 5 ).EQ.'MV' )THEN
1232 $ WRITE( NTRA, FMT = 9993 )NC, SNAME,
1233 $ UPLO, TRANS, DIAG, N, LDA, INCX
1236 CALL STRMV( UPLO, TRANS, DIAG, N, AA, LDA,
1238 ELSE IF( BANDED )THEN
1240 $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
1241 $ UPLO, TRANS, DIAG, N, K, LDA, INCX
1244 CALL STBMV( UPLO, TRANS, DIAG, N, K, AA,
1246 ELSE IF( PACKED )THEN
1248 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1249 $ UPLO, TRANS, DIAG, N, INCX
1252 CALL STPMV( UPLO, TRANS, DIAG, N, AA, XX,
1255 ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN
1258 $ WRITE( NTRA, FMT = 9993 )NC, SNAME,
1259 $ UPLO, TRANS, DIAG, N, LDA, INCX
1262 CALL STRSV( UPLO, TRANS, DIAG, N, AA, LDA,
1264 ELSE IF( BANDED )THEN
1266 $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
1267 $ UPLO, TRANS, DIAG, N, K, LDA, INCX
1270 CALL STBSV( UPLO, TRANS, DIAG, N, K, AA,
1272 ELSE IF( PACKED )THEN
1274 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1275 $ UPLO, TRANS, DIAG, N, INCX
1278 CALL STPSV( UPLO, TRANS, DIAG, N, AA, XX,
1283 * Check if error-exit was taken incorrectly.
1286 WRITE( NOUT, FMT = 9992 )
1291 * See what data changed inside subroutines.
1293 ISAME( 1 ) = UPLO.EQ.UPLOS
1294 ISAME( 2 ) = TRANS.EQ.TRANSS
1295 ISAME( 3 ) = DIAG.EQ.DIAGS
1296 ISAME( 4 ) = NS.EQ.N
1298 ISAME( 5 ) = LSE( AS, AA, LAA )
1299 ISAME( 6 ) = LDAS.EQ.LDA
1301 ISAME( 7 ) = LSE( XS, XX, LX )
1303 ISAME( 7 ) = LSERES( 'GE', ' ', 1, N, XS,
1306 ISAME( 8 ) = INCXS.EQ.INCX
1307 ELSE IF( BANDED )THEN
1308 ISAME( 5 ) = KS.EQ.K
1309 ISAME( 6 ) = LSE( AS, AA, LAA )
1310 ISAME( 7 ) = LDAS.EQ.LDA
1312 ISAME( 8 ) = LSE( XS, XX, LX )
1314 ISAME( 8 ) = LSERES( 'GE', ' ', 1, N, XS,
1317 ISAME( 9 ) = INCXS.EQ.INCX
1318 ELSE IF( PACKED )THEN
1319 ISAME( 5 ) = LSE( AS, AA, LAA )
1321 ISAME( 6 ) = LSE( XS, XX, LX )
1323 ISAME( 6 ) = LSERES( 'GE', ' ', 1, N, XS,
1326 ISAME( 7 ) = INCXS.EQ.INCX
1329 * If data was incorrectly changed, report and
1334 SAME = SAME.AND.ISAME( I )
1335 IF( .NOT.ISAME( I ) )
1336 $ WRITE( NOUT, FMT = 9998 )I
1344 IF( SNAME( 4: 5 ).EQ.'MV' )THEN
1348 CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X,
1349 $ INCX, ZERO, Z, INCX, XT, G,
1350 $ XX, EPS, ERR, FATAL, NOUT,
1352 ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN
1354 * Compute approximation to original vector.
1357 Z( I ) = XX( 1 + ( I - 1 )*
1359 XX( 1 + ( I - 1 )*ABS( INCX ) )
1362 CALL SMVCH( TRANS, N, N, ONE, A, NMAX, Z,
1363 $ INCX, ZERO, X, INCX, XT, G,
1364 $ XX, EPS, ERR, FATAL, NOUT,
1367 ERRMAX = MAX( ERRMAX, ERR )
1368 * If got really bad answer, report and return.
1372 * Avoid repeating tests with N.le.0.
1390 IF( ERRMAX.LT.THRESH )THEN
1391 WRITE( NOUT, FMT = 9999 )SNAME, NC
1393 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1398 WRITE( NOUT, FMT = 9996 )SNAME
1400 WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, DIAG, N, LDA,
1402 ELSE IF( BANDED )THEN
1403 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, DIAG, N, K,
1405 ELSE IF( PACKED )THEN
1406 WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANS, DIAG, N, INCX
1412 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1414 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1415 $ 'ANGED INCORRECTLY *******' )
1416 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1417 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1418 $ ' - SUSPECT *******' )
1419 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1420 9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ',
1422 9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ),
1423 $ ' A,', I3, ', X,', I2, ') .' )
1424 9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,',
1425 $ I3, ', X,', I2, ') .' )
1426 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1432 SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1433 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
1434 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
1439 * Auxiliary routine for test program for Level 2 Blas.
1441 * -- Written on 10-August-1987.
1442 * Richard Hanson, Sandia National Labs.
1443 * Jeremy Du Croz, NAG Central Office.
1446 REAL ZERO, HALF, ONE
1447 PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
1448 * .. Scalar Arguments ..
1450 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
1451 LOGICAL FATAL, REWI, TRACE
1453 * .. Array Arguments ..
1454 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1455 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1456 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
1457 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
1458 $ YY( NMAX*INCMAX ), Z( NMAX )
1459 INTEGER IDIM( NIDIM ), INC( NINC )
1460 * .. Local Scalars ..
1461 REAL ALPHA, ALS, ERR, ERRMAX, TRANSL
1462 INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX,
1463 $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS,
1465 LOGICAL NULL, RESET, SAME
1466 * .. Local Arrays ..
1469 * .. External Functions ..
1471 EXTERNAL LSE, LSERES
1472 * .. External Subroutines ..
1473 EXTERNAL SGER, SMAKE, SMVCH
1474 * .. Intrinsic Functions ..
1475 INTRINSIC ABS, MAX, MIN
1476 * .. Scalars in Common ..
1477 INTEGER INFOT, NOUTC
1479 * .. Common blocks ..
1480 COMMON /INFOC/INFOT, NOUTC, OK, LERR
1481 * .. Executable Statements ..
1482 * Define the number of arguments.
1489 DO 120 IN = 1, NIDIM
1495 $ M = MAX( N - ND, 0 )
1497 $ M = MIN( N + ND, NMAX )
1499 * Set LDA to 1 more than minimum value if room.
1503 * Skip tests if not enough room.
1507 NULL = N.LE.0.OR.M.LE.0
1513 * Generate the vector X.
1516 CALL SMAKE( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ),
1517 $ 0, M - 1, RESET, TRANSL )
1520 XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO
1527 * Generate the vector Y.
1530 CALL SMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
1531 $ ABS( INCY ), 0, N - 1, RESET, TRANSL )
1534 YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
1540 * Generate the matrix A.
1543 CALL SMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX,
1544 $ AA, LDA, M - 1, N - 1, RESET, TRANSL )
1548 * Save every datum before calling the subroutine.
1566 * Call the subroutine.
1569 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N,
1570 $ ALPHA, INCX, INCY, LDA
1573 CALL SGER( M, N, ALPHA, XX, INCX, YY, INCY, AA,
1576 * Check if error-exit was taken incorrectly.
1579 WRITE( NOUT, FMT = 9993 )
1584 * See what data changed inside subroutine.
1586 ISAME( 1 ) = MS.EQ.M
1587 ISAME( 2 ) = NS.EQ.N
1588 ISAME( 3 ) = ALS.EQ.ALPHA
1589 ISAME( 4 ) = LSE( XS, XX, LX )
1590 ISAME( 5 ) = INCXS.EQ.INCX
1591 ISAME( 6 ) = LSE( YS, YY, LY )
1592 ISAME( 7 ) = INCYS.EQ.INCY
1594 ISAME( 8 ) = LSE( AS, AA, LAA )
1596 ISAME( 8 ) = LSERES( 'GE', ' ', M, N, AS, AA,
1599 ISAME( 9 ) = LDAS.EQ.LDA
1601 * If data was incorrectly changed, report and return.
1605 SAME = SAME.AND.ISAME( I )
1606 IF( .NOT.ISAME( I ) )
1607 $ WRITE( NOUT, FMT = 9998 )I
1616 * Check the result column by column.
1624 Z( I ) = X( M - I + 1 )
1631 W( 1 ) = Y( N - J + 1 )
1633 CALL SMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1,
1634 $ ONE, A( 1, J ), 1, YT, G,
1635 $ AA( 1 + ( J - 1 )*LDA ), EPS,
1636 $ ERR, FATAL, NOUT, .TRUE. )
1637 ERRMAX = MAX( ERRMAX, ERR )
1638 * If got really bad answer, report and return.
1643 * Avoid repeating tests with M.le.0 or N.le.0.
1659 IF( ERRMAX.LT.THRESH )THEN
1660 WRITE( NOUT, FMT = 9999 )SNAME, NC
1662 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1667 WRITE( NOUT, FMT = 9995 )J
1670 WRITE( NOUT, FMT = 9996 )SNAME
1671 WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA
1676 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1678 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1679 $ 'ANGED INCORRECTLY *******' )
1680 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1681 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1682 $ ' - SUSPECT *******' )
1683 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1684 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
1685 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), F4.1, ', X,', I2,
1686 $ ', Y,', I2, ', A,', I3, ') .' )
1687 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1693 SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1694 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
1695 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
1698 * Tests SSYR and SSPR.
1700 * Auxiliary routine for test program for Level 2 Blas.
1702 * -- Written on 10-August-1987.
1703 * Richard Hanson, Sandia National Labs.
1704 * Jeremy Du Croz, NAG Central Office.
1707 REAL ZERO, HALF, ONE
1708 PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
1709 * .. Scalar Arguments ..
1711 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
1712 LOGICAL FATAL, REWI, TRACE
1714 * .. Array Arguments ..
1715 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1716 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1717 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
1718 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
1719 $ YY( NMAX*INCMAX ), Z( NMAX )
1720 INTEGER IDIM( NIDIM ), INC( NINC )
1721 * .. Local Scalars ..
1722 REAL ALPHA, ALS, ERR, ERRMAX, TRANSL
1723 INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA,
1724 $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS
1725 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
1726 CHARACTER*1 UPLO, UPLOS
1728 * .. Local Arrays ..
1731 * .. External Functions ..
1733 EXTERNAL LSE, LSERES
1734 * .. External Subroutines ..
1735 EXTERNAL SMAKE, SMVCH, SSPR, SSYR
1736 * .. Intrinsic Functions ..
1738 * .. Scalars in Common ..
1739 INTEGER INFOT, NOUTC
1741 * .. Common blocks ..
1742 COMMON /INFOC/INFOT, NOUTC, OK, LERR
1743 * .. Data statements ..
1745 * .. Executable Statements ..
1746 FULL = SNAME( 3: 3 ).EQ.'Y'
1747 PACKED = SNAME( 3: 3 ).EQ.'P'
1748 * Define the number of arguments.
1751 ELSE IF( PACKED )THEN
1759 DO 100 IN = 1, NIDIM
1761 * Set LDA to 1 more than minimum value if room.
1765 * Skip tests if not enough room.
1769 LAA = ( N*( N + 1 ) )/2
1775 UPLO = ICH( IC: IC )
1782 * Generate the vector X.
1785 CALL SMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
1786 $ 0, N - 1, RESET, TRANSL )
1789 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
1794 NULL = N.LE.0.OR.ALPHA.EQ.ZERO
1796 * Generate the matrix A.
1799 CALL SMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX,
1800 $ AA, LDA, N - 1, N - 1, RESET, TRANSL )
1804 * Save every datum before calling the subroutine.
1818 * Call the subroutine.
1822 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N,
1826 CALL SSYR( UPLO, N, ALPHA, XX, INCX, AA, LDA )
1827 ELSE IF( PACKED )THEN
1829 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N,
1833 CALL SSPR( UPLO, N, ALPHA, XX, INCX, AA )
1836 * Check if error-exit was taken incorrectly.
1839 WRITE( NOUT, FMT = 9992 )
1844 * See what data changed inside subroutines.
1846 ISAME( 1 ) = UPLO.EQ.UPLOS
1847 ISAME( 2 ) = NS.EQ.N
1848 ISAME( 3 ) = ALS.EQ.ALPHA
1849 ISAME( 4 ) = LSE( XS, XX, LX )
1850 ISAME( 5 ) = INCXS.EQ.INCX
1852 ISAME( 6 ) = LSE( AS, AA, LAA )
1854 ISAME( 6 ) = LSERES( SNAME( 2: 3 ), UPLO, N, N, AS,
1857 IF( .NOT.PACKED )THEN
1858 ISAME( 7 ) = LDAS.EQ.LDA
1861 * If data was incorrectly changed, report and return.
1865 SAME = SAME.AND.ISAME( I )
1866 IF( .NOT.ISAME( I ) )
1867 $ WRITE( NOUT, FMT = 9998 )I
1876 * Check the result column by column.
1884 Z( I ) = X( N - I + 1 )
1897 CALL SMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W,
1898 $ 1, ONE, A( JJ, J ), 1, YT, G,
1899 $ AA( JA ), EPS, ERR, FATAL, NOUT,
1910 ERRMAX = MAX( ERRMAX, ERR )
1911 * If got really bad answer, report and return.
1916 * Avoid repeating tests if N.le.0.
1931 IF( ERRMAX.LT.THRESH )THEN
1932 WRITE( NOUT, FMT = 9999 )SNAME, NC
1934 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1939 WRITE( NOUT, FMT = 9995 )J
1942 WRITE( NOUT, FMT = 9996 )SNAME
1944 WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, LDA
1945 ELSE IF( PACKED )THEN
1946 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX
1952 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1954 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1955 $ 'ANGED INCORRECTLY *******' )
1956 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1957 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1958 $ ' - SUSPECT *******' )
1959 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1960 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
1961 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
1963 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
1964 $ I2, ', A,', I3, ') .' )
1965 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1971 SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1972 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
1973 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
1976 * Tests SSYR2 and SSPR2.
1978 * Auxiliary routine for test program for Level 2 Blas.
1980 * -- Written on 10-August-1987.
1981 * Richard Hanson, Sandia National Labs.
1982 * Jeremy Du Croz, NAG Central Office.
1985 REAL ZERO, HALF, ONE
1986 PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
1987 * .. Scalar Arguments ..
1989 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
1990 LOGICAL FATAL, REWI, TRACE
1992 * .. Array Arguments ..
1993 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1994 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1995 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
1996 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
1997 $ YY( NMAX*INCMAX ), Z( NMAX, 2 )
1998 INTEGER IDIM( NIDIM ), INC( NINC )
1999 * .. Local Scalars ..
2000 REAL ALPHA, ALS, ERR, ERRMAX, TRANSL
2001 INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX,
2002 $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N,
2004 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
2005 CHARACTER*1 UPLO, UPLOS
2007 * .. Local Arrays ..
2010 * .. External Functions ..
2012 EXTERNAL LSE, LSERES
2013 * .. External Subroutines ..
2014 EXTERNAL SMAKE, SMVCH, SSPR2, SSYR2
2015 * .. Intrinsic Functions ..
2017 * .. Scalars in Common ..
2018 INTEGER INFOT, NOUTC
2020 * .. Common blocks ..
2021 COMMON /INFOC/INFOT, NOUTC, OK, LERR
2022 * .. Data statements ..
2024 * .. Executable Statements ..
2025 FULL = SNAME( 3: 3 ).EQ.'Y'
2026 PACKED = SNAME( 3: 3 ).EQ.'P'
2027 * Define the number of arguments.
2030 ELSE IF( PACKED )THEN
2038 DO 140 IN = 1, NIDIM
2040 * Set LDA to 1 more than minimum value if room.
2044 * Skip tests if not enough room.
2048 LAA = ( N*( N + 1 ) )/2
2054 UPLO = ICH( IC: IC )
2061 * Generate the vector X.
2064 CALL SMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
2065 $ 0, N - 1, RESET, TRANSL )
2068 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
2075 * Generate the vector Y.
2078 CALL SMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
2079 $ ABS( INCY ), 0, N - 1, RESET, TRANSL )
2082 YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
2087 NULL = N.LE.0.OR.ALPHA.EQ.ZERO
2089 * Generate the matrix A.
2092 CALL SMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A,
2093 $ NMAX, AA, LDA, N - 1, N - 1, RESET,
2098 * Save every datum before calling the subroutine.
2116 * Call the subroutine.
2120 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N,
2121 $ ALPHA, INCX, INCY, LDA
2124 CALL SSYR2( UPLO, N, ALPHA, XX, INCX, YY, INCY,
2126 ELSE IF( PACKED )THEN
2128 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N,
2132 CALL SSPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY,
2136 * Check if error-exit was taken incorrectly.
2139 WRITE( NOUT, FMT = 9992 )
2144 * See what data changed inside subroutines.
2146 ISAME( 1 ) = UPLO.EQ.UPLOS
2147 ISAME( 2 ) = NS.EQ.N
2148 ISAME( 3 ) = ALS.EQ.ALPHA
2149 ISAME( 4 ) = LSE( XS, XX, LX )
2150 ISAME( 5 ) = INCXS.EQ.INCX
2151 ISAME( 6 ) = LSE( YS, YY, LY )
2152 ISAME( 7 ) = INCYS.EQ.INCY
2154 ISAME( 8 ) = LSE( AS, AA, LAA )
2156 ISAME( 8 ) = LSERES( SNAME( 2: 3 ), UPLO, N, N,
2159 IF( .NOT.PACKED )THEN
2160 ISAME( 9 ) = LDAS.EQ.LDA
2163 * If data was incorrectly changed, report and return.
2167 SAME = SAME.AND.ISAME( I )
2168 IF( .NOT.ISAME( I ) )
2169 $ WRITE( NOUT, FMT = 9998 )I
2178 * Check the result column by column.
2186 Z( I, 1 ) = X( N - I + 1 )
2195 Z( I, 2 ) = Y( N - I + 1 )
2209 CALL SMVCH( 'N', LJ, 2, ALPHA, Z( JJ, 1 ),
2210 $ NMAX, W, 1, ONE, A( JJ, J ), 1,
2211 $ YT, G, AA( JA ), EPS, ERR, FATAL,
2222 ERRMAX = MAX( ERRMAX, ERR )
2223 * If got really bad answer, report and return.
2228 * Avoid repeating tests with N.le.0.
2245 IF( ERRMAX.LT.THRESH )THEN
2246 WRITE( NOUT, FMT = 9999 )SNAME, NC
2248 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
2253 WRITE( NOUT, FMT = 9995 )J
2256 WRITE( NOUT, FMT = 9996 )SNAME
2258 WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX,
2260 ELSE IF( PACKED )THEN
2261 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX, INCY
2267 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
2269 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
2270 $ 'ANGED INCORRECTLY *******' )
2271 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
2272 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
2273 $ ' - SUSPECT *******' )
2274 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
2275 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
2276 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
2277 $ I2, ', Y,', I2, ', AP) .' )
2278 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
2279 $ I2, ', Y,', I2, ', A,', I3, ') .' )
2280 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2286 SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT )
2288 * Tests the error exits from the Level 2 Blas.
2289 * Requires a special version of the error-handling routine XERBLA.
2290 * ALPHA, BETA, A, X and Y should not need to be defined.
2292 * Auxiliary routine for test program for Level 2 Blas.
2294 * -- Written on 10-August-1987.
2295 * Richard Hanson, Sandia National Labs.
2296 * Jeremy Du Croz, NAG Central Office.
2298 * .. Scalar Arguments ..
2301 * .. Scalars in Common ..
2302 INTEGER INFOT, NOUTC
2304 * .. Local Scalars ..
2306 * .. Local Arrays ..
2307 REAL A( 1, 1 ), X( 1 ), Y( 1 )
2308 * .. External Subroutines ..
2309 EXTERNAL CHKXER, SGBMV, SGEMV, SGER, SSBMV, SSPMV, SSPR,
2310 $ SSPR2, SSYMV, SSYR, SSYR2, STBMV, STBSV, STPMV,
2311 $ STPSV, STRMV, STRSV
2312 * .. Common blocks ..
2313 COMMON /INFOC/INFOT, NOUTC, OK, LERR
2314 * .. Executable Statements ..
2315 * OK is set to .FALSE. by the special version of XERBLA or by CHKXER
2316 * if anything is wrong.
2318 * LERR is set to .TRUE. by the special version of XERBLA each time
2319 * it is called, and is then tested and re-set by CHKXER.
2321 GO TO ( 10, 20, 30, 40, 50, 60, 70, 80,
2322 $ 90, 100, 110, 120, 130, 140, 150,
2325 CALL SGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2326 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2328 CALL SGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2329 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2331 CALL SGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2332 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2334 CALL SGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2335 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2337 CALL SGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
2338 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2340 CALL SGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
2341 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2344 CALL SGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2345 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2347 CALL SGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2348 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2350 CALL SGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2351 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2353 CALL SGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2354 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2356 CALL SGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2357 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2359 CALL SGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2360 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2362 CALL SGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
2363 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2365 CALL SGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
2366 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2369 CALL SSYMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2370 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2372 CALL SSYMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2373 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2375 CALL SSYMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2376 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2378 CALL SSYMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
2379 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2381 CALL SSYMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
2382 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2385 CALL SSBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2386 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2388 CALL SSBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2389 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2391 CALL SSBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2392 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2394 CALL SSBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2395 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2397 CALL SSBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
2398 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2400 CALL SSBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
2401 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2404 CALL SSPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 )
2405 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2407 CALL SSPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 )
2408 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2410 CALL SSPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 )
2411 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2413 CALL SSPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 )
2414 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2417 CALL STRMV( '/', 'N', 'N', 0, A, 1, X, 1 )
2418 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2420 CALL STRMV( 'U', '/', 'N', 0, A, 1, X, 1 )
2421 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2423 CALL STRMV( 'U', 'N', '/', 0, A, 1, X, 1 )
2424 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2426 CALL STRMV( 'U', 'N', 'N', -1, A, 1, X, 1 )
2427 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2429 CALL STRMV( 'U', 'N', 'N', 2, A, 1, X, 1 )
2430 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2432 CALL STRMV( 'U', 'N', 'N', 0, A, 1, X, 0 )
2433 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2436 CALL STBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 )
2437 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2439 CALL STBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 )
2440 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2442 CALL STBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 )
2443 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2445 CALL STBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 )
2446 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2448 CALL STBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 )
2449 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2451 CALL STBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 )
2452 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2454 CALL STBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 )
2455 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2458 CALL STPMV( '/', 'N', 'N', 0, A, X, 1 )
2459 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2461 CALL STPMV( 'U', '/', 'N', 0, A, X, 1 )
2462 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2464 CALL STPMV( 'U', 'N', '/', 0, A, X, 1 )
2465 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2467 CALL STPMV( 'U', 'N', 'N', -1, A, X, 1 )
2468 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2470 CALL STPMV( 'U', 'N', 'N', 0, A, X, 0 )
2471 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2474 CALL STRSV( '/', 'N', 'N', 0, A, 1, X, 1 )
2475 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2477 CALL STRSV( 'U', '/', 'N', 0, A, 1, X, 1 )
2478 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2480 CALL STRSV( 'U', 'N', '/', 0, A, 1, X, 1 )
2481 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2483 CALL STRSV( 'U', 'N', 'N', -1, A, 1, X, 1 )
2484 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2486 CALL STRSV( 'U', 'N', 'N', 2, A, 1, X, 1 )
2487 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2489 CALL STRSV( 'U', 'N', 'N', 0, A, 1, X, 0 )
2490 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2493 CALL STBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 )
2494 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2496 CALL STBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 )
2497 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2499 CALL STBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 )
2500 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2502 CALL STBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 )
2503 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2505 CALL STBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 )
2506 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2508 CALL STBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 )
2509 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2511 CALL STBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 )
2512 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2515 CALL STPSV( '/', 'N', 'N', 0, A, X, 1 )
2516 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2518 CALL STPSV( 'U', '/', 'N', 0, A, X, 1 )
2519 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2521 CALL STPSV( 'U', 'N', '/', 0, A, X, 1 )
2522 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2524 CALL STPSV( 'U', 'N', 'N', -1, A, X, 1 )
2525 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2527 CALL STPSV( 'U', 'N', 'N', 0, A, X, 0 )
2528 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2531 CALL SGER( -1, 0, ALPHA, X, 1, Y, 1, A, 1 )
2532 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2534 CALL SGER( 0, -1, ALPHA, X, 1, Y, 1, A, 1 )
2535 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2537 CALL SGER( 0, 0, ALPHA, X, 0, Y, 1, A, 1 )
2538 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2540 CALL SGER( 0, 0, ALPHA, X, 1, Y, 0, A, 1 )
2541 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2543 CALL SGER( 2, 0, ALPHA, X, 1, Y, 1, A, 1 )
2544 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2547 CALL SSYR( '/', 0, ALPHA, X, 1, A, 1 )
2548 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2550 CALL SSYR( 'U', -1, ALPHA, X, 1, A, 1 )
2551 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2553 CALL SSYR( 'U', 0, ALPHA, X, 0, A, 1 )
2554 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2556 CALL SSYR( 'U', 2, ALPHA, X, 1, A, 1 )
2557 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2560 CALL SSPR( '/', 0, ALPHA, X, 1, A )
2561 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2563 CALL SSPR( 'U', -1, ALPHA, X, 1, A )
2564 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2566 CALL SSPR( 'U', 0, ALPHA, X, 0, A )
2567 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2570 CALL SSYR2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 )
2571 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2573 CALL SSYR2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 )
2574 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2576 CALL SSYR2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 )
2577 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2579 CALL SSYR2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 )
2580 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2582 CALL SSYR2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 )
2583 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2586 CALL SSPR2( '/', 0, ALPHA, X, 1, Y, 1, A )
2587 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2589 CALL SSPR2( 'U', -1, ALPHA, X, 1, Y, 1, A )
2590 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2592 CALL SSPR2( 'U', 0, ALPHA, X, 0, Y, 1, A )
2593 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2595 CALL SSPR2( 'U', 0, ALPHA, X, 1, Y, 0, A )
2596 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2599 WRITE( NOUT, FMT = 9999 )SRNAMT
2601 WRITE( NOUT, FMT = 9998 )SRNAMT
2605 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' )
2606 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****',
2612 SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL,
2613 $ KU, RESET, TRANSL )
2615 * Generates values for an M by N matrix A within the bandwidth
2616 * defined by KL and KU.
2617 * Stores the values in the array AA in the data structure required
2618 * by the routine, with unwanted elements set to rogue value.
2620 * TYPE is 'GE', 'GB', 'SY', 'SB', 'SP', 'TR', 'TB' OR 'TP'.
2622 * Auxiliary routine for test program for Level 2 Blas.
2624 * -- Written on 10-August-1987.
2625 * Richard Hanson, Sandia National Labs.
2626 * Jeremy Du Croz, NAG Central Office.
2630 PARAMETER ( ZERO = 0.0, ONE = 1.0 )
2632 PARAMETER ( ROGUE = -1.0E10 )
2633 * .. Scalar Arguments ..
2635 INTEGER KL, KU, LDA, M, N, NMAX
2637 CHARACTER*1 DIAG, UPLO
2639 * .. Array Arguments ..
2640 REAL A( NMAX, * ), AA( * )
2641 * .. Local Scalars ..
2642 INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, KK
2643 LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
2644 * .. External Functions ..
2647 * .. Intrinsic Functions ..
2649 * .. Executable Statements ..
2650 GEN = TYPE( 1: 1 ).EQ.'G'
2651 SYM = TYPE( 1: 1 ).EQ.'S'
2652 TRI = TYPE( 1: 1 ).EQ.'T'
2653 UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U'
2654 LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L'
2655 UNIT = TRI.AND.DIAG.EQ.'U'
2657 * Generate data in array A.
2661 IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
2663 IF( ( I.LE.J.AND.J - I.LE.KU ).OR.
2664 $ ( I.GE.J.AND.I - J.LE.KL ) )THEN
2665 A( I, J ) = SBEG( RESET ) + TRANSL
2671 A( J, I ) = A( I, J )
2679 $ A( J, J ) = A( J, J ) + ONE
2684 * Store elements in array AS in data structure required by routine.
2686 IF( TYPE.EQ.'GE' )THEN
2689 AA( I + ( J - 1 )*LDA ) = A( I, J )
2691 DO 40 I = M + 1, LDA
2692 AA( I + ( J - 1 )*LDA ) = ROGUE
2695 ELSE IF( TYPE.EQ.'GB' )THEN
2697 DO 60 I1 = 1, KU + 1 - J
2698 AA( I1 + ( J - 1 )*LDA ) = ROGUE
2700 DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J )
2701 AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J )
2704 AA( I3 + ( J - 1 )*LDA ) = ROGUE
2707 ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN
2724 DO 100 I = 1, IBEG - 1
2725 AA( I + ( J - 1 )*LDA ) = ROGUE
2727 DO 110 I = IBEG, IEND
2728 AA( I + ( J - 1 )*LDA ) = A( I, J )
2730 DO 120 I = IEND + 1, LDA
2731 AA( I + ( J - 1 )*LDA ) = ROGUE
2734 ELSE IF( TYPE.EQ.'SB'.OR.TYPE.EQ.'TB' )THEN
2738 IBEG = MAX( 1, KL + 2 - J )
2751 IEND = MIN( KL + 1, 1 + M - J )
2753 DO 140 I = 1, IBEG - 1
2754 AA( I + ( J - 1 )*LDA ) = ROGUE
2756 DO 150 I = IBEG, IEND
2757 AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J )
2759 DO 160 I = IEND + 1, LDA
2760 AA( I + ( J - 1 )*LDA ) = ROGUE
2763 ELSE IF( TYPE.EQ.'SP'.OR.TYPE.EQ.'TP' )THEN
2773 DO 180 I = IBEG, IEND
2775 AA( IOFF ) = A( I, J )
2778 $ AA( IOFF ) = ROGUE
2788 SUBROUTINE SMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y,
2789 $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV )
2791 * Checks the results of the computational tests.
2793 * Auxiliary routine for test program for Level 2 Blas.
2795 * -- Written on 10-August-1987.
2796 * Richard Hanson, Sandia National Labs.
2797 * Jeremy Du Croz, NAG Central Office.
2801 PARAMETER ( ZERO = 0.0, ONE = 1.0 )
2802 * .. Scalar Arguments ..
2803 REAL ALPHA, BETA, EPS, ERR
2804 INTEGER INCX, INCY, M, N, NMAX, NOUT
2807 * .. Array Arguments ..
2808 REAL A( NMAX, * ), G( * ), X( * ), Y( * ), YT( * ),
2810 * .. Local Scalars ..
2812 INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL
2814 * .. Intrinsic Functions ..
2815 INTRINSIC ABS, MAX, SQRT
2816 * .. Executable Statements ..
2817 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
2840 * Compute expected result in YT using data in A, X and Y.
2841 * Compute gauges in G.
2850 YT( IY ) = YT( IY ) + A( J, I )*X( JX )
2851 G( IY ) = G( IY ) + ABS( A( J, I )*X( JX ) )
2856 YT( IY ) = YT( IY ) + A( I, J )*X( JX )
2857 G( IY ) = G( IY ) + ABS( A( I, J )*X( JX ) )
2861 YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY )
2862 G( IY ) = ABS( ALPHA )*G( IY ) + ABS( BETA*Y( IY ) )
2866 * Compute the error ratio for this result.
2870 ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS
2871 IF( G( I ).NE.ZERO )
2872 $ ERRI = ERRI/G( I )
2873 ERR = MAX( ERR, ERRI )
2874 IF( ERR*SQRT( EPS ).GE.ONE )
2877 * If the loop completes, all results are at least half accurate.
2880 * Report fatal error.
2883 WRITE( NOUT, FMT = 9999 )
2886 WRITE( NOUT, FMT = 9998 )I, YT( I ),
2887 $ YY( 1 + ( I - 1 )*ABS( INCY ) )
2889 WRITE( NOUT, FMT = 9998 )I,
2890 $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT(I)
2897 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2898 $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
2900 9998 FORMAT( 1X, I7, 2G18.6 )
2905 LOGICAL FUNCTION LSE( RI, RJ, LR )
2907 * Tests if two arrays are identical.
2909 * Auxiliary routine for test program for Level 2 Blas.
2911 * -- Written on 10-August-1987.
2912 * Richard Hanson, Sandia National Labs.
2913 * Jeremy Du Croz, NAG Central Office.
2915 * .. Scalar Arguments ..
2917 * .. Array Arguments ..
2918 REAL RI( * ), RJ( * )
2919 * .. Local Scalars ..
2921 * .. Executable Statements ..
2923 IF( RI( I ).NE.RJ( I ) )
2935 LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA )
2937 * Tests if selected elements in two arrays are equal.
2939 * TYPE is 'GE', 'SY' or 'SP'.
2941 * Auxiliary routine for test program for Level 2 Blas.
2943 * -- Written on 10-August-1987.
2944 * Richard Hanson, Sandia National Labs.
2945 * Jeremy Du Croz, NAG Central Office.
2947 * .. Scalar Arguments ..
2951 * .. Array Arguments ..
2952 REAL AA( LDA, * ), AS( LDA, * )
2953 * .. Local Scalars ..
2954 INTEGER I, IBEG, IEND, J
2956 * .. Executable Statements ..
2958 IF( TYPE.EQ.'GE' )THEN
2960 DO 10 I = M + 1, LDA
2961 IF( AA( I, J ).NE.AS( I, J ) )
2965 ELSE IF( TYPE.EQ.'SY' )THEN
2974 DO 30 I = 1, IBEG - 1
2975 IF( AA( I, J ).NE.AS( I, J ) )
2978 DO 40 I = IEND + 1, LDA
2979 IF( AA( I, J ).NE.AS( I, J ) )
2995 REAL FUNCTION SBEG( RESET )
2997 * Generates random numbers uniformly distributed between -0.5 and 0.5.
2999 * Auxiliary routine for test program for Level 2 Blas.
3001 * -- Written on 10-August-1987.
3002 * Richard Hanson, Sandia National Labs.
3003 * Jeremy Du Croz, NAG Central Office.
3005 * .. Scalar Arguments ..
3007 * .. Local Scalars ..
3009 * .. Save statement ..
3011 * .. Intrinsic Functions ..
3013 * .. Executable Statements ..
3015 * Initialize local variables.
3022 * The sequence of values of I is bounded between 1 and 999.
3023 * If initial I = 1,2,3,6,7 or 9, the period will be 50.
3024 * If initial I = 4 or 8, the period will be 25.
3025 * If initial I = 5, the period will be 10.
3026 * IC is used to break up the period by skipping 1 value of I in 6.
3030 I = I - 1000*( I/1000 )
3035 SBEG = REAL( I - 500 )/1001.0
3041 REAL FUNCTION SDIFF( X, Y )
3043 * Auxiliary routine for test program for Level 2 Blas.
3045 * -- Written on 10-August-1987.
3046 * Richard Hanson, Sandia National Labs.
3048 * .. Scalar Arguments ..
3050 * .. Executable Statements ..
3057 SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
3059 * Tests whether XERBLA has detected an error when it should.
3061 * Auxiliary routine for test program for Level 2 Blas.
3063 * -- Written on 10-August-1987.
3064 * Richard Hanson, Sandia National Labs.
3065 * Jeremy Du Croz, NAG Central Office.
3067 * .. Scalar Arguments ..
3071 * .. Executable Statements ..
3073 WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
3079 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D',
3080 $ 'ETECTED BY ', A6, ' *****' )
3085 SUBROUTINE XERBLA( SRNAME, INFO )
3087 * This is a special version of XERBLA to be used only as part of
3088 * the test program for testing error exits from the Level 2 BLAS
3091 * XERBLA is an error handler for the Level 2 BLAS routines.
3093 * It is called by the Level 2 BLAS routines if an input parameter is
3096 * Auxiliary routine for test program for Level 2 Blas.
3098 * -- Written on 10-August-1987.
3099 * Richard Hanson, Sandia National Labs.
3100 * Jeremy Du Croz, NAG Central Office.
3102 * .. Scalar Arguments ..
3105 * .. Scalars in Common ..
3109 * .. Common blocks ..
3110 COMMON /INFOC/INFOT, NOUT, OK, LERR
3111 COMMON /SRNAMC/SRNAMT
3112 * .. Executable Statements ..
3114 IF( INFO.NE.INFOT )THEN
3115 IF( INFOT.NE.0 )THEN
3116 WRITE( NOUT, FMT = 9999 )INFO, INFOT
3118 WRITE( NOUT, FMT = 9997 )INFO
3122 IF( SRNAME.NE.SRNAMT )THEN
3123 WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
3128 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD',
3129 $ ' OF ', I2, ' *******' )
3130 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE',
3131 $ 'AD OF ', A6, ' *******' )
3132 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6,