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