1*> \brief \b SDRVGT 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 SDRVGT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, AF, 12* B, X, XACT, WORK, RWORK, IWORK, NOUT ) 13* 14* .. Scalar Arguments .. 15* LOGICAL TSTERR 16* INTEGER NN, NOUT, NRHS 17* REAL THRESH 18* .. 19* .. Array Arguments .. 20* LOGICAL DOTYPE( * ) 21* INTEGER IWORK( * ), NVAL( * ) 22* REAL A( * ), AF( * ), B( * ), RWORK( * ), WORK( * ), 23* $ X( * ), XACT( * ) 24* .. 25* 26* 27*> \par Purpose: 28* ============= 29*> 30*> \verbatim 31*> 32*> SDRVGT tests SGTSV and -SVX. 33*> \endverbatim 34* 35* Arguments: 36* ========== 37* 38*> \param[in] DOTYPE 39*> \verbatim 40*> DOTYPE is LOGICAL array, dimension (NTYPES) 41*> The matrix types to be used for testing. Matrices of type j 42*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 43*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 44*> \endverbatim 45*> 46*> \param[in] NN 47*> \verbatim 48*> NN is INTEGER 49*> The number of values of N contained in the vector NVAL. 50*> \endverbatim 51*> 52*> \param[in] NVAL 53*> \verbatim 54*> NVAL is INTEGER array, dimension (NN) 55*> The values of the matrix dimension N. 56*> \endverbatim 57*> 58*> \param[in] NRHS 59*> \verbatim 60*> NRHS is INTEGER 61*> The number of right hand sides, NRHS >= 0. 62*> \endverbatim 63*> 64*> \param[in] THRESH 65*> \verbatim 66*> THRESH is REAL 67*> The threshold value for the test ratios. A result is 68*> included in the output file if RESULT >= THRESH. To have 69*> every test ratio printed, use THRESH = 0. 70*> \endverbatim 71*> 72*> \param[in] TSTERR 73*> \verbatim 74*> TSTERR is LOGICAL 75*> Flag that indicates whether error exits are to be tested. 76*> \endverbatim 77*> 78*> \param[out] A 79*> \verbatim 80*> A is REAL array, dimension (NMAX*4) 81*> \endverbatim 82*> 83*> \param[out] AF 84*> \verbatim 85*> AF is REAL array, dimension (NMAX*4) 86*> \endverbatim 87*> 88*> \param[out] B 89*> \verbatim 90*> B is REAL array, dimension (NMAX*NRHS) 91*> \endverbatim 92*> 93*> \param[out] X 94*> \verbatim 95*> X is REAL array, dimension (NMAX*NRHS) 96*> \endverbatim 97*> 98*> \param[out] XACT 99*> \verbatim 100*> XACT is REAL array, dimension (NMAX*NRHS) 101*> \endverbatim 102*> 103*> \param[out] WORK 104*> \verbatim 105*> WORK is REAL array, dimension 106*> (NMAX*max(3,NRHS)) 107*> \endverbatim 108*> 109*> \param[out] RWORK 110*> \verbatim 111*> RWORK is REAL array, dimension 112*> (max(NMAX,2*NRHS)) 113*> \endverbatim 114*> 115*> \param[out] IWORK 116*> \verbatim 117*> IWORK is INTEGER array, dimension (2*NMAX) 118*> \endverbatim 119*> 120*> \param[in] NOUT 121*> \verbatim 122*> NOUT is INTEGER 123*> The unit number for output. 124*> \endverbatim 125* 126* Authors: 127* ======== 128* 129*> \author Univ. of Tennessee 130*> \author Univ. of California Berkeley 131*> \author Univ. of Colorado Denver 132*> \author NAG Ltd. 133* 134*> \ingroup single_lin 135* 136* ===================================================================== 137 SUBROUTINE SDRVGT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, AF, 138 $ B, X, XACT, WORK, RWORK, IWORK, NOUT ) 139* 140* -- LAPACK test routine -- 141* -- LAPACK is a software package provided by Univ. of Tennessee, -- 142* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 143* 144* .. Scalar Arguments .. 145 LOGICAL TSTERR 146 INTEGER NN, NOUT, NRHS 147 REAL THRESH 148* .. 149* .. Array Arguments .. 150 LOGICAL DOTYPE( * ) 151 INTEGER IWORK( * ), NVAL( * ) 152 REAL A( * ), AF( * ), B( * ), RWORK( * ), WORK( * ), 153 $ X( * ), XACT( * ) 154* .. 155* 156* ===================================================================== 157* 158* .. Parameters .. 159 REAL ONE, ZERO 160 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 161 INTEGER NTYPES 162 PARAMETER ( NTYPES = 12 ) 163 INTEGER NTESTS 164 PARAMETER ( NTESTS = 6 ) 165* .. 166* .. Local Scalars .. 167 LOGICAL TRFCON, ZEROT 168 CHARACTER DIST, FACT, TRANS, TYPE 169 CHARACTER*3 PATH 170 INTEGER I, IFACT, IMAT, IN, INFO, ITRAN, IX, IZERO, J, 171 $ K, K1, KL, KOFF, KU, LDA, M, MODE, N, NERRS, 172 $ NFAIL, NIMAT, NRUN, NT 173 REAL AINVNM, ANORM, ANORMI, ANORMO, COND, RCOND, 174 $ RCONDC, RCONDI, RCONDO 175* .. 176* .. Local Arrays .. 177 CHARACTER TRANSS( 3 ) 178 INTEGER ISEED( 4 ), ISEEDY( 4 ) 179 REAL RESULT( NTESTS ), Z( 3 ) 180* .. 181* .. External Functions .. 182 REAL SASUM, SGET06, SLANGT 183 EXTERNAL SASUM, SGET06, SLANGT 184* .. 185* .. External Subroutines .. 186 EXTERNAL ALADHD, ALAERH, ALASVM, SCOPY, SERRVX, SGET04, 187 $ SGTSV, SGTSVX, SGTT01, SGTT02, SGTT05, SGTTRF, 188 $ SGTTRS, SLACPY, SLAGTM, SLARNV, SLASET, SLATB4, 189 $ SLATMS, SSCAL 190* .. 191* .. Intrinsic Functions .. 192 INTRINSIC MAX 193* .. 194* .. Scalars in Common .. 195 LOGICAL LERR, OK 196 CHARACTER*32 SRNAMT 197 INTEGER INFOT, NUNIT 198* .. 199* .. Common blocks .. 200 COMMON / INFOC / INFOT, NUNIT, OK, LERR 201 COMMON / SRNAMC / SRNAMT 202* .. 203* .. Data statements .. 204 DATA ISEEDY / 0, 0, 0, 1 / , TRANSS / 'N', 'T', 205 $ 'C' / 206* .. 207* .. Executable Statements .. 208* 209 PATH( 1: 1 ) = 'Single precision' 210 PATH( 2: 3 ) = 'GT' 211 NRUN = 0 212 NFAIL = 0 213 NERRS = 0 214 DO 10 I = 1, 4 215 ISEED( I ) = ISEEDY( I ) 216 10 CONTINUE 217* 218* Test the error exits 219* 220 IF( TSTERR ) 221 $ CALL SERRVX( PATH, NOUT ) 222 INFOT = 0 223* 224 DO 140 IN = 1, NN 225* 226* Do for each value of N in NVAL. 227* 228 N = NVAL( IN ) 229 M = MAX( N-1, 0 ) 230 LDA = MAX( 1, N ) 231 NIMAT = NTYPES 232 IF( N.LE.0 ) 233 $ NIMAT = 1 234* 235 DO 130 IMAT = 1, NIMAT 236* 237* Do the tests only if DOTYPE( IMAT ) is true. 238* 239 IF( .NOT.DOTYPE( IMAT ) ) 240 $ GO TO 130 241* 242* Set up parameters with SLATB4. 243* 244 CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 245 $ COND, DIST ) 246* 247 ZEROT = IMAT.GE.8 .AND. IMAT.LE.10 248 IF( IMAT.LE.6 ) THEN 249* 250* Types 1-6: generate matrices of known condition number. 251* 252 KOFF = MAX( 2-KU, 3-MAX( 1, N ) ) 253 SRNAMT = 'SLATMS' 254 CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, COND, 255 $ ANORM, KL, KU, 'Z', AF( KOFF ), 3, WORK, 256 $ INFO ) 257* 258* Check the error code from SLATMS. 259* 260 IF( INFO.NE.0 ) THEN 261 CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', N, N, KL, 262 $ KU, -1, IMAT, NFAIL, NERRS, NOUT ) 263 GO TO 130 264 END IF 265 IZERO = 0 266* 267 IF( N.GT.1 ) THEN 268 CALL SCOPY( N-1, AF( 4 ), 3, A, 1 ) 269 CALL SCOPY( N-1, AF( 3 ), 3, A( N+M+1 ), 1 ) 270 END IF 271 CALL SCOPY( N, AF( 2 ), 3, A( M+1 ), 1 ) 272 ELSE 273* 274* Types 7-12: generate tridiagonal matrices with 275* unknown condition numbers. 276* 277 IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 7 ) ) THEN 278* 279* Generate a matrix with elements from [-1,1]. 280* 281 CALL SLARNV( 2, ISEED, N+2*M, A ) 282 IF( ANORM.NE.ONE ) 283 $ CALL SSCAL( N+2*M, ANORM, A, 1 ) 284 ELSE IF( IZERO.GT.0 ) THEN 285* 286* Reuse the last matrix by copying back the zeroed out 287* elements. 288* 289 IF( IZERO.EQ.1 ) THEN 290 A( N ) = Z( 2 ) 291 IF( N.GT.1 ) 292 $ A( 1 ) = Z( 3 ) 293 ELSE IF( IZERO.EQ.N ) THEN 294 A( 3*N-2 ) = Z( 1 ) 295 A( 2*N-1 ) = Z( 2 ) 296 ELSE 297 A( 2*N-2+IZERO ) = Z( 1 ) 298 A( N-1+IZERO ) = Z( 2 ) 299 A( IZERO ) = Z( 3 ) 300 END IF 301 END IF 302* 303* If IMAT > 7, set one column of the matrix to 0. 304* 305 IF( .NOT.ZEROT ) THEN 306 IZERO = 0 307 ELSE IF( IMAT.EQ.8 ) THEN 308 IZERO = 1 309 Z( 2 ) = A( N ) 310 A( N ) = ZERO 311 IF( N.GT.1 ) THEN 312 Z( 3 ) = A( 1 ) 313 A( 1 ) = ZERO 314 END IF 315 ELSE IF( IMAT.EQ.9 ) THEN 316 IZERO = N 317 Z( 1 ) = A( 3*N-2 ) 318 Z( 2 ) = A( 2*N-1 ) 319 A( 3*N-2 ) = ZERO 320 A( 2*N-1 ) = ZERO 321 ELSE 322 IZERO = ( N+1 ) / 2 323 DO 20 I = IZERO, N - 1 324 A( 2*N-2+I ) = ZERO 325 A( N-1+I ) = ZERO 326 A( I ) = ZERO 327 20 CONTINUE 328 A( 3*N-2 ) = ZERO 329 A( 2*N-1 ) = ZERO 330 END IF 331 END IF 332* 333 DO 120 IFACT = 1, 2 334 IF( IFACT.EQ.1 ) THEN 335 FACT = 'F' 336 ELSE 337 FACT = 'N' 338 END IF 339* 340* Compute the condition number for comparison with 341* the value returned by SGTSVX. 342* 343 IF( ZEROT ) THEN 344 IF( IFACT.EQ.1 ) 345 $ GO TO 120 346 RCONDO = ZERO 347 RCONDI = ZERO 348* 349 ELSE IF( IFACT.EQ.1 ) THEN 350 CALL SCOPY( N+2*M, A, 1, AF, 1 ) 351* 352* Compute the 1-norm and infinity-norm of A. 353* 354 ANORMO = SLANGT( '1', N, A, A( M+1 ), A( N+M+1 ) ) 355 ANORMI = SLANGT( 'I', N, A, A( M+1 ), A( N+M+1 ) ) 356* 357* Factor the matrix A. 358* 359 CALL SGTTRF( N, AF, AF( M+1 ), AF( N+M+1 ), 360 $ AF( N+2*M+1 ), IWORK, INFO ) 361* 362* Use SGTTRS to solve for one column at a time of 363* inv(A), computing the maximum column sum as we go. 364* 365 AINVNM = ZERO 366 DO 40 I = 1, N 367 DO 30 J = 1, N 368 X( J ) = ZERO 369 30 CONTINUE 370 X( I ) = ONE 371 CALL SGTTRS( 'No transpose', N, 1, AF, AF( M+1 ), 372 $ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X, 373 $ LDA, INFO ) 374 AINVNM = MAX( AINVNM, SASUM( N, X, 1 ) ) 375 40 CONTINUE 376* 377* Compute the 1-norm condition number of A. 378* 379 IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 380 RCONDO = ONE 381 ELSE 382 RCONDO = ( ONE / ANORMO ) / AINVNM 383 END IF 384* 385* Use SGTTRS to solve for one column at a time of 386* inv(A'), computing the maximum column sum as we go. 387* 388 AINVNM = ZERO 389 DO 60 I = 1, N 390 DO 50 J = 1, N 391 X( J ) = ZERO 392 50 CONTINUE 393 X( I ) = ONE 394 CALL SGTTRS( 'Transpose', N, 1, AF, AF( M+1 ), 395 $ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X, 396 $ LDA, INFO ) 397 AINVNM = MAX( AINVNM, SASUM( N, X, 1 ) ) 398 60 CONTINUE 399* 400* Compute the infinity-norm condition number of A. 401* 402 IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 403 RCONDI = ONE 404 ELSE 405 RCONDI = ( ONE / ANORMI ) / AINVNM 406 END IF 407 END IF 408* 409 DO 110 ITRAN = 1, 3 410 TRANS = TRANSS( ITRAN ) 411 IF( ITRAN.EQ.1 ) THEN 412 RCONDC = RCONDO 413 ELSE 414 RCONDC = RCONDI 415 END IF 416* 417* Generate NRHS random solution vectors. 418* 419 IX = 1 420 DO 70 J = 1, NRHS 421 CALL SLARNV( 2, ISEED, N, XACT( IX ) ) 422 IX = IX + LDA 423 70 CONTINUE 424* 425* Set the right hand side. 426* 427 CALL SLAGTM( TRANS, N, NRHS, ONE, A, A( M+1 ), 428 $ A( N+M+1 ), XACT, LDA, ZERO, B, LDA ) 429* 430 IF( IFACT.EQ.2 .AND. ITRAN.EQ.1 ) THEN 431* 432* --- Test SGTSV --- 433* 434* Solve the system using Gaussian elimination with 435* partial pivoting. 436* 437 CALL SCOPY( N+2*M, A, 1, AF, 1 ) 438 CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 439* 440 SRNAMT = 'SGTSV ' 441 CALL SGTSV( N, NRHS, AF, AF( M+1 ), AF( N+M+1 ), X, 442 $ LDA, INFO ) 443* 444* Check error code from SGTSV . 445* 446 IF( INFO.NE.IZERO ) 447 $ CALL ALAERH( PATH, 'SGTSV ', INFO, IZERO, ' ', 448 $ N, N, 1, 1, NRHS, IMAT, NFAIL, 449 $ NERRS, NOUT ) 450 NT = 1 451 IF( IZERO.EQ.0 ) THEN 452* 453* Check residual of computed solution. 454* 455 CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, 456 $ LDA ) 457 CALL SGTT02( TRANS, N, NRHS, A, A( M+1 ), 458 $ A( N+M+1 ), X, LDA, WORK, LDA, 459 $ RESULT( 2 ) ) 460* 461* Check solution from generated exact solution. 462* 463 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 464 $ RESULT( 3 ) ) 465 NT = 3 466 END IF 467* 468* Print information about the tests that did not pass 469* the threshold. 470* 471 DO 80 K = 2, NT 472 IF( RESULT( K ).GE.THRESH ) THEN 473 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 474 $ CALL ALADHD( NOUT, PATH ) 475 WRITE( NOUT, FMT = 9999 )'SGTSV ', N, IMAT, 476 $ K, RESULT( K ) 477 NFAIL = NFAIL + 1 478 END IF 479 80 CONTINUE 480 NRUN = NRUN + NT - 1 481 END IF 482* 483* --- Test SGTSVX --- 484* 485 IF( IFACT.GT.1 ) THEN 486* 487* Initialize AF to zero. 488* 489 DO 90 I = 1, 3*N - 2 490 AF( I ) = ZERO 491 90 CONTINUE 492 END IF 493 CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA ) 494* 495* Solve the system and compute the condition number and 496* error bounds using SGTSVX. 497* 498 SRNAMT = 'SGTSVX' 499 CALL SGTSVX( FACT, TRANS, N, NRHS, A, A( M+1 ), 500 $ A( N+M+1 ), AF, AF( M+1 ), AF( N+M+1 ), 501 $ AF( N+2*M+1 ), IWORK, B, LDA, X, LDA, 502 $ RCOND, RWORK, RWORK( NRHS+1 ), WORK, 503 $ IWORK( N+1 ), INFO ) 504* 505* Check the error code from SGTSVX. 506* 507 IF( INFO.NE.IZERO ) 508 $ CALL ALAERH( PATH, 'SGTSVX', INFO, IZERO, 509 $ FACT // TRANS, N, N, 1, 1, NRHS, IMAT, 510 $ NFAIL, NERRS, NOUT ) 511* 512 IF( IFACT.GE.2 ) THEN 513* 514* Reconstruct matrix from factors and compute 515* residual. 516* 517 CALL SGTT01( N, A, A( M+1 ), A( N+M+1 ), AF, 518 $ AF( M+1 ), AF( N+M+1 ), AF( N+2*M+1 ), 519 $ IWORK, WORK, LDA, RWORK, RESULT( 1 ) ) 520 K1 = 1 521 ELSE 522 K1 = 2 523 END IF 524* 525 IF( INFO.EQ.0 ) THEN 526 TRFCON = .FALSE. 527* 528* Check residual of computed solution. 529* 530 CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) 531 CALL SGTT02( TRANS, N, NRHS, A, A( M+1 ), 532 $ A( N+M+1 ), X, LDA, WORK, LDA, 533 $ RESULT( 2 ) ) 534* 535* Check solution from generated exact solution. 536* 537 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 538 $ RESULT( 3 ) ) 539* 540* Check the error bounds from iterative refinement. 541* 542 CALL SGTT05( TRANS, N, NRHS, A, A( M+1 ), 543 $ A( N+M+1 ), B, LDA, X, LDA, XACT, LDA, 544 $ RWORK, RWORK( NRHS+1 ), RESULT( 4 ) ) 545 NT = 5 546 END IF 547* 548* Print information about the tests that did not pass 549* the threshold. 550* 551 DO 100 K = K1, NT 552 IF( RESULT( K ).GE.THRESH ) THEN 553 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 554 $ CALL ALADHD( NOUT, PATH ) 555 WRITE( NOUT, FMT = 9998 )'SGTSVX', FACT, TRANS, 556 $ N, IMAT, K, RESULT( K ) 557 NFAIL = NFAIL + 1 558 END IF 559 100 CONTINUE 560* 561* Check the reciprocal of the condition number. 562* 563 RESULT( 6 ) = SGET06( RCOND, RCONDC ) 564 IF( RESULT( 6 ).GE.THRESH ) THEN 565 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 566 $ CALL ALADHD( NOUT, PATH ) 567 WRITE( NOUT, FMT = 9998 )'SGTSVX', FACT, TRANS, N, 568 $ IMAT, K, RESULT( K ) 569 NFAIL = NFAIL + 1 570 END IF 571 NRUN = NRUN + NT - K1 + 2 572* 573 110 CONTINUE 574 120 CONTINUE 575 130 CONTINUE 576 140 CONTINUE 577* 578* Print a summary of the results. 579* 580 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) 581* 582 9999 FORMAT( 1X, A, ', N =', I5, ', type ', I2, ', test ', I2, 583 $ ', ratio = ', G12.5 ) 584 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N =', 585 $ I5, ', type ', I2, ', test ', I2, ', ratio = ', G12.5 ) 586 RETURN 587* 588* End of SDRVGT 589* 590 END 591