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