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