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