1*> \brief \b SCHKPT 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 SCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, 12* A, D, E, B, X, XACT, WORK, RWORK, 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 NSVAL( * ), NVAL( * ) 22* REAL A( * ), B( * ), D( * ), E( * ), RWORK( * ), 23* $ WORK( * ), X( * ), XACT( * ) 24* .. 25* 26* 27*> \par Purpose: 28* ============= 29*> 30*> \verbatim 31*> 32*> SCHKPT tests SPTTRF, -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*2) 87*> \endverbatim 88*> 89*> \param[out] D 90*> \verbatim 91*> D is REAL array, dimension (NMAX*2) 92*> \endverbatim 93*> 94*> \param[out] E 95*> \verbatim 96*> E is REAL array, dimension (NMAX*2) 97*> \endverbatim 98*> 99*> \param[out] B 100*> \verbatim 101*> B is REAL array, dimension (NMAX*NSMAX) 102*> where NSMAX is the largest entry in NSVAL. 103*> \endverbatim 104*> 105*> \param[out] X 106*> \verbatim 107*> X is REAL array, dimension (NMAX*NSMAX) 108*> \endverbatim 109*> 110*> \param[out] XACT 111*> \verbatim 112*> XACT is REAL array, dimension (NMAX*NSMAX) 113*> \endverbatim 114*> 115*> \param[out] WORK 116*> \verbatim 117*> WORK is REAL array, dimension 118*> (NMAX*max(3,NSMAX)) 119*> \endverbatim 120*> 121*> \param[out] RWORK 122*> \verbatim 123*> RWORK is REAL array, dimension 124*> (max(NMAX,2*NSMAX)) 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 November 2011 142* 143*> \ingroup single_lin 144* 145* ===================================================================== 146 SUBROUTINE SCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, 147 $ A, D, E, B, X, XACT, WORK, RWORK, NOUT ) 148* 149* -- LAPACK test routine (version 3.4.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* November 2011 153* 154* .. Scalar Arguments .. 155 LOGICAL TSTERR 156 INTEGER NN, NNS, NOUT 157 REAL THRESH 158* .. 159* .. Array Arguments .. 160 LOGICAL DOTYPE( * ) 161 INTEGER NSVAL( * ), NVAL( * ) 162 REAL A( * ), B( * ), D( * ), E( * ), RWORK( * ), 163 $ WORK( * ), 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 ZEROT 178 CHARACTER DIST, TYPE 179 CHARACTER*3 PATH 180 INTEGER I, IA, IMAT, IN, INFO, IRHS, IX, IZERO, J, K, 181 $ KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT, 182 $ NRHS, NRUN 183 REAL AINVNM, ANORM, COND, DMAX, RCOND, RCONDC 184* .. 185* .. Local Arrays .. 186 INTEGER ISEED( 4 ), ISEEDY( 4 ) 187 REAL RESULT( NTESTS ), Z( 3 ) 188* .. 189* .. External Functions .. 190 INTEGER ISAMAX 191 REAL SASUM, SGET06, SLANST 192 EXTERNAL ISAMAX, SASUM, SGET06, SLANST 193* .. 194* .. External Subroutines .. 195 EXTERNAL ALAERH, ALAHD, ALASUM, SCOPY, SERRGT, SGET04, 196 $ SLACPY, SLAPTM, SLARNV, SLATB4, SLATMS, SPTCON, 197 $ SPTRFS, SPTT01, SPTT02, SPTT05, SPTTRF, SPTTRS, 198 $ SSCAL 199* .. 200* .. Intrinsic Functions .. 201 INTRINSIC ABS, MAX 202* .. 203* .. Scalars in Common .. 204 LOGICAL LERR, OK 205 CHARACTER*32 SRNAMT 206 INTEGER INFOT, NUNIT 207* .. 208* .. Common blocks .. 209 COMMON / INFOC / INFOT, NUNIT, OK, LERR 210 COMMON / SRNAMC / SRNAMT 211* .. 212* .. Data statements .. 213 DATA ISEEDY / 0, 0, 0, 1 / 214* .. 215* .. Executable Statements .. 216* 217 PATH( 1: 1 ) = 'Single precision' 218 PATH( 2: 3 ) = 'PT' 219 NRUN = 0 220 NFAIL = 0 221 NERRS = 0 222 DO 10 I = 1, 4 223 ISEED( I ) = ISEEDY( I ) 224 10 CONTINUE 225* 226* Test the error exits 227* 228 IF( TSTERR ) 229 $ CALL SERRGT( PATH, NOUT ) 230 INFOT = 0 231* 232 DO 110 IN = 1, NN 233* 234* Do for each value of N in NVAL. 235* 236 N = NVAL( IN ) 237 LDA = MAX( 1, N ) 238 NIMAT = NTYPES 239 IF( N.LE.0 ) 240 $ NIMAT = 1 241* 242 DO 100 IMAT = 1, NIMAT 243* 244* Do the tests only if DOTYPE( IMAT ) is true. 245* 246 IF( N.GT.0 .AND. .NOT.DOTYPE( IMAT ) ) 247 $ GO TO 100 248* 249* Set up parameters with SLATB4. 250* 251 CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 252 $ COND, DIST ) 253* 254 ZEROT = IMAT.GE.8 .AND. IMAT.LE.10 255 IF( IMAT.LE.6 ) THEN 256* 257* Type 1-6: generate a symmetric tridiagonal matrix of 258* known condition number in lower triangular band storage. 259* 260 SRNAMT = 'SLATMS' 261 CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, COND, 262 $ ANORM, KL, KU, 'B', A, 2, WORK, INFO ) 263* 264* Check the error code from SLATMS. 265* 266 IF( INFO.NE.0 ) THEN 267 CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', N, N, KL, 268 $ KU, -1, IMAT, NFAIL, NERRS, NOUT ) 269 GO TO 100 270 END IF 271 IZERO = 0 272* 273* Copy the matrix to D and E. 274* 275 IA = 1 276 DO 20 I = 1, N - 1 277 D( I ) = A( IA ) 278 E( I ) = A( IA+1 ) 279 IA = IA + 2 280 20 CONTINUE 281 IF( N.GT.0 ) 282 $ D( N ) = A( IA ) 283 ELSE 284* 285* Type 7-12: generate a diagonally dominant matrix with 286* unknown condition number in the vectors D and E. 287* 288 IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 7 ) ) THEN 289* 290* Let D and E have values from [-1,1]. 291* 292 CALL SLARNV( 2, ISEED, N, D ) 293 CALL SLARNV( 2, ISEED, N-1, E ) 294* 295* Make the tridiagonal matrix diagonally dominant. 296* 297 IF( N.EQ.1 ) THEN 298 D( 1 ) = ABS( D( 1 ) ) 299 ELSE 300 D( 1 ) = ABS( D( 1 ) ) + ABS( E( 1 ) ) 301 D( N ) = ABS( D( N ) ) + ABS( E( N-1 ) ) 302 DO 30 I = 2, N - 1 303 D( I ) = ABS( D( I ) ) + ABS( E( I ) ) + 304 $ ABS( E( I-1 ) ) 305 30 CONTINUE 306 END IF 307* 308* Scale D and E so the maximum element is ANORM. 309* 310 IX = ISAMAX( N, D, 1 ) 311 DMAX = D( IX ) 312 CALL SSCAL( N, ANORM / DMAX, D, 1 ) 313 CALL SSCAL( N-1, ANORM / DMAX, E, 1 ) 314* 315 ELSE IF( IZERO.GT.0 ) THEN 316* 317* Reuse the last matrix by copying back the zeroed out 318* elements. 319* 320 IF( IZERO.EQ.1 ) THEN 321 D( 1 ) = Z( 2 ) 322 IF( N.GT.1 ) 323 $ E( 1 ) = Z( 3 ) 324 ELSE IF( IZERO.EQ.N ) THEN 325 E( N-1 ) = Z( 1 ) 326 D( N ) = Z( 2 ) 327 ELSE 328 E( IZERO-1 ) = Z( 1 ) 329 D( IZERO ) = Z( 2 ) 330 E( IZERO ) = Z( 3 ) 331 END IF 332 END IF 333* 334* For types 8-10, set one row and column of the matrix to 335* zero. 336* 337 IZERO = 0 338 IF( IMAT.EQ.8 ) THEN 339 IZERO = 1 340 Z( 2 ) = D( 1 ) 341 D( 1 ) = ZERO 342 IF( N.GT.1 ) THEN 343 Z( 3 ) = E( 1 ) 344 E( 1 ) = ZERO 345 END IF 346 ELSE IF( IMAT.EQ.9 ) THEN 347 IZERO = N 348 IF( N.GT.1 ) THEN 349 Z( 1 ) = E( N-1 ) 350 E( N-1 ) = ZERO 351 END IF 352 Z( 2 ) = D( N ) 353 D( N ) = ZERO 354 ELSE IF( IMAT.EQ.10 ) THEN 355 IZERO = ( N+1 ) / 2 356 IF( IZERO.GT.1 ) THEN 357 Z( 1 ) = E( IZERO-1 ) 358 E( IZERO-1 ) = ZERO 359 Z( 3 ) = E( IZERO ) 360 E( IZERO ) = ZERO 361 END IF 362 Z( 2 ) = D( IZERO ) 363 D( IZERO ) = ZERO 364 END IF 365 END IF 366* 367 CALL SCOPY( N, D, 1, D( N+1 ), 1 ) 368 IF( N.GT.1 ) 369 $ CALL SCOPY( N-1, E, 1, E( N+1 ), 1 ) 370* 371*+ TEST 1 372* Factor A as L*D*L' and compute the ratio 373* norm(L*D*L' - A) / (n * norm(A) * EPS ) 374* 375 CALL SPTTRF( N, D( N+1 ), E( N+1 ), INFO ) 376* 377* Check error code from SPTTRF. 378* 379 IF( INFO.NE.IZERO ) THEN 380 CALL ALAERH( PATH, 'SPTTRF', INFO, IZERO, ' ', N, N, -1, 381 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 382 GO TO 100 383 END IF 384* 385 IF( INFO.GT.0 ) THEN 386 RCONDC = ZERO 387 GO TO 90 388 END IF 389* 390 CALL SPTT01( N, D, E, D( N+1 ), E( N+1 ), WORK, 391 $ RESULT( 1 ) ) 392* 393* Print the test ratio if greater than or equal to THRESH. 394* 395 IF( RESULT( 1 ).GE.THRESH ) THEN 396 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 397 $ CALL ALAHD( NOUT, PATH ) 398 WRITE( NOUT, FMT = 9999 )N, IMAT, 1, RESULT( 1 ) 399 NFAIL = NFAIL + 1 400 END IF 401 NRUN = NRUN + 1 402* 403* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) 404* 405* Compute norm(A). 406* 407 ANORM = SLANST( '1', N, D, E ) 408* 409* Use SPTTRS to solve for one column at a time of inv(A), 410* computing the maximum column sum as we go. 411* 412 AINVNM = ZERO 413 DO 50 I = 1, N 414 DO 40 J = 1, N 415 X( J ) = ZERO 416 40 CONTINUE 417 X( I ) = ONE 418 CALL SPTTRS( N, 1, D( N+1 ), E( N+1 ), X, LDA, INFO ) 419 AINVNM = MAX( AINVNM, SASUM( N, X, 1 ) ) 420 50 CONTINUE 421 RCONDC = ONE / MAX( ONE, ANORM*AINVNM ) 422* 423 DO 80 IRHS = 1, NNS 424 NRHS = NSVAL( IRHS ) 425* 426* Generate NRHS random solution vectors. 427* 428 IX = 1 429 DO 60 J = 1, NRHS 430 CALL SLARNV( 2, ISEED, N, XACT( IX ) ) 431 IX = IX + LDA 432 60 CONTINUE 433* 434* Set the right hand side. 435* 436 CALL SLAPTM( N, NRHS, ONE, D, E, XACT, LDA, ZERO, B, 437 $ LDA ) 438* 439*+ TEST 2 440* Solve A*x = b and compute the residual. 441* 442 CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 443 CALL SPTTRS( N, NRHS, D( N+1 ), E( N+1 ), X, LDA, INFO ) 444* 445* Check error code from SPTTRS. 446* 447 IF( INFO.NE.0 ) 448 $ CALL ALAERH( PATH, 'SPTTRS', INFO, 0, ' ', N, N, -1, 449 $ -1, NRHS, IMAT, NFAIL, NERRS, NOUT ) 450* 451 CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) 452 CALL SPTT02( N, NRHS, D, E, X, LDA, WORK, LDA, 453 $ RESULT( 2 ) ) 454* 455*+ TEST 3 456* Check solution from generated exact solution. 457* 458 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 459 $ RESULT( 3 ) ) 460* 461*+ TESTS 4, 5, and 6 462* Use iterative refinement to improve the solution. 463* 464 SRNAMT = 'SPTRFS' 465 CALL SPTRFS( N, NRHS, D, E, D( N+1 ), E( N+1 ), B, LDA, 466 $ X, LDA, RWORK, RWORK( NRHS+1 ), WORK, INFO ) 467* 468* Check error code from SPTRFS. 469* 470 IF( INFO.NE.0 ) 471 $ CALL ALAERH( PATH, 'SPTRFS', INFO, 0, ' ', N, N, -1, 472 $ -1, NRHS, IMAT, NFAIL, NERRS, NOUT ) 473* 474 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 475 $ RESULT( 4 ) ) 476 CALL SPTT05( N, NRHS, D, E, B, LDA, X, LDA, XACT, LDA, 477 $ RWORK, RWORK( NRHS+1 ), RESULT( 5 ) ) 478* 479* Print information about the tests that did not pass the 480* threshold. 481* 482 DO 70 K = 2, 6 483 IF( RESULT( K ).GE.THRESH ) THEN 484 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 485 $ CALL ALAHD( NOUT, PATH ) 486 WRITE( NOUT, FMT = 9998 )N, NRHS, IMAT, K, 487 $ RESULT( K ) 488 NFAIL = NFAIL + 1 489 END IF 490 70 CONTINUE 491 NRUN = NRUN + 5 492 80 CONTINUE 493* 494*+ TEST 7 495* Estimate the reciprocal of the condition number of the 496* matrix. 497* 498 90 CONTINUE 499 SRNAMT = 'SPTCON' 500 CALL SPTCON( N, D( N+1 ), E( N+1 ), ANORM, RCOND, RWORK, 501 $ INFO ) 502* 503* Check error code from SPTCON. 504* 505 IF( INFO.NE.0 ) 506 $ CALL ALAERH( PATH, 'SPTCON', INFO, 0, ' ', N, N, -1, -1, 507 $ -1, IMAT, NFAIL, NERRS, NOUT ) 508* 509 RESULT( 7 ) = SGET06( RCOND, RCONDC ) 510* 511* Print the test ratio if greater than or equal to THRESH. 512* 513 IF( RESULT( 7 ).GE.THRESH ) THEN 514 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 515 $ CALL ALAHD( NOUT, PATH ) 516 WRITE( NOUT, FMT = 9999 )N, IMAT, 7, RESULT( 7 ) 517 NFAIL = NFAIL + 1 518 END IF 519 NRUN = NRUN + 1 520 100 CONTINUE 521 110 CONTINUE 522* 523* Print a summary of the results. 524* 525 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 526* 527 9999 FORMAT( ' N =', I5, ', type ', I2, ', test ', I2, ', ratio = ', 528 $ G12.5 ) 529 9998 FORMAT( ' N =', I5, ', NRHS=', I3, ', type ', I2, ', test(', I2, 530 $ ') = ', G12.5 ) 531 RETURN 532* 533* End of SCHKPT 534* 535 END 536