3 * Test program for the REAL Level 2 Blas.
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
10 * 'SBLAT2.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
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_sgemv T PUT F FOR NO TEST. SAME COLUMNS.
28 * cblas_sgbmv T PUT F FOR NO TEST. SAME COLUMNS.
29 * cblas_ssymv T PUT F FOR NO TEST. SAME COLUMNS.
30 * cblas_ssbmv T PUT F FOR NO TEST. SAME COLUMNS.
31 * cblas_sspmv T PUT F FOR NO TEST. SAME COLUMNS.
32 * cblas_strmv T PUT F FOR NO TEST. SAME COLUMNS.
33 * cblas_stbmv T PUT F FOR NO TEST. SAME COLUMNS.
34 * cblas_stpmv T PUT F FOR NO TEST. SAME COLUMNS.
35 * cblas_strsv T PUT F FOR NO TEST. SAME COLUMNS.
36 * cblas_stbsv T PUT F FOR NO TEST. SAME COLUMNS.
37 * cblas_stpsv T PUT F FOR NO TEST. SAME COLUMNS.
38 * cblas_sger T PUT F FOR NO TEST. SAME COLUMNS.
39 * cblas_ssyr T PUT F FOR NO TEST. SAME COLUMNS.
40 * cblas_sspr T PUT F FOR NO TEST. SAME COLUMNS.
41 * cblas_ssyr2 T PUT F FOR NO TEST. SAME COLUMNS.
42 * cblas_sspr2 T PUT F FOR NO TEST. SAME COLUMNS.
46 * Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J..
47 * An extended set of Fortran Basic Linear Algebra Subprograms.
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.
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.
61 * -- Written on 10-August-1987.
62 * Richard Hanson, Sandia National Labs.
63 * Jeremy Du Croz, NAG Central Office.
67 PARAMETER ( NIN = 5, NOUT = 6 )
69 PARAMETER ( NSUBS = 16 )
71 PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
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 )
79 INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB,
81 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
82 $ TSTERR, CORDER, RORDER
87 REAL 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 ..
100 * .. External Subroutines ..
101 EXTERNAL SCHK1, SCHK2, SCHK3, SCHK4, SCHK5, SCHK6,
103 * .. Intrinsic Functions ..
104 INTRINSIC ABS, MAX, MIN
105 * .. Scalars in Common ..
109 * .. Common blocks ..
110 COMMON /INFOC/INFOT, NOUTC, OK
111 COMMON /SRNAMC/SRNAMT
112 * .. Data statements ..
113 DATA SNAMES/'cblas_sgemv ', 'cblas_sgbmv ',
114 $ 'cblas_ssymv ','cblas_ssbmv ','cblas_sspmv ',
115 $ 'cblas_strmv ','cblas_stbmv ','cblas_stpmv ',
116 $ 'cblas_strsv ','cblas_stbsv ','cblas_stpsv ',
117 $ 'cblas_sger ','cblas_ssyr ','cblas_sspr ',
118 $ 'cblas_ssyr2 ','cblas_sspr2 '/
119 * .. Executable Statements ..
123 * Read name and unit number for snapshot output file and open file.
125 READ( NIN, FMT = * )SNAPS
126 READ( NIN, FMT = * )NTRA
129 OPEN( NTRA, FILE = SNAPS )
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
143 * Read and check the parameter values for the tests.
146 READ( NIN, FMT = * )NIDIM
147 IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
148 WRITE( NOUT, FMT = 9997 )'N', NIDMAX
151 READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
153 IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
154 WRITE( NOUT, FMT = 9996 )NMAX
159 READ( NIN, FMT = * )NKB
160 IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN
161 WRITE( NOUT, FMT = 9997 )'K', NKBMAX
164 READ( NIN, FMT = * )( KB( I ), I = 1, NKB )
166 IF( KB( I ).LT.0 )THEN
167 WRITE( NOUT, FMT = 9995 )
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
177 READ( NIN, FMT = * )( INC( I ), I = 1, NINC )
179 IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN
180 WRITE( NOUT, FMT = 9994 )INCMAX
185 READ( NIN, FMT = * )NALF
186 IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
187 WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
190 READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
192 READ( NIN, FMT = * )NBET
193 IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
194 WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
197 READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
199 * Report values of parameters.
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 )
211 WRITE( NOUT, FMT = * )
212 WRITE( NOUT, FMT = 9999 )THRESH
213 WRITE( NOUT, FMT = * )
217 IF (LAYOUT.EQ.2) THEN
220 WRITE( *, FMT = 10002 )
221 ELSE IF (LAYOUT.EQ.1) THEN
223 WRITE( *, FMT = 10001 )
224 ELSE IF (LAYOUT.EQ.0) THEN
226 WRITE( *, FMT = 10000 )
230 * Read names of subroutines and flags which indicate
231 * whether they are to be tested.
236 50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT
238 IF( SNAMET.EQ.SNAMES( I ) )
241 WRITE( NOUT, FMT = 9986 )SNAMET
243 70 LTEST( I ) = LTESTT
249 * Compute EPS (the machine precision).
253 IF( SDIFF( ONE + EPS, ONE ).EQ.ZERO )
259 WRITE( NOUT, FMT = 9998 )EPS
261 * Check the reliability of SMVCH using exact data.
266 A( I, J ) = MAX( I - J + 1, 0 )
272 YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
274 * YY holds the exact result. On exit from SMVCH YT holds
275 * the result computed by SMVCH.
277 CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G,
278 $ YY, EPS, ERR, FATAL, NOUT, .TRUE. )
279 SAME = LSE( YY, YT, N )
280 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
281 WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
285 CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G,
286 $ YY, EPS, ERR, FATAL, NOUT, .TRUE. )
287 SAME = LSE( YY, YT, N )
288 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
289 WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
293 * Test each subroutine in turn.
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 )
301 SRNAMT = SNAMES( ISNUM )
304 CALL CS2CHKE( SNAMES( ISNUM ) )
305 WRITE( NOUT, FMT = * )
311 GO TO ( 140, 140, 150, 150, 150, 160, 160,
312 $ 160, 160, 160, 160, 170, 180, 180,
314 * Test SGEMV, 01, and SGBMV, 02.
316 CALL SCHK1( 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 )
322 CALL SCHK1( 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 )
328 * Test SSYMV, 03, SSBMV, 04, and SSPMV, 05.
330 CALL SCHK2( 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 )
336 CALL SCHK2( 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 )
342 * Test STRMV, 06, STBMV, 07, STPMV, 08,
343 * STRSV, 09, STBSV, 10, and STPSV, 11.
345 CALL SCHK3( 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,
351 CALL SCHK3( 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,
359 CALL SCHK4( 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,
365 CALL SCHK4( 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,
371 * Test SSYR, 13, and SSPR, 14.
373 CALL SCHK5( 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,
379 CALL SCHK5( 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,
385 * Test SSYR2, 15, and SSPR2, 16.
387 CALL SCHK6( 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,
393 CALL SCHK6( 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,
399 200 IF( FATAL.AND.SFATAL )
403 WRITE( NOUT, FMT = 9982 )
407 WRITE( NOUT, FMT = 9981 )
411 WRITE( NOUT, FMT = 9987 )
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',
424 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 )
425 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
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 ',
431 9993 FORMAT( ' TESTS OF THE REAL 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 SMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
443 $ 'ATED WRONGLY.', /' SMVCH 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' )
456 SUBROUTINE SCHK1( 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 )
461 * Tests SGEMV and SGBMV.
463 * Auxiliary routine for test program for Level 2 Blas.
465 * -- Written on 10-August-1987.
466 * Richard Hanson, Sandia National Labs.
467 * Jeremy Du Croz, NAG Central Office.
471 PARAMETER ( ZERO = 0.0, HALF = 0.5 )
472 * .. Scalar Arguments ..
474 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
476 LOGICAL FATAL, REWI, TRACE
478 * .. Array Arguments ..
479 REAL 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 ),
485 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
486 * .. Local Scalars ..
487 REAL 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,
492 LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN
493 CHARACTER*1 TRANS, TRANSS
498 * .. External Functions ..
501 * .. External Subroutines ..
502 EXTERNAL CSGBMV, CSGEMV, SMAKE, SMVCH
503 * .. Intrinsic Functions ..
504 INTRINSIC ABS, MAX, MIN
505 * .. Scalars in Common ..
508 * .. Common blocks ..
509 COMMON /INFOC/INFOT, NOUTC, OK
510 * .. Data statements ..
512 * .. Executable Statements ..
513 FULL = SNAME( 9: 9 ).EQ.'e'
514 BANDED = SNAME( 9: 9 ).EQ.'b'
515 * Define the number of arguments.
518 ELSE IF( BANDED )THEN
532 $ M = MAX( N - ND, 0 )
534 $ M = MIN( N + ND, NMAX )
544 KL = MAX( KU - 1, 0 )
549 * Set LDA to 1 more than minimum value if room.
557 * Skip tests if not enough room.
561 NULL = N.LE.0.OR.M.LE.0
563 * Generate the matrix A.
566 CALL SMAKE( SNAME( 8: 9 ), ' ', ' ', M, N, A, NMAX, AA,
567 $ LDA, KL, KU, RESET, TRANSL )
570 TRANS = ICH( IC: IC )
571 IF (TRANS.EQ.'N')THEN
572 CTRANS = ' CblasNoTrans'
573 ELSE IF (TRANS.EQ.'T')THEN
574 CTRANS = ' CblasTrans'
576 CTRANS = 'CblasConjTrans'
578 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
592 * Generate the vector X.
595 CALL SMAKE( 'ge', ' ', ' ', 1, NL, X, 1, XX,
596 $ ABS( INCX ), 0, NL - 1, RESET, TRANSL )
599 XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO
612 * Generate the vector Y.
615 CALL SMAKE( 'ge', ' ', ' ', 1, ML, Y, 1,
616 $ YY, ABS( INCY ), 0, ML - 1,
621 * Save every datum before calling the
644 * Call the subroutine.
648 $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
649 $ CTRANS, M, N, ALPHA, LDA, INCX,
653 CALL CSGEMV( IORDER, TRANS, M, N,
654 $ ALPHA, AA, LDA, XX, INCX,
656 ELSE IF( BANDED )THEN
658 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
659 $ CTRANS, M, N, KL, KU, ALPHA, LDA,
663 CALL CSGBMV( IORDER, TRANS, M, N, KL,
664 $ KU, ALPHA, AA, LDA, XX,
665 $ INCX, BETA, YY, INCY )
668 * Check if error-exit was taken incorrectly.
671 WRITE( NOUT, FMT = 9993 )
676 * See what data changed inside subroutines.
678 ISAME( 1 ) = TRANS.EQ.TRANSS
682 ISAME( 4 ) = ALS.EQ.ALPHA
683 ISAME( 5 ) = LSE( AS, AA, LAA )
684 ISAME( 6 ) = LDAS.EQ.LDA
685 ISAME( 7 ) = LSE( XS, XX, LX )
686 ISAME( 8 ) = INCXS.EQ.INCX
687 ISAME( 9 ) = BLS.EQ.BETA
689 ISAME( 10 ) = LSE( YS, YY, LY )
691 ISAME( 10 ) = LSERES( 'ge', ' ', 1,
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 ) = LSE( AS, AA, LAA )
701 ISAME( 8 ) = LDAS.EQ.LDA
702 ISAME( 9 ) = LSE( XS, XX, LX )
703 ISAME( 10 ) = INCXS.EQ.INCX
704 ISAME( 11 ) = BLS.EQ.BETA
706 ISAME( 12 ) = LSE( YS, YY, LY )
708 ISAME( 12 ) = LSERES( 'ge', ' ', 1,
712 ISAME( 13 ) = INCYS.EQ.INCY
715 * If data was incorrectly changed, report
720 SAME = SAME.AND.ISAME( I )
721 IF( .NOT.ISAME( I ) )
722 $ WRITE( NOUT, FMT = 9998 )I
733 CALL SMVCH( 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
743 * Avoid repeating tests with M.le.0 or
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
770 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
771 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
776 WRITE( NOUT, FMT = 9996 )SNAME
778 WRITE( NOUT, FMT = 9994 )NC, SNAME, CTRANS, M, N, ALPHA, LDA,
780 ELSE IF( BANDED )THEN
781 WRITE( NOUT, FMT = 9995 )NC, SNAME, CTRANS, M, N, KL, KU,
782 $ ALPHA, LDA, INCX, BETA, INCY
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,',
807 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 2( I3, ',' ), F4.1,
808 $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2,
810 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
816 SUBROUTINE SCHK2( 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 )
821 * Tests SSYMV, SSBMV and SSPMV.
823 * Auxiliary routine for test program for Level 2 Blas.
825 * -- Written on 10-August-1987.
826 * Richard Hanson, Sandia National Labs.
827 * Jeremy Du Croz, NAG Central Office.
831 PARAMETER ( ZERO = 0.0, HALF = 0.5 )
832 * .. Scalar Arguments ..
834 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
836 LOGICAL FATAL, REWI, TRACE
838 * .. Array Arguments ..
839 REAL 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 ),
845 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
846 * .. Local Scalars ..
847 REAL 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
857 * .. External Functions ..
860 * .. External Subroutines ..
861 EXTERNAL SMAKE, SMVCH, CSSBMV, CSSPMV, CSSYMV
862 * .. Intrinsic Functions ..
864 * .. Scalars in Common ..
867 * .. Common blocks ..
868 COMMON /INFOC/INFOT, NOUTC, OK
869 * .. Data statements ..
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.
878 ELSE IF( BANDED )THEN
880 ELSE IF( PACKED )THEN
902 * Set LDA to 1 more than minimum value if room.
910 * Skip tests if not enough room.
914 LAA = ( N*( N + 1 ) )/2
923 CUPLO = ' CblasUpper'
925 CUPLO = ' CblasLower'
928 * Generate the matrix A.
931 CALL SMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A, NMAX, AA,
932 $ LDA, K, K, RESET, TRANSL )
938 * Generate the vector X.
941 CALL SMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX,
942 $ ABS( INCX ), 0, N - 1, RESET, TRANSL )
945 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
958 * Generate the vector Y.
961 CALL SMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY,
962 $ ABS( INCY ), 0, N - 1, RESET,
967 * Save every datum before calling the
988 * Call the subroutine.
992 $ WRITE( NTRA, FMT = 9993 )NC, SNAME,
993 $ CUPLO, N, ALPHA, LDA, INCX, BETA, INCY
996 CALL CSSYMV( IORDER, UPLO, N, ALPHA, AA,
997 $ LDA, XX, INCX, BETA, YY, INCY )
998 ELSE IF( BANDED )THEN
1000 $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
1001 $ CUPLO, N, K, ALPHA, LDA, INCX, BETA,
1005 CALL CSSBMV( IORDER, UPLO, N, K, ALPHA,
1006 $ AA, LDA, XX, INCX, BETA, YY,
1008 ELSE IF( PACKED )THEN
1010 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1011 $ CUPLO, N, ALPHA, INCX, BETA, INCY
1014 CALL CSSPMV( IORDER, UPLO, N, ALPHA, AA,
1015 $ XX, INCX, BETA, YY, INCY )
1018 * Check if error-exit was taken incorrectly.
1021 WRITE( NOUT, FMT = 9992 )
1026 * See what data changed inside subroutines.
1028 ISAME( 1 ) = UPLO.EQ.UPLOS
1029 ISAME( 2 ) = NS.EQ.N
1031 ISAME( 3 ) = ALS.EQ.ALPHA
1032 ISAME( 4 ) = LSE( AS, AA, LAA )
1033 ISAME( 5 ) = LDAS.EQ.LDA
1034 ISAME( 6 ) = LSE( XS, XX, LX )
1035 ISAME( 7 ) = INCXS.EQ.INCX
1036 ISAME( 8 ) = BLS.EQ.BETA
1038 ISAME( 9 ) = LSE( YS, YY, LY )
1040 ISAME( 9 ) = LSERES( 'ge', ' ', 1, N,
1041 $ YS, YY, ABS( INCY ) )
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 ) = LSE( AS, AA, LAA )
1048 ISAME( 6 ) = LDAS.EQ.LDA
1049 ISAME( 7 ) = LSE( XS, XX, LX )
1050 ISAME( 8 ) = INCXS.EQ.INCX
1051 ISAME( 9 ) = BLS.EQ.BETA
1053 ISAME( 10 ) = LSE( YS, YY, LY )
1055 ISAME( 10 ) = LSERES( 'ge', ' ', 1, N,
1056 $ YS, YY, ABS( INCY ) )
1058 ISAME( 11 ) = INCYS.EQ.INCY
1059 ELSE IF( PACKED )THEN
1060 ISAME( 3 ) = ALS.EQ.ALPHA
1061 ISAME( 4 ) = LSE( AS, AA, LAA )
1062 ISAME( 5 ) = LSE( XS, XX, LX )
1063 ISAME( 6 ) = INCXS.EQ.INCX
1064 ISAME( 7 ) = BLS.EQ.BETA
1066 ISAME( 8 ) = LSE( YS, YY, LY )
1068 ISAME( 8 ) = LSERES( 'ge', ' ', 1, N,
1069 $ YS, YY, ABS( INCY ) )
1071 ISAME( 9 ) = INCYS.EQ.INCY
1074 * If data was incorrectly changed, report and
1079 SAME = SAME.AND.ISAME( I )
1080 IF( .NOT.ISAME( I ) )
1081 $ WRITE( NOUT, FMT = 9998 )I
1092 CALL SMVCH( 'N', N, N, ALPHA, A, NMAX, X,
1093 $ INCX, BETA, Y, INCY, YT, G,
1094 $ YY, EPS, ERR, FATAL, NOUT,
1096 ERRMAX = MAX( ERRMAX, ERR )
1097 * If got really bad answer, report and
1102 * Avoid repeating tests with N.le.0
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
1126 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
1127 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
1132 WRITE( NOUT, FMT = 9996 )SNAME
1134 WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, LDA,
1136 ELSE IF( BANDED )THEN
1137 WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, K, ALPHA, LDA,
1139 ELSE IF( PACKED )THEN
1140 WRITE( NOUT, FMT = 9995 )NC, SNAME, CUPLO, N, ALPHA, INCX,
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,
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 *',
1176 SUBROUTINE SCHK3( 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 )
1180 * Tests STRMV, STBMV, STPMV, STRSV, STBSV and STPSV.
1182 * Auxiliary routine for test program for Level 2 Blas.
1184 * -- Written on 10-August-1987.
1185 * Richard Hanson, Sandia National Labs.
1186 * Jeremy Du Croz, NAG Central Office.
1189 REAL ZERO, HALF, ONE
1190 PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
1191 * .. Scalar Arguments ..
1193 INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA,
1195 LOGICAL FATAL, REWI, TRACE
1197 * .. Array Arguments ..
1198 REAL 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 REAL 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
1212 * .. Local Arrays ..
1214 * .. External Functions ..
1216 EXTERNAL LSE, LSERES
1217 * .. External Subroutines ..
1218 EXTERNAL SMAKE, SMVCH, CSTBMV, CSTBSV, CSTPMV,
1219 $ CSTPSV, CSTRMV, CSTRSV
1220 * .. Intrinsic Functions ..
1222 * .. Scalars in Common ..
1223 INTEGER INFOT, NOUTC
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.
1236 ELSE IF( BANDED )THEN
1238 ELSE IF( PACKED )THEN
1245 * Set up zero vector for SMVCH.
1250 DO 110 IN = 1, NIDIM
1264 * Set LDA to 1 more than minimum value if room.
1272 * Skip tests if not enough room.
1276 LAA = ( N*( N + 1 ) )/2
1283 UPLO = ICHU( ICU: ICU )
1284 IF (UPLO.EQ.'U')THEN
1285 CUPLO = ' CblasUpper'
1287 CUPLO = ' CblasLower'
1291 TRANS = ICHT( ICT: ICT )
1292 IF (TRANS.EQ.'N')THEN
1293 CTRANS = ' CblasNoTrans'
1294 ELSE IF (TRANS.EQ.'T')THEN
1295 CTRANS = ' CblasTrans'
1297 CTRANS = 'CblasConjTrans'
1301 DIAG = ICHD( ICD: ICD )
1302 IF (DIAG.EQ.'N')THEN
1303 CDIAG = ' CblasNonUnit'
1305 CDIAG = ' CblasUnit'
1308 * Generate the matrix A.
1311 CALL SMAKE( SNAME( 8: 9 ), UPLO, DIAG, N, N, A,
1312 $ NMAX, AA, LDA, K, K, RESET, TRANSL )
1318 * Generate the vector X.
1321 CALL SMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX,
1322 $ ABS( INCX ), 0, N - 1, RESET,
1326 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
1331 * Save every datum before calling the subroutine.
1347 * Call the subroutine.
1349 IF( SNAME( 10: 11 ).EQ.'mv' )THEN
1352 $ WRITE( NTRA, FMT = 9993 )NC, SNAME,
1353 $ CUPLO, CTRANS, CDIAG, N, LDA, INCX
1356 CALL CSTRMV( IORDER, UPLO, TRANS, DIAG,
1357 $ N, AA, LDA, XX, INCX )
1358 ELSE IF( BANDED )THEN
1360 $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
1361 $ CUPLO, CTRANS, CDIAG, N, K, LDA, INCX
1364 CALL CSTBMV( IORDER, UPLO, TRANS, DIAG,
1365 $ N, K, AA, LDA, XX, INCX )
1366 ELSE IF( PACKED )THEN
1368 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1369 $ CUPLO, CTRANS, CDIAG, N, INCX
1372 CALL CSTPMV( IORDER, UPLO, TRANS, DIAG,
1375 ELSE IF( SNAME( 10: 11 ).EQ.'sv' )THEN
1378 $ WRITE( NTRA, FMT = 9993 )NC, SNAME,
1379 $ CUPLO, CTRANS, CDIAG, N, LDA, INCX
1382 CALL CSTRSV( IORDER, UPLO, TRANS, DIAG,
1383 $ N, AA, LDA, XX, INCX )
1384 ELSE IF( BANDED )THEN
1386 $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
1387 $ CUPLO, CTRANS, CDIAG, N, K, LDA, INCX
1390 CALL CSTBSV( IORDER, UPLO, TRANS, DIAG,
1391 $ N, K, AA, LDA, XX, INCX )
1392 ELSE IF( PACKED )THEN
1394 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1395 $ CUPLO, CTRANS, CDIAG, N, INCX
1398 CALL CSTPSV( IORDER, UPLO, TRANS, DIAG,
1403 * Check if error-exit was taken incorrectly.
1406 WRITE( NOUT, FMT = 9992 )
1411 * See what data changed inside subroutines.
1413 ISAME( 1 ) = UPLO.EQ.UPLOS
1414 ISAME( 2 ) = TRANS.EQ.TRANSS
1415 ISAME( 3 ) = DIAG.EQ.DIAGS
1416 ISAME( 4 ) = NS.EQ.N
1418 ISAME( 5 ) = LSE( AS, AA, LAA )
1419 ISAME( 6 ) = LDAS.EQ.LDA
1421 ISAME( 7 ) = LSE( XS, XX, LX )
1423 ISAME( 7 ) = LSERES( 'ge', ' ', 1, N, XS,
1426 ISAME( 8 ) = INCXS.EQ.INCX
1427 ELSE IF( BANDED )THEN
1428 ISAME( 5 ) = KS.EQ.K
1429 ISAME( 6 ) = LSE( AS, AA, LAA )
1430 ISAME( 7 ) = LDAS.EQ.LDA
1432 ISAME( 8 ) = LSE( XS, XX, LX )
1434 ISAME( 8 ) = LSERES( 'ge', ' ', 1, N, XS,
1437 ISAME( 9 ) = INCXS.EQ.INCX
1438 ELSE IF( PACKED )THEN
1439 ISAME( 5 ) = LSE( AS, AA, LAA )
1441 ISAME( 6 ) = LSE( XS, XX, LX )
1443 ISAME( 6 ) = LSERES( 'ge', ' ', 1, N, XS,
1446 ISAME( 7 ) = INCXS.EQ.INCX
1449 * If data was incorrectly changed, report and
1454 SAME = SAME.AND.ISAME( I )
1455 IF( .NOT.ISAME( I ) )
1456 $ WRITE( NOUT, FMT = 9998 )I
1464 IF( SNAME( 10: 11 ).EQ.'mv' )THEN
1468 CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X,
1469 $ INCX, ZERO, Z, INCX, XT, G,
1470 $ XX, EPS, ERR, FATAL, NOUT,
1472 ELSE IF( SNAME( 10: 11 ).EQ.'sv' )THEN
1474 * Compute approximation to original vector.
1477 Z( I ) = XX( 1 + ( I - 1 )*
1479 XX( 1 + ( I - 1 )*ABS( INCX ) )
1482 CALL SMVCH( TRANS, N, N, ONE, A, NMAX, Z,
1483 $ INCX, ZERO, X, INCX, XT, G,
1484 $ XX, EPS, ERR, FATAL, NOUT,
1487 ERRMAX = MAX( ERRMAX, ERR )
1488 * If got really bad answer, report and return.
1492 * Avoid repeating tests with N.le.0.
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
1514 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
1515 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
1520 WRITE( NOUT, FMT = 9996 )SNAME
1522 WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, CTRANS, CDIAG, N,
1524 ELSE IF( BANDED )THEN
1525 WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, CTRANS, CDIAG, N,
1527 ELSE IF( PACKED )THEN
1528 WRITE( NOUT, FMT = 9995 )NC, SNAME, CUPLO, CTRANS, CDIAG, N,
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, ',
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 *',
1563 SUBROUTINE SCHK4( 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,
1570 * Auxiliary routine for test program for Level 2 Blas.
1572 * -- Written on 10-August-1987.
1573 * Richard Hanson, Sandia National Labs.
1574 * Jeremy Du Croz, NAG Central Office.
1577 REAL ZERO, HALF, ONE
1578 PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
1579 * .. Scalar Arguments ..
1581 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA,
1583 LOGICAL FATAL, REWI, TRACE
1585 * .. Array Arguments ..
1586 REAL 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 REAL 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,
1597 LOGICAL NULL, RESET, SAME
1598 * .. Local Arrays ..
1601 * .. External Functions ..
1603 EXTERNAL LSE, LSERES
1604 * .. External Subroutines ..
1605 EXTERNAL CSGER, SMAKE, SMVCH
1606 * .. Intrinsic Functions ..
1607 INTRINSIC ABS, MAX, MIN
1608 * .. Scalars in Common ..
1609 INTEGER INFOT, NOUTC
1611 * .. Common blocks ..
1612 COMMON /INFOC/INFOT, NOUTC, OK
1613 * .. Executable Statements ..
1614 * Define the number of arguments.
1621 DO 120 IN = 1, NIDIM
1627 $ M = MAX( N - ND, 0 )
1629 $ M = MIN( N + ND, NMAX )
1631 * Set LDA to 1 more than minimum value if room.
1635 * Skip tests if not enough room.
1639 NULL = N.LE.0.OR.M.LE.0
1645 * Generate the vector X.
1648 CALL SMAKE( 'ge', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ),
1649 $ 0, M - 1, RESET, TRANSL )
1652 XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO
1659 * Generate the vector Y.
1662 CALL SMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY,
1663 $ ABS( INCY ), 0, N - 1, RESET, TRANSL )
1666 YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
1672 * Generate the matrix A.
1675 CALL SMAKE( SNAME( 8: 9 ), ' ', ' ', M, N, A, NMAX,
1676 $ AA, LDA, M - 1, N - 1, RESET, TRANSL )
1680 * Save every datum before calling the subroutine.
1698 * Call the subroutine.
1701 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N,
1702 $ ALPHA, INCX, INCY, LDA
1705 CALL CSGER( IORDER, M, N, ALPHA, XX, INCX, YY,
1708 * Check if error-exit was taken incorrectly.
1711 WRITE( NOUT, FMT = 9993 )
1716 * See what data changed inside subroutine.
1718 ISAME( 1 ) = MS.EQ.M
1719 ISAME( 2 ) = NS.EQ.N
1720 ISAME( 3 ) = ALS.EQ.ALPHA
1721 ISAME( 4 ) = LSE( XS, XX, LX )
1722 ISAME( 5 ) = INCXS.EQ.INCX
1723 ISAME( 6 ) = LSE( YS, YY, LY )
1724 ISAME( 7 ) = INCYS.EQ.INCY
1726 ISAME( 8 ) = LSE( AS, AA, LAA )
1728 ISAME( 8 ) = LSERES( 'ge', ' ', M, N, AS, AA,
1731 ISAME( 9 ) = LDAS.EQ.LDA
1733 * If data was incorrectly changed, report and return.
1737 SAME = SAME.AND.ISAME( I )
1738 IF( .NOT.ISAME( I ) )
1739 $ WRITE( NOUT, FMT = 9998 )I
1748 * Check the result column by column.
1756 Z( I ) = X( M - I + 1 )
1763 W( 1 ) = Y( N - J + 1 )
1765 CALL SMVCH( '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.
1775 * Avoid repeating tests with M.le.0 or N.le.0.
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
1795 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
1796 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
1801 WRITE( NOUT, FMT = 9995 )J
1804 WRITE( NOUT, FMT = 9996 )SNAME
1805 WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA
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 *',
1835 SUBROUTINE SCHK5( 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,
1840 * Tests SSYR and SSPR.
1842 * Auxiliary routine for test program for Level 2 Blas.
1844 * -- Written on 10-August-1987.
1845 * Richard Hanson, Sandia National Labs.
1846 * Jeremy Du Croz, NAG Central Office.
1849 REAL ZERO, HALF, ONE
1850 PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
1851 * .. Scalar Arguments ..
1853 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA,
1855 LOGICAL FATAL, REWI, TRACE
1857 * .. Array Arguments ..
1858 REAL 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 REAL 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
1872 * .. Local Arrays ..
1875 * .. External Functions ..
1877 EXTERNAL LSE, LSERES
1878 * .. External Subroutines ..
1879 EXTERNAL SMAKE, SMVCH, CSSPR, CSSYR
1880 * .. Intrinsic Functions ..
1882 * .. Scalars in Common ..
1883 INTEGER INFOT, NOUTC
1885 * .. Common blocks ..
1886 COMMON /INFOC/INFOT, NOUTC, OK
1887 * .. Data statements ..
1889 * .. Executable Statements ..
1890 FULL = SNAME( 9: 9 ).EQ.'y'
1891 PACKED = SNAME( 9: 9 ).EQ.'p'
1892 * Define the number of arguments.
1895 ELSE IF( PACKED )THEN
1903 DO 100 IN = 1, NIDIM
1905 * Set LDA to 1 more than minimum value if room.
1909 * Skip tests if not enough room.
1913 LAA = ( N*( N + 1 ) )/2
1919 UPLO = ICH( IC: IC )
1920 IF (UPLO.EQ.'U')THEN
1921 CUPLO = ' CblasUpper'
1923 CUPLO = ' CblasLower'
1931 * Generate the vector X.
1934 CALL SMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
1935 $ 0, N - 1, RESET, TRANSL )
1938 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
1943 NULL = N.LE.0.OR.ALPHA.EQ.ZERO
1945 * Generate the matrix A.
1948 CALL SMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A, NMAX,
1949 $ AA, LDA, N - 1, N - 1, RESET, TRANSL )
1953 * Save every datum before calling the subroutine.
1967 * Call the subroutine.
1971 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, CUPLO, N,
1975 CALL CSSYR( IORDER, UPLO, N, ALPHA, XX, INCX,
1977 ELSE IF( PACKED )THEN
1979 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, CUPLO, N,
1983 CALL CSSPR( IORDER, UPLO, N, ALPHA, XX, INCX, AA )
1986 * Check if error-exit was taken incorrectly.
1989 WRITE( NOUT, FMT = 9992 )
1994 * See what data changed inside subroutines.
1996 ISAME( 1 ) = UPLO.EQ.UPLOS
1997 ISAME( 2 ) = NS.EQ.N
1998 ISAME( 3 ) = ALS.EQ.ALPHA
1999 ISAME( 4 ) = LSE( XS, XX, LX )
2000 ISAME( 5 ) = INCXS.EQ.INCX
2002 ISAME( 6 ) = LSE( AS, AA, LAA )
2004 ISAME( 6 ) = LSERES( SNAME( 8: 9 ), UPLO, N, N, AS,
2007 IF( .NOT.PACKED )THEN
2008 ISAME( 7 ) = LDAS.EQ.LDA
2011 * If data was incorrectly changed, report and return.
2015 SAME = SAME.AND.ISAME( I )
2016 IF( .NOT.ISAME( I ) )
2017 $ WRITE( NOUT, FMT = 9998 )I
2026 * Check the result column by column.
2034 Z( I ) = X( N - I + 1 )
2047 CALL SMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W,
2048 $ 1, ONE, A( JJ, J ), 1, YT, G,
2049 $ AA( JA ), EPS, ERR, FATAL, NOUT,
2060 ERRMAX = MAX( ERRMAX, ERR )
2061 * If got really bad answer, report and return.
2066 * Avoid repeating tests if N.le.0.
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
2085 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
2086 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
2091 WRITE( NOUT, FMT = 9995 )J
2094 WRITE( NOUT, FMT = 9996 )SNAME
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
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,',
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 *',
2131 SUBROUTINE SCHK6( 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,
2136 * Tests SSYR2 and SSPR2.
2138 * Auxiliary routine for test program for Level 2 Blas.
2140 * -- Written on 10-August-1987.
2141 * Richard Hanson, Sandia National Labs.
2142 * Jeremy Du Croz, NAG Central Office.
2145 REAL ZERO, HALF, ONE
2146 PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
2147 * .. Scalar Arguments ..
2149 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA,
2151 LOGICAL FATAL, REWI, TRACE
2153 * .. Array Arguments ..
2154 REAL 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 REAL 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,
2165 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
2166 CHARACTER*1 UPLO, UPLOS
2169 * .. Local Arrays ..
2172 * .. External Functions ..
2174 EXTERNAL LSE, LSERES
2175 * .. External Subroutines ..
2176 EXTERNAL SMAKE, SMVCH, CSSPR2, CSSYR2
2177 * .. Intrinsic Functions ..
2179 * .. Scalars in Common ..
2180 INTEGER INFOT, NOUTC
2182 * .. Common blocks ..
2183 COMMON /INFOC/INFOT, NOUTC, OK
2184 * .. Data statements ..
2186 * .. Executable Statements ..
2187 FULL = SNAME( 9: 9 ).EQ.'y'
2188 PACKED = SNAME( 9: 9 ).EQ.'p'
2189 * Define the number of arguments.
2192 ELSE IF( PACKED )THEN
2200 DO 140 IN = 1, NIDIM
2202 * Set LDA to 1 more than minimum value if room.
2206 * Skip tests if not enough room.
2210 LAA = ( N*( N + 1 ) )/2
2216 UPLO = ICH( IC: IC )
2217 IF (UPLO.EQ.'U')THEN
2218 CUPLO = ' CblasUpper'
2220 CUPLO = ' CblasLower'
2228 * Generate the vector X.
2231 CALL SMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
2232 $ 0, N - 1, RESET, TRANSL )
2235 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
2242 * Generate the vector Y.
2245 CALL SMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY,
2246 $ ABS( INCY ), 0, N - 1, RESET, TRANSL )
2249 YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
2254 NULL = N.LE.0.OR.ALPHA.EQ.ZERO
2256 * Generate the matrix A.
2259 CALL SMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A,
2260 $ NMAX, AA, LDA, N - 1, N - 1, RESET,
2265 * Save every datum before calling the subroutine.
2283 * Call the subroutine.
2287 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, CUPLO, N,
2288 $ ALPHA, INCX, INCY, LDA
2291 CALL CSSYR2( IORDER, UPLO, N, ALPHA, XX, INCX,
2292 $ YY, INCY, AA, LDA )
2293 ELSE IF( PACKED )THEN
2295 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, CUPLO, N,
2299 CALL CSSPR2( IORDER, UPLO, N, ALPHA, XX, INCX,
2303 * Check if error-exit was taken incorrectly.
2306 WRITE( NOUT, FMT = 9992 )
2311 * See what data changed inside subroutines.
2313 ISAME( 1 ) = UPLO.EQ.UPLOS
2314 ISAME( 2 ) = NS.EQ.N
2315 ISAME( 3 ) = ALS.EQ.ALPHA
2316 ISAME( 4 ) = LSE( XS, XX, LX )
2317 ISAME( 5 ) = INCXS.EQ.INCX
2318 ISAME( 6 ) = LSE( YS, YY, LY )
2319 ISAME( 7 ) = INCYS.EQ.INCY
2321 ISAME( 8 ) = LSE( AS, AA, LAA )
2323 ISAME( 8 ) = LSERES( SNAME( 8: 9 ), UPLO, N, N,
2326 IF( .NOT.PACKED )THEN
2327 ISAME( 9 ) = LDAS.EQ.LDA
2330 * If data was incorrectly changed, report and return.
2334 SAME = SAME.AND.ISAME( I )
2335 IF( .NOT.ISAME( I ) )
2336 $ WRITE( NOUT, FMT = 9998 )I
2345 * Check the result column by column.
2353 Z( I, 1 ) = X( N - I + 1 )
2362 Z( I, 2 ) = Y( N - I + 1 )
2376 CALL SMVCH( 'N', LJ, 2, ALPHA, Z( JJ, 1 ),
2377 $ NMAX, W, 1, ONE, A( JJ, J ), 1,
2378 $ YT, G, AA( JA ), EPS, ERR, FATAL,
2389 ERRMAX = MAX( ERRMAX, ERR )
2390 * If got really bad answer, report and return.
2395 * Avoid repeating tests with N.le.0.
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
2416 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
2417 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
2422 WRITE( NOUT, FMT = 9995 )J
2425 WRITE( NOUT, FMT = 9996 )SNAME
2427 WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, INCX,
2429 ELSE IF( PACKED )THEN
2430 WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, ALPHA, INCX, INCY
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 *',
2463 SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL,
2464 $ KU, RESET, TRANSL )
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.
2471 * TYPE is 'ge', 'gb', 'sy', 'sb', 'sp', 'tr', 'tb' OR 'tp'.
2473 * Auxiliary routine for test program for Level 2 Blas.
2475 * -- Written on 10-August-1987.
2476 * Richard Hanson, Sandia National Labs.
2477 * Jeremy Du Croz, NAG Central Office.
2481 PARAMETER ( ZERO = 0.0, ONE = 1.0 )
2483 PARAMETER ( ROGUE = -1.0E10 )
2484 * .. Scalar Arguments ..
2486 INTEGER KL, KU, LDA, M, N, NMAX
2488 CHARACTER*1 DIAG, UPLO
2490 * .. Array Arguments ..
2491 REAL 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 ..
2498 * .. Intrinsic Functions ..
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'
2508 * Generate data in array A.
2512 IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
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 ) = SBEG( RESET ) + TRANSL
2522 A( J, I ) = A( I, J )
2530 $ A( J, J ) = A( J, J ) + ONE
2535 * Store elements in array AS in data structure required by routine.
2537 IF( TYPE.EQ.'ge' )THEN
2540 AA( I + ( J - 1 )*LDA ) = A( I, J )
2542 DO 40 I = M + 1, LDA
2543 AA( I + ( J - 1 )*LDA ) = ROGUE
2546 ELSE IF( TYPE.EQ.'gb' )THEN
2548 DO 60 I1 = 1, KU + 1 - J
2549 AA( I1 + ( J - 1 )*LDA ) = ROGUE
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 )
2555 AA( I3 + ( J - 1 )*LDA ) = ROGUE
2558 ELSE IF( TYPE.EQ.'sy'.OR.TYPE.EQ.'tr' )THEN
2575 DO 100 I = 1, IBEG - 1
2576 AA( I + ( J - 1 )*LDA ) = ROGUE
2578 DO 110 I = IBEG, IEND
2579 AA( I + ( J - 1 )*LDA ) = A( I, J )
2581 DO 120 I = IEND + 1, LDA
2582 AA( I + ( J - 1 )*LDA ) = ROGUE
2585 ELSE IF( TYPE.EQ.'sb'.OR.TYPE.EQ.'tb' )THEN
2589 IBEG = MAX( 1, KL + 2 - J )
2602 IEND = MIN( KL + 1, 1 + M - J )
2604 DO 140 I = 1, IBEG - 1
2605 AA( I + ( J - 1 )*LDA ) = ROGUE
2607 DO 150 I = IBEG, IEND
2608 AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J )
2610 DO 160 I = IEND + 1, LDA
2611 AA( I + ( J - 1 )*LDA ) = ROGUE
2614 ELSE IF( TYPE.EQ.'sp'.OR.TYPE.EQ.'tp' )THEN
2624 DO 180 I = IBEG, IEND
2626 AA( IOFF ) = A( I, J )
2629 $ AA( IOFF ) = ROGUE
2639 SUBROUTINE SMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y,
2640 $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV )
2642 * Checks the results of the computational tests.
2644 * Auxiliary routine for test program for Level 2 Blas.
2646 * -- Written on 10-August-1987.
2647 * Richard Hanson, Sandia National Labs.
2648 * Jeremy Du Croz, NAG Central Office.
2652 PARAMETER ( ZERO = 0.0, ONE = 1.0 )
2653 * .. Scalar Arguments ..
2654 REAL ALPHA, BETA, EPS, ERR
2655 INTEGER INCX, INCY, M, N, NMAX, NOUT
2658 * .. Array Arguments ..
2659 REAL A( NMAX, * ), G( * ), X( * ), Y( * ), YT( * ),
2661 * .. Local Scalars ..
2663 INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL
2665 * .. Intrinsic Functions ..
2666 INTRINSIC ABS, MAX, SQRT
2667 * .. Executable Statements ..
2668 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
2691 * Compute expected result in YT using data in A, X and Y.
2692 * Compute gauges in G.
2701 YT( IY ) = YT( IY ) + A( J, I )*X( JX )
2702 G( IY ) = G( IY ) + ABS( A( J, I )*X( JX ) )
2707 YT( IY ) = YT( IY ) + A( I, J )*X( JX )
2708 G( IY ) = G( IY ) + ABS( A( I, J )*X( JX ) )
2712 YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY )
2713 G( IY ) = ABS( ALPHA )*G( IY ) + ABS( BETA*Y( IY ) )
2717 * Compute the error ratio for this result.
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 )
2728 * If the loop completes, all results are at least half accurate.
2731 * Report fatal error.
2734 WRITE( NOUT, FMT = 9999 )
2737 WRITE( NOUT, FMT = 9998 )I, YT( I ),
2738 $ YY( 1 + ( I - 1 )*ABS( INCY ) )
2740 WRITE( NOUT, FMT = 9998 )I,
2741 $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT(I)
2748 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2749 $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
2751 9998 FORMAT( 1X, I7, 2G18.6 )
2756 LOGICAL FUNCTION LSE( RI, RJ, LR )
2758 * Tests if two arrays are identical.
2760 * Auxiliary routine for test program for Level 2 Blas.
2762 * -- Written on 10-August-1987.
2763 * Richard Hanson, Sandia National Labs.
2764 * Jeremy Du Croz, NAG Central Office.
2766 * .. Scalar Arguments ..
2768 * .. Array Arguments ..
2769 REAL RI( * ), RJ( * )
2770 * .. Local Scalars ..
2772 * .. Executable Statements ..
2774 IF( RI( I ).NE.RJ( I ) )
2786 LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA )
2788 * Tests if selected elements in two arrays are equal.
2790 * TYPE is 'ge', 'sy' or 'sp'.
2792 * Auxiliary routine for test program for Level 2 Blas.
2794 * -- Written on 10-August-1987.
2795 * Richard Hanson, Sandia National Labs.
2796 * Jeremy Du Croz, NAG Central Office.
2798 * .. Scalar Arguments ..
2802 * .. Array Arguments ..
2803 REAL AA( LDA, * ), AS( LDA, * )
2804 * .. Local Scalars ..
2805 INTEGER I, IBEG, IEND, J
2807 * .. Executable Statements ..
2809 IF( TYPE.EQ.'ge' )THEN
2811 DO 10 I = M + 1, LDA
2812 IF( AA( I, J ).NE.AS( I, J ) )
2816 ELSE IF( TYPE.EQ.'sy' )THEN
2825 DO 30 I = 1, IBEG - 1
2826 IF( AA( I, J ).NE.AS( I, J ) )
2829 DO 40 I = IEND + 1, LDA
2830 IF( AA( I, J ).NE.AS( I, J ) )
2846 REAL FUNCTION SBEG( RESET )
2848 * Generates random numbers uniformly distributed between -0.5 and 0.5.
2850 * Auxiliary routine for test program for Level 2 Blas.
2852 * -- Written on 10-August-1987.
2853 * Richard Hanson, Sandia National Labs.
2854 * Jeremy Du Croz, NAG Central Office.
2856 * .. Scalar Arguments ..
2858 * .. Local Scalars ..
2860 * .. Save statement ..
2862 * .. Intrinsic Functions ..
2864 * .. Executable Statements ..
2866 * Initialize local variables.
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.
2881 I = I - 1000*( I/1000 )
2886 SBEG = REAL( I - 500 )/1001.0
2892 REAL FUNCTION SDIFF( X, Y )
2894 * Auxiliary routine for test program for Level 2 Blas.
2896 * -- Written on 10-August-1987.
2897 * Richard Hanson, Sandia National Labs.
2899 * .. Scalar Arguments ..
2901 * .. Executable Statements ..