1*> \brief \b SDRVGBX 2* 3* =========== DOCUMENTATION =========== 4* 5* Online html documentation available at 6* http://www.netlib.org/lapack/explore-html/ 7* 8* Definition: 9* =========== 10* 11* SUBROUTINE SDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, 12* AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, 13* RWORK, IWORK, NOUT ) 14* 15* .. Scalar Arguments .. 16* LOGICAL TSTERR 17* INTEGER LA, LAFB, NN, NOUT, NRHS 18* REAL THRESH 19* .. 20* .. Array Arguments .. 21* LOGICAL DOTYPE( * ) 22* INTEGER IWORK( * ), NVAL( * ) 23* REAL A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ), 24* $ RWORK( * ), S( * ), WORK( * ), X( * ), 25* $ XACT( * ) 26* .. 27* 28* 29*> \par Purpose: 30* ============= 31*> 32*> \verbatim 33*> 34*> SDRVGB tests the driver routines SGBSV, -SVX, and -SVXX. 35*> 36*> Note that this file is used only when the XBLAS are available, 37*> otherwise sdrvgb.f defines this subroutine. 38*> \endverbatim 39* 40* Arguments: 41* ========== 42* 43*> \param[in] DOTYPE 44*> \verbatim 45*> DOTYPE is LOGICAL array, dimension (NTYPES) 46*> The matrix types to be used for testing. Matrices of type j 47*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 48*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 49*> \endverbatim 50*> 51*> \param[in] NN 52*> \verbatim 53*> NN is INTEGER 54*> The number of values of N contained in the vector NVAL. 55*> \endverbatim 56*> 57*> \param[in] NVAL 58*> \verbatim 59*> NVAL is INTEGER array, dimension (NN) 60*> The values of the matrix column dimension N. 61*> \endverbatim 62*> 63*> \param[in] NRHS 64*> \verbatim 65*> NRHS is INTEGER 66*> The number of right hand side vectors to be generated for 67*> each linear system. 68*> \endverbatim 69*> 70*> \param[in] THRESH 71*> \verbatim 72*> THRESH is REAL 73*> The threshold value for the test ratios. A result is 74*> included in the output file if RESULT >= THRESH. To have 75*> every test ratio printed, use THRESH = 0. 76*> \endverbatim 77*> 78*> \param[in] TSTERR 79*> \verbatim 80*> TSTERR is LOGICAL 81*> Flag that indicates whether error exits are to be tested. 82*> \endverbatim 83*> 84*> \param[out] A 85*> \verbatim 86*> A is REAL array, dimension (LA) 87*> \endverbatim 88*> 89*> \param[in] LA 90*> \verbatim 91*> LA is INTEGER 92*> The length of the array A. LA >= (2*NMAX-1)*NMAX 93*> where NMAX is the largest entry in NVAL. 94*> \endverbatim 95*> 96*> \param[out] AFB 97*> \verbatim 98*> AFB is REAL array, dimension (LAFB) 99*> \endverbatim 100*> 101*> \param[in] LAFB 102*> \verbatim 103*> LAFB is INTEGER 104*> The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX 105*> where NMAX is the largest entry in NVAL. 106*> \endverbatim 107*> 108*> \param[out] ASAV 109*> \verbatim 110*> ASAV is REAL array, dimension (LA) 111*> \endverbatim 112*> 113*> \param[out] B 114*> \verbatim 115*> B is REAL array, dimension (NMAX*NRHS) 116*> \endverbatim 117*> 118*> \param[out] BSAV 119*> \verbatim 120*> BSAV is REAL array, dimension (NMAX*NRHS) 121*> \endverbatim 122*> 123*> \param[out] X 124*> \verbatim 125*> X is REAL array, dimension (NMAX*NRHS) 126*> \endverbatim 127*> 128*> \param[out] XACT 129*> \verbatim 130*> XACT is REAL array, dimension (NMAX*NRHS) 131*> \endverbatim 132*> 133*> \param[out] S 134*> \verbatim 135*> S is REAL array, dimension (2*NMAX) 136*> \endverbatim 137*> 138*> \param[out] WORK 139*> \verbatim 140*> WORK is REAL array, dimension 141*> (NMAX*max(3,NRHS,NMAX)) 142*> \endverbatim 143*> 144*> \param[out] RWORK 145*> \verbatim 146*> RWORK is REAL array, dimension 147*> (max(NMAX,2*NRHS)) 148*> \endverbatim 149*> 150*> \param[out] IWORK 151*> \verbatim 152*> IWORK is INTEGER array, dimension (2*NMAX) 153*> \endverbatim 154*> 155*> \param[in] NOUT 156*> \verbatim 157*> NOUT is INTEGER 158*> The unit number for output. 159*> \endverbatim 160* 161* Authors: 162* ======== 163* 164*> \author Univ. of Tennessee 165*> \author Univ. of California Berkeley 166*> \author Univ. of Colorado Denver 167*> \author NAG Ltd. 168* 169*> \date November 2011 170* 171*> \ingroup single_lin 172* 173* ===================================================================== 174 SUBROUTINE SDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, 175 $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, 176 $ RWORK, IWORK, NOUT ) 177* 178* -- LAPACK test routine (version 3.4.0) -- 179* -- LAPACK is a software package provided by Univ. of Tennessee, -- 180* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 181* November 2011 182* 183* .. Scalar Arguments .. 184 LOGICAL TSTERR 185 INTEGER LA, LAFB, NN, NOUT, NRHS 186 REAL THRESH 187* .. 188* .. Array Arguments .. 189 LOGICAL DOTYPE( * ) 190 INTEGER IWORK( * ), NVAL( * ) 191 REAL A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ), 192 $ RWORK( * ), S( * ), WORK( * ), X( * ), 193 $ XACT( * ) 194* .. 195* 196* ===================================================================== 197* 198* .. Parameters .. 199 REAL ONE, ZERO 200 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 201 INTEGER NTYPES 202 PARAMETER ( NTYPES = 8 ) 203 INTEGER NTESTS 204 PARAMETER ( NTESTS = 7 ) 205 INTEGER NTRAN 206 PARAMETER ( NTRAN = 3 ) 207* .. 208* .. Local Scalars .. 209 LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT 210 CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE 211 CHARACTER*3 PATH 212 INTEGER I, I1, I2, IEQUED, IFACT, IKL, IKU, IMAT, IN, 213 $ INFO, IOFF, ITRAN, IZERO, J, K, K1, KL, KU, 214 $ LDA, LDAFB, LDB, MODE, N, NB, NBMIN, NERRS, 215 $ NFACT, NFAIL, NIMAT, NKL, NKU, NRUN, NT, 216 $ N_ERR_BNDS 217 REAL AINVNM, AMAX, ANORM, ANORMI, ANORMO, ANRMPV, 218 $ CNDNUM, COLCND, RCOND, RCONDC, RCONDI, RCONDO, 219 $ ROLDC, ROLDI, ROLDO, ROWCND, RPVGRW, 220 $ RPVGRW_SVXX 221* .. 222* .. Local Arrays .. 223 CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN ) 224 INTEGER ISEED( 4 ), ISEEDY( 4 ) 225 REAL RESULT( NTESTS ), BERR( NRHS ), 226 $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 ) 227* .. 228* .. External Functions .. 229 LOGICAL LSAME 230 REAL SGET06, SLAMCH, SLANGB, SLANGE, SLANTB, 231 $ SLA_GBRPVGRW 232 EXTERNAL LSAME, SGET06, SLAMCH, SLANGB, SLANGE, SLANTB, 233 $ SLA_GBRPVGRW 234* .. 235* .. External Subroutines .. 236 EXTERNAL ALADHD, ALAERH, ALASVM, SERRVX, SGBEQU, SGBSV, 237 $ SGBSVX, SGBT01, SGBT02, SGBT05, SGBTRF, SGBTRS, 238 $ SGET04, SLACPY, SLAQGB, SLARHS, SLASET, SLATB4, 239 $ SLATMS, XLAENV, SGBSVXX 240* .. 241* .. Intrinsic Functions .. 242 INTRINSIC ABS, MAX, MIN 243* .. 244* .. Scalars in Common .. 245 LOGICAL LERR, OK 246 CHARACTER*32 SRNAMT 247 INTEGER INFOT, NUNIT 248* .. 249* .. Common blocks .. 250 COMMON / INFOC / INFOT, NUNIT, OK, LERR 251 COMMON / SRNAMC / SRNAMT 252* .. 253* .. Data statements .. 254 DATA ISEEDY / 1988, 1989, 1990, 1991 / 255 DATA TRANSS / 'N', 'T', 'C' / 256 DATA FACTS / 'F', 'N', 'E' / 257 DATA EQUEDS / 'N', 'R', 'C', 'B' / 258* .. 259* .. Executable Statements .. 260* 261* Initialize constants and the random number seed. 262* 263 PATH( 1: 1 ) = 'Single precision' 264 PATH( 2: 3 ) = 'GB' 265 NRUN = 0 266 NFAIL = 0 267 NERRS = 0 268 DO 10 I = 1, 4 269 ISEED( I ) = ISEEDY( I ) 270 10 CONTINUE 271* 272* Test the error exits 273* 274 IF( TSTERR ) 275 $ CALL SERRVX( PATH, NOUT ) 276 INFOT = 0 277* 278* Set the block size and minimum block size for testing. 279* 280 NB = 1 281 NBMIN = 2 282 CALL XLAENV( 1, NB ) 283 CALL XLAENV( 2, NBMIN ) 284* 285* Do for each value of N in NVAL 286* 287 DO 150 IN = 1, NN 288 N = NVAL( IN ) 289 LDB = MAX( N, 1 ) 290 XTYPE = 'N' 291* 292* Set limits on the number of loop iterations. 293* 294 NKL = MAX( 1, MIN( N, 4 ) ) 295 IF( N.EQ.0 ) 296 $ NKL = 1 297 NKU = NKL 298 NIMAT = NTYPES 299 IF( N.LE.0 ) 300 $ NIMAT = 1 301* 302 DO 140 IKL = 1, NKL 303* 304* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes 305* it easier to skip redundant values for small values of N. 306* 307 IF( IKL.EQ.1 ) THEN 308 KL = 0 309 ELSE IF( IKL.EQ.2 ) THEN 310 KL = MAX( N-1, 0 ) 311 ELSE IF( IKL.EQ.3 ) THEN 312 KL = ( 3*N-1 ) / 4 313 ELSE IF( IKL.EQ.4 ) THEN 314 KL = ( N+1 ) / 4 315 END IF 316 DO 130 IKU = 1, NKU 317* 318* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order 319* makes it easier to skip redundant values for small 320* values of N. 321* 322 IF( IKU.EQ.1 ) THEN 323 KU = 0 324 ELSE IF( IKU.EQ.2 ) THEN 325 KU = MAX( N-1, 0 ) 326 ELSE IF( IKU.EQ.3 ) THEN 327 KU = ( 3*N-1 ) / 4 328 ELSE IF( IKU.EQ.4 ) THEN 329 KU = ( N+1 ) / 4 330 END IF 331* 332* Check that A and AFB are big enough to generate this 333* matrix. 334* 335 LDA = KL + KU + 1 336 LDAFB = 2*KL + KU + 1 337 IF( LDA*N.GT.LA .OR. LDAFB*N.GT.LAFB ) THEN 338 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 339 $ CALL ALADHD( NOUT, PATH ) 340 IF( LDA*N.GT.LA ) THEN 341 WRITE( NOUT, FMT = 9999 )LA, N, KL, KU, 342 $ N*( KL+KU+1 ) 343 NERRS = NERRS + 1 344 END IF 345 IF( LDAFB*N.GT.LAFB ) THEN 346 WRITE( NOUT, FMT = 9998 )LAFB, N, KL, KU, 347 $ N*( 2*KL+KU+1 ) 348 NERRS = NERRS + 1 349 END IF 350 GO TO 130 351 END IF 352* 353 DO 120 IMAT = 1, NIMAT 354* 355* Do the tests only if DOTYPE( IMAT ) is true. 356* 357 IF( .NOT.DOTYPE( IMAT ) ) 358 $ GO TO 120 359* 360* Skip types 2, 3, or 4 if the matrix is too small. 361* 362 ZEROT = IMAT.GE.2 .AND. IMAT.LE.4 363 IF( ZEROT .AND. N.LT.IMAT-1 ) 364 $ GO TO 120 365* 366* Set up parameters with SLATB4 and generate a 367* test matrix with SLATMS. 368* 369 CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, 370 $ MODE, CNDNUM, DIST ) 371 RCONDC = ONE / CNDNUM 372* 373 SRNAMT = 'SLATMS' 374 CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, 375 $ CNDNUM, ANORM, KL, KU, 'Z', A, LDA, WORK, 376 $ INFO ) 377* 378* Check the error code from SLATMS. 379* 380 IF( INFO.NE.0 ) THEN 381 CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', N, N, 382 $ KL, KU, -1, IMAT, NFAIL, NERRS, NOUT ) 383 GO TO 120 384 END IF 385* 386* For types 2, 3, and 4, zero one or more columns of 387* the matrix to test that INFO is returned correctly. 388* 389 IZERO = 0 390 IF( ZEROT ) THEN 391 IF( IMAT.EQ.2 ) THEN 392 IZERO = 1 393 ELSE IF( IMAT.EQ.3 ) THEN 394 IZERO = N 395 ELSE 396 IZERO = N / 2 + 1 397 END IF 398 IOFF = ( IZERO-1 )*LDA 399 IF( IMAT.LT.4 ) THEN 400 I1 = MAX( 1, KU+2-IZERO ) 401 I2 = MIN( KL+KU+1, KU+1+( N-IZERO ) ) 402 DO 20 I = I1, I2 403 A( IOFF+I ) = ZERO 404 20 CONTINUE 405 ELSE 406 DO 40 J = IZERO, N 407 DO 30 I = MAX( 1, KU+2-J ), 408 $ MIN( KL+KU+1, KU+1+( N-J ) ) 409 A( IOFF+I ) = ZERO 410 30 CONTINUE 411 IOFF = IOFF + LDA 412 40 CONTINUE 413 END IF 414 END IF 415* 416* Save a copy of the matrix A in ASAV. 417* 418 CALL SLACPY( 'Full', KL+KU+1, N, A, LDA, ASAV, LDA ) 419* 420 DO 110 IEQUED = 1, 4 421 EQUED = EQUEDS( IEQUED ) 422 IF( IEQUED.EQ.1 ) THEN 423 NFACT = 3 424 ELSE 425 NFACT = 1 426 END IF 427* 428 DO 100 IFACT = 1, NFACT 429 FACT = FACTS( IFACT ) 430 PREFAC = LSAME( FACT, 'F' ) 431 NOFACT = LSAME( FACT, 'N' ) 432 EQUIL = LSAME( FACT, 'E' ) 433* 434 IF( ZEROT ) THEN 435 IF( PREFAC ) 436 $ GO TO 100 437 RCONDO = ZERO 438 RCONDI = ZERO 439* 440 ELSE IF( .NOT.NOFACT ) THEN 441* 442* Compute the condition number for comparison 443* with the value returned by SGESVX (FACT = 444* 'N' reuses the condition number from the 445* previous iteration with FACT = 'F'). 446* 447 CALL SLACPY( 'Full', KL+KU+1, N, ASAV, LDA, 448 $ AFB( KL+1 ), LDAFB ) 449 IF( EQUIL .OR. IEQUED.GT.1 ) THEN 450* 451* Compute row and column scale factors to 452* equilibrate the matrix A. 453* 454 CALL SGBEQU( N, N, KL, KU, AFB( KL+1 ), 455 $ LDAFB, S, S( N+1 ), ROWCND, 456 $ COLCND, AMAX, INFO ) 457 IF( INFO.EQ.0 .AND. N.GT.0 ) THEN 458 IF( LSAME( EQUED, 'R' ) ) THEN 459 ROWCND = ZERO 460 COLCND = ONE 461 ELSE IF( LSAME( EQUED, 'C' ) ) THEN 462 ROWCND = ONE 463 COLCND = ZERO 464 ELSE IF( LSAME( EQUED, 'B' ) ) THEN 465 ROWCND = ZERO 466 COLCND = ZERO 467 END IF 468* 469* Equilibrate the matrix. 470* 471 CALL SLAQGB( N, N, KL, KU, AFB( KL+1 ), 472 $ LDAFB, S, S( N+1 ), 473 $ ROWCND, COLCND, AMAX, 474 $ EQUED ) 475 END IF 476 END IF 477* 478* Save the condition number of the 479* non-equilibrated system for use in SGET04. 480* 481 IF( EQUIL ) THEN 482 ROLDO = RCONDO 483 ROLDI = RCONDI 484 END IF 485* 486* Compute the 1-norm and infinity-norm of A. 487* 488 ANORMO = SLANGB( '1', N, KL, KU, AFB( KL+1 ), 489 $ LDAFB, RWORK ) 490 ANORMI = SLANGB( 'I', N, KL, KU, AFB( KL+1 ), 491 $ LDAFB, RWORK ) 492* 493* Factor the matrix A. 494* 495 CALL SGBTRF( N, N, KL, KU, AFB, LDAFB, IWORK, 496 $ INFO ) 497* 498* Form the inverse of A. 499* 500 CALL SLASET( 'Full', N, N, ZERO, ONE, WORK, 501 $ LDB ) 502 SRNAMT = 'SGBTRS' 503 CALL SGBTRS( 'No transpose', N, KL, KU, N, 504 $ AFB, LDAFB, IWORK, WORK, LDB, 505 $ INFO ) 506* 507* Compute the 1-norm condition number of A. 508* 509 AINVNM = SLANGE( '1', N, N, WORK, LDB, 510 $ RWORK ) 511 IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 512 RCONDO = ONE 513 ELSE 514 RCONDO = ( ONE / ANORMO ) / AINVNM 515 END IF 516* 517* Compute the infinity-norm condition number 518* of A. 519* 520 AINVNM = SLANGE( 'I', N, N, WORK, LDB, 521 $ RWORK ) 522 IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 523 RCONDI = ONE 524 ELSE 525 RCONDI = ( ONE / ANORMI ) / AINVNM 526 END IF 527 END IF 528* 529 DO 90 ITRAN = 1, NTRAN 530* 531* Do for each value of TRANS. 532* 533 TRANS = TRANSS( ITRAN ) 534 IF( ITRAN.EQ.1 ) THEN 535 RCONDC = RCONDO 536 ELSE 537 RCONDC = RCONDI 538 END IF 539* 540* Restore the matrix A. 541* 542 CALL SLACPY( 'Full', KL+KU+1, N, ASAV, LDA, 543 $ A, LDA ) 544* 545* Form an exact solution and set the right hand 546* side. 547* 548 SRNAMT = 'SLARHS' 549 CALL SLARHS( PATH, XTYPE, 'Full', TRANS, N, 550 $ N, KL, KU, NRHS, A, LDA, XACT, 551 $ LDB, B, LDB, ISEED, INFO ) 552 XTYPE = 'C' 553 CALL SLACPY( 'Full', N, NRHS, B, LDB, BSAV, 554 $ LDB ) 555* 556 IF( NOFACT .AND. ITRAN.EQ.1 ) THEN 557* 558* --- Test SGBSV --- 559* 560* Compute the LU factorization of the matrix 561* and solve the system. 562* 563 CALL SLACPY( 'Full', KL+KU+1, N, A, LDA, 564 $ AFB( KL+1 ), LDAFB ) 565 CALL SLACPY( 'Full', N, NRHS, B, LDB, X, 566 $ LDB ) 567* 568 SRNAMT = 'SGBSV ' 569 CALL SGBSV( N, KL, KU, NRHS, AFB, LDAFB, 570 $ IWORK, X, LDB, INFO ) 571* 572* Check error code from SGBSV . 573* 574 IF( INFO.NE.IZERO ) 575 $ CALL ALAERH( PATH, 'SGBSV ', INFO, 576 $ IZERO, ' ', N, N, KL, KU, 577 $ NRHS, IMAT, NFAIL, NERRS, 578 $ NOUT ) 579* 580* Reconstruct matrix from factors and 581* compute residual. 582* 583 CALL SGBT01( N, N, KL, KU, A, LDA, AFB, 584 $ LDAFB, IWORK, WORK, 585 $ RESULT( 1 ) ) 586 NT = 1 587 IF( IZERO.EQ.0 ) THEN 588* 589* Compute residual of the computed 590* solution. 591* 592 CALL SLACPY( 'Full', N, NRHS, B, LDB, 593 $ WORK, LDB ) 594 CALL SGBT02( 'No transpose', N, N, KL, 595 $ KU, NRHS, A, LDA, X, LDB, 596 $ WORK, LDB, RESULT( 2 ) ) 597* 598* Check solution from generated exact 599* solution. 600* 601 CALL SGET04( N, NRHS, X, LDB, XACT, 602 $ LDB, RCONDC, RESULT( 3 ) ) 603 NT = 3 604 END IF 605* 606* Print information about the tests that did 607* not pass the threshold. 608* 609 DO 50 K = 1, NT 610 IF( RESULT( K ).GE.THRESH ) THEN 611 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 612 $ CALL ALADHD( NOUT, PATH ) 613 WRITE( NOUT, FMT = 9997 )'SGBSV ', 614 $ N, KL, KU, IMAT, K, RESULT( K ) 615 NFAIL = NFAIL + 1 616 END IF 617 50 CONTINUE 618 NRUN = NRUN + NT 619 END IF 620* 621* --- Test SGBSVX --- 622* 623 IF( .NOT.PREFAC ) 624 $ CALL SLASET( 'Full', 2*KL+KU+1, N, ZERO, 625 $ ZERO, AFB, LDAFB ) 626 CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, 627 $ LDB ) 628 IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN 629* 630* Equilibrate the matrix if FACT = 'F' and 631* EQUED = 'R', 'C', or 'B'. 632* 633 CALL SLAQGB( N, N, KL, KU, A, LDA, S, 634 $ S( N+1 ), ROWCND, COLCND, 635 $ AMAX, EQUED ) 636 END IF 637* 638* Solve the system and compute the condition 639* number and error bounds using SGBSVX. 640* 641 SRNAMT = 'SGBSVX' 642 CALL SGBSVX( FACT, TRANS, N, KL, KU, NRHS, A, 643 $ LDA, AFB, LDAFB, IWORK, EQUED, 644 $ S, S( N+1 ), B, LDB, X, LDB, 645 $ RCOND, RWORK, RWORK( NRHS+1 ), 646 $ WORK, IWORK( N+1 ), INFO ) 647* 648* Check the error code from SGBSVX. 649* 650 IF( INFO.NE.IZERO ) 651 $ CALL ALAERH( PATH, 'SGBSVX', INFO, IZERO, 652 $ FACT // TRANS, N, N, KL, KU, 653 $ NRHS, IMAT, NFAIL, NERRS, 654 $ NOUT ) 655* 656* Compare WORK(1) from SGBSVX with the computed 657* reciprocal pivot growth factor RPVGRW 658* 659 IF( INFO.NE.0 ) THEN 660 ANRMPV = ZERO 661 DO 70 J = 1, INFO 662 DO 60 I = MAX( KU+2-J, 1 ), 663 $ MIN( N+KU+1-J, KL+KU+1 ) 664 ANRMPV = MAX( ANRMPV, 665 $ ABS( A( I+( J-1 )*LDA ) ) ) 666 60 CONTINUE 667 70 CONTINUE 668 RPVGRW = SLANTB( 'M', 'U', 'N', INFO, 669 $ MIN( INFO-1, KL+KU ), 670 $ AFB( MAX( 1, KL+KU+2-INFO ) ), 671 $ LDAFB, WORK ) 672 IF( RPVGRW.EQ.ZERO ) THEN 673 RPVGRW = ONE 674 ELSE 675 RPVGRW = ANRMPV / RPVGRW 676 END IF 677 ELSE 678 RPVGRW = SLANTB( 'M', 'U', 'N', N, KL+KU, 679 $ AFB, LDAFB, WORK ) 680 IF( RPVGRW.EQ.ZERO ) THEN 681 RPVGRW = ONE 682 ELSE 683 RPVGRW = SLANGB( 'M', N, KL, KU, A, 684 $ LDA, WORK ) / RPVGRW 685 END IF 686 END IF 687 RESULT( 7 ) = ABS( RPVGRW-WORK( 1 ) ) / 688 $ MAX( WORK( 1 ), RPVGRW ) / 689 $ SLAMCH( 'E' ) 690* 691 IF( .NOT.PREFAC ) THEN 692* 693* Reconstruct matrix from factors and 694* compute residual. 695* 696 CALL SGBT01( N, N, KL, KU, A, LDA, AFB, 697 $ LDAFB, IWORK, WORK, 698 $ RESULT( 1 ) ) 699 K1 = 1 700 ELSE 701 K1 = 2 702 END IF 703* 704 IF( INFO.EQ.0 ) THEN 705 TRFCON = .FALSE. 706* 707* Compute residual of the computed solution. 708* 709 CALL SLACPY( 'Full', N, NRHS, BSAV, LDB, 710 $ WORK, LDB ) 711 CALL SGBT02( TRANS, N, N, KL, KU, NRHS, 712 $ ASAV, LDA, X, LDB, WORK, LDB, 713 $ RESULT( 2 ) ) 714* 715* Check solution from generated exact 716* solution. 717* 718 IF( NOFACT .OR. ( PREFAC .AND. 719 $ LSAME( EQUED, 'N' ) ) ) THEN 720 CALL SGET04( N, NRHS, X, LDB, XACT, 721 $ LDB, RCONDC, RESULT( 3 ) ) 722 ELSE 723 IF( ITRAN.EQ.1 ) THEN 724 ROLDC = ROLDO 725 ELSE 726 ROLDC = ROLDI 727 END IF 728 CALL SGET04( N, NRHS, X, LDB, XACT, 729 $ LDB, ROLDC, RESULT( 3 ) ) 730 END IF 731* 732* Check the error bounds from iterative 733* refinement. 734* 735 CALL SGBT05( TRANS, N, KL, KU, NRHS, ASAV, 736 $ LDA, B, LDB, X, LDB, XACT, 737 $ LDB, RWORK, RWORK( NRHS+1 ), 738 $ RESULT( 4 ) ) 739 ELSE 740 TRFCON = .TRUE. 741 END IF 742* 743* Compare RCOND from SGBSVX with the computed 744* value in RCONDC. 745* 746 RESULT( 6 ) = SGET06( RCOND, RCONDC ) 747* 748* Print information about the tests that did 749* not pass the threshold. 750* 751 IF( .NOT.TRFCON ) THEN 752 DO 80 K = K1, NTESTS 753 IF( RESULT( K ).GE.THRESH ) THEN 754 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 755 $ CALL ALADHD( NOUT, PATH ) 756 IF( PREFAC ) THEN 757 WRITE( NOUT, FMT = 9995 ) 758 $ 'SGBSVX', FACT, TRANS, N, KL, 759 $ KU, EQUED, IMAT, K, 760 $ RESULT( K ) 761 ELSE 762 WRITE( NOUT, FMT = 9996 ) 763 $ 'SGBSVX', FACT, TRANS, N, KL, 764 $ KU, IMAT, K, RESULT( K ) 765 END IF 766 NFAIL = NFAIL + 1 767 END IF 768 80 CONTINUE 769 NRUN = NRUN + 7 - K1 770 ELSE 771 IF( RESULT( 1 ).GE.THRESH .AND. .NOT. 772 $ PREFAC ) THEN 773 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 774 $ CALL ALADHD( NOUT, PATH ) 775 IF( PREFAC ) THEN 776 WRITE( NOUT, FMT = 9995 )'SGBSVX', 777 $ FACT, TRANS, N, KL, KU, EQUED, 778 $ IMAT, 1, RESULT( 1 ) 779 ELSE 780 WRITE( NOUT, FMT = 9996 )'SGBSVX', 781 $ FACT, TRANS, N, KL, KU, IMAT, 1, 782 $ RESULT( 1 ) 783 END IF 784 NFAIL = NFAIL + 1 785 NRUN = NRUN + 1 786 END IF 787 IF( RESULT( 6 ).GE.THRESH ) THEN 788 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 789 $ CALL ALADHD( NOUT, PATH ) 790 IF( PREFAC ) THEN 791 WRITE( NOUT, FMT = 9995 )'SGBSVX', 792 $ FACT, TRANS, N, KL, KU, EQUED, 793 $ IMAT, 6, RESULT( 6 ) 794 ELSE 795 WRITE( NOUT, FMT = 9996 )'SGBSVX', 796 $ FACT, TRANS, N, KL, KU, IMAT, 6, 797 $ RESULT( 6 ) 798 END IF 799 NFAIL = NFAIL + 1 800 NRUN = NRUN + 1 801 END IF 802 IF( RESULT( 7 ).GE.THRESH ) THEN 803 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 804 $ CALL ALADHD( NOUT, PATH ) 805 IF( PREFAC ) THEN 806 WRITE( NOUT, FMT = 9995 )'SGBSVX', 807 $ FACT, TRANS, N, KL, KU, EQUED, 808 $ IMAT, 7, RESULT( 7 ) 809 ELSE 810 WRITE( NOUT, FMT = 9996 )'SGBSVX', 811 $ FACT, TRANS, N, KL, KU, IMAT, 7, 812 $ RESULT( 7 ) 813 END IF 814 NFAIL = NFAIL + 1 815 NRUN = NRUN + 1 816 END IF 817* 818 END IF 819* 820* --- Test SGBSVXX --- 821* 822* Restore the matrices A and B. 823* 824 CALL SLACPY( 'Full', KL+KU+1, N, ASAV, LDA, A, 825 $ LDA ) 826 CALL SLACPY( 'Full', N, NRHS, BSAV, LDB, B, LDB ) 827 828 IF( .NOT.PREFAC ) 829 $ CALL SLASET( 'Full', 2*KL+KU+1, N, ZERO, ZERO, 830 $ AFB, LDAFB ) 831 CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDB ) 832 IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN 833* 834* Equilibrate the matrix if FACT = 'F' and 835* EQUED = 'R', 'C', or 'B'. 836* 837 CALL SLAQGB( N, N, KL, KU, A, LDA, S, 838 $ S( N+1 ), ROWCND, COLCND, AMAX, EQUED ) 839 END IF 840* 841* Solve the system and compute the condition number 842* and error bounds using SGBSVXX. 843* 844 SRNAMT = 'SGBSVXX' 845 N_ERR_BNDS = 3 846 CALL SGBSVXX( FACT, TRANS, N, KL, KU, NRHS, A, LDA, 847 $ AFB, LDAFB, IWORK, EQUED, S, S( N+1 ), B, LDB, 848 $ X, LDB, RCOND, RPVGRW_SVXX, BERR, N_ERR_BNDS, 849 $ ERRBNDS_N, ERRBNDS_C, 0, ZERO, WORK, 850 $ IWORK( N+1 ), INFO ) 851 852* Check the error code from SGBSVXX. 853* 854 IF( INFO.EQ.N+1 ) GOTO 90 855 IF( INFO.NE.IZERO ) THEN 856 CALL ALAERH( PATH, 'SGBSVXX', INFO, IZERO, 857 $ FACT // TRANS, N, N, -1, -1, NRHS, 858 $ IMAT, NFAIL, NERRS, NOUT ) 859 GOTO 90 860 END IF 861* 862* Compare rpvgrw_svxx from SGBSVXX with the computed 863* reciprocal pivot growth factor RPVGRW 864* 865 866 IF ( INFO .GT. 0 .AND. INFO .LT. N+1 ) THEN 867 RPVGRW = SLA_GBRPVGRW(N, KL, KU, INFO, A, LDA, 868 $ AFB, LDAFB ) 869 ELSE 870 RPVGRW = SLA_GBRPVGRW(N, KL, KU, N, A, LDA, 871 $ AFB, LDAFB ) 872 ENDIF 873 874 RESULT( 7 ) = ABS( RPVGRW-rpvgrw_svxx ) / 875 $ MAX( rpvgrw_svxx, RPVGRW ) / 876 $ SLAMCH( 'E' ) 877* 878 IF( .NOT.PREFAC ) THEN 879* 880* Reconstruct matrix from factors and compute 881* residual. 882* 883 CALL SGBT01( N, N, KL, KU, A, LDA, AFB, LDAFB, 884 $ IWORK, WORK, 885 $ RESULT( 1 ) ) 886 K1 = 1 887 ELSE 888 K1 = 2 889 END IF 890* 891 IF( INFO.EQ.0 ) THEN 892 TRFCON = .FALSE. 893* 894* Compute residual of the computed solution. 895* 896 CALL SLACPY( 'Full', N, NRHS, BSAV, LDB, WORK, 897 $ LDB ) 898 CALL SGBT02( TRANS, N, N, KL, KU, NRHS, ASAV, 899 $ LDA, X, LDB, WORK, LDB, 900 $ RESULT( 2 ) ) 901* 902* Check solution from generated exact solution. 903* 904 IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, 905 $ 'N' ) ) ) THEN 906 CALL SGET04( N, NRHS, X, LDB, XACT, LDB, 907 $ RCONDC, RESULT( 3 ) ) 908 ELSE 909 IF( ITRAN.EQ.1 ) THEN 910 ROLDC = ROLDO 911 ELSE 912 ROLDC = ROLDI 913 END IF 914 CALL SGET04( N, NRHS, X, LDB, XACT, LDB, 915 $ ROLDC, RESULT( 3 ) ) 916 END IF 917 ELSE 918 TRFCON = .TRUE. 919 END IF 920* 921* Compare RCOND from SGBSVXX with the computed value 922* in RCONDC. 923* 924 RESULT( 6 ) = SGET06( RCOND, RCONDC ) 925* 926* Print information about the tests that did not pass 927* the threshold. 928* 929 IF( .NOT.TRFCON ) THEN 930 DO 45 K = K1, NTESTS 931 IF( RESULT( K ).GE.THRESH ) THEN 932 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 933 $ CALL ALADHD( NOUT, PATH ) 934 IF( PREFAC ) THEN 935 WRITE( NOUT, FMT = 9995 )'SGBSVXX', 936 $ FACT, TRANS, N, KL, KU, EQUED, 937 $ IMAT, K, RESULT( K ) 938 ELSE 939 WRITE( NOUT, FMT = 9996 )'SGBSVXX', 940 $ FACT, TRANS, N, KL, KU, IMAT, K, 941 $ RESULT( K ) 942 END IF 943 NFAIL = NFAIL + 1 944 END IF 945 45 CONTINUE 946 NRUN = NRUN + 7 - K1 947 ELSE 948 IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC ) 949 $ THEN 950 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 951 $ CALL ALADHD( NOUT, PATH ) 952 IF( PREFAC ) THEN 953 WRITE( NOUT, FMT = 9995 )'SGBSVXX', FACT, 954 $ TRANS, N, KL, KU, EQUED, IMAT, 1, 955 $ RESULT( 1 ) 956 ELSE 957 WRITE( NOUT, FMT = 9996 )'SGBSVXX', FACT, 958 $ TRANS, N, KL, KU, IMAT, 1, 959 $ RESULT( 1 ) 960 END IF 961 NFAIL = NFAIL + 1 962 NRUN = NRUN + 1 963 END IF 964 IF( RESULT( 6 ).GE.THRESH ) THEN 965 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 966 $ CALL ALADHD( NOUT, PATH ) 967 IF( PREFAC ) THEN 968 WRITE( NOUT, FMT = 9995 )'SGBSVXX', FACT, 969 $ TRANS, N, KL, KU, EQUED, IMAT, 6, 970 $ RESULT( 6 ) 971 ELSE 972 WRITE( NOUT, FMT = 9996 )'SGBSVXX', FACT, 973 $ TRANS, N, KL, KU, IMAT, 6, 974 $ RESULT( 6 ) 975 END IF 976 NFAIL = NFAIL + 1 977 NRUN = NRUN + 1 978 END IF 979 IF( RESULT( 7 ).GE.THRESH ) THEN 980 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 981 $ CALL ALADHD( NOUT, PATH ) 982 IF( PREFAC ) THEN 983 WRITE( NOUT, FMT = 9995 )'SGBSVXX', FACT, 984 $ TRANS, N, KL, KU, EQUED, IMAT, 7, 985 $ RESULT( 7 ) 986 ELSE 987 WRITE( NOUT, FMT = 9996 )'SGBSVXX', FACT, 988 $ TRANS, N, KL, KU, IMAT, 7, 989 $ RESULT( 7 ) 990 END IF 991 NFAIL = NFAIL + 1 992 NRUN = NRUN + 1 993 END IF 994 995 END IF 996* 997 90 CONTINUE 998 100 CONTINUE 999 110 CONTINUE 1000 120 CONTINUE 1001 130 CONTINUE 1002 140 CONTINUE 1003 150 CONTINUE 1004* 1005* Print a summary of the results. 1006* 1007 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) 1008* 1009 1010* Test Error Bounds from SGBSVXX 1011 1012 CALL SEBCHVXX(THRESH, PATH) 1013 1014 9999 FORMAT( ' *** In SDRVGB, LA=', I5, ' is too small for N=', I5, 1015 $ ', KU=', I5, ', KL=', I5, / ' ==> Increase LA to at least ', 1016 $ I5 ) 1017 9998 FORMAT( ' *** In SDRVGB, LAFB=', I5, ' is too small for N=', I5, 1018 $ ', KU=', I5, ', KL=', I5, / 1019 $ ' ==> Increase LAFB to at least ', I5 ) 1020 9997 FORMAT( 1X, A, ', N=', I5, ', KL=', I5, ', KU=', I5, ', type ', 1021 $ I1, ', test(', I1, ')=', G12.5 ) 1022 9996 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',', 1023 $ I5, ',...), type ', I1, ', test(', I1, ')=', G12.5 ) 1024 9995 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',', 1025 $ I5, ',...), EQUED=''', A1, ''', type ', I1, ', test(', I1, 1026 $ ')=', G12.5 ) 1027* 1028 RETURN 1029* 1030* End of SDRVGB 1031* 1032 END 1033