1*> \brief \b SCHKPP 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 SCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, 12* NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, 13* IWORK, NOUT ) 14* 15* .. Scalar Arguments .. 16* LOGICAL TSTERR 17* INTEGER NMAX, NN, NNS, NOUT 18* REAL THRESH 19* .. 20* .. Array Arguments .. 21* LOGICAL DOTYPE( * ) 22* INTEGER IWORK( * ), NSVAL( * ), NVAL( * ) 23* REAL A( * ), AFAC( * ), AINV( * ), B( * ), 24* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) 25* .. 26* 27* 28*> \par Purpose: 29* ============= 30*> 31*> \verbatim 32*> 33*> SCHKPP tests SPPTRF, -TRI, -TRS, -RFS, and -CON 34*> \endverbatim 35* 36* Arguments: 37* ========== 38* 39*> \param[in] DOTYPE 40*> \verbatim 41*> DOTYPE is LOGICAL array, dimension (NTYPES) 42*> The matrix types to be used for testing. Matrices of type j 43*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 44*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 45*> \endverbatim 46*> 47*> \param[in] NN 48*> \verbatim 49*> NN is INTEGER 50*> The number of values of N contained in the vector NVAL. 51*> \endverbatim 52*> 53*> \param[in] NVAL 54*> \verbatim 55*> NVAL is INTEGER array, dimension (NN) 56*> The values of the matrix dimension N. 57*> \endverbatim 58*> 59*> \param[in] NNS 60*> \verbatim 61*> NNS is INTEGER 62*> The number of values of NRHS contained in the vector NSVAL. 63*> \endverbatim 64*> 65*> \param[in] NSVAL 66*> \verbatim 67*> NSVAL is INTEGER array, dimension (NNS) 68*> The values of the number of right hand sides NRHS. 69*> \endverbatim 70*> 71*> \param[in] THRESH 72*> \verbatim 73*> THRESH is REAL 74*> The threshold value for the test ratios. A result is 75*> included in the output file if RESULT >= THRESH. To have 76*> every test ratio printed, use THRESH = 0. 77*> \endverbatim 78*> 79*> \param[in] TSTERR 80*> \verbatim 81*> TSTERR is LOGICAL 82*> Flag that indicates whether error exits are to be tested. 83*> \endverbatim 84*> 85*> \param[in] NMAX 86*> \verbatim 87*> NMAX is INTEGER 88*> The maximum value permitted for N, used in dimensioning the 89*> work arrays. 90*> \endverbatim 91*> 92*> \param[out] A 93*> \verbatim 94*> A is REAL array, dimension 95*> (NMAX*(NMAX+1)/2) 96*> \endverbatim 97*> 98*> \param[out] AFAC 99*> \verbatim 100*> AFAC is REAL array, dimension 101*> (NMAX*(NMAX+1)/2) 102*> \endverbatim 103*> 104*> \param[out] AINV 105*> \verbatim 106*> AINV is REAL array, dimension 107*> (NMAX*(NMAX+1)/2) 108*> \endverbatim 109*> 110*> \param[out] B 111*> \verbatim 112*> B is REAL array, dimension (NMAX*NSMAX) 113*> where NSMAX is the largest entry in NSVAL. 114*> \endverbatim 115*> 116*> \param[out] X 117*> \verbatim 118*> X is REAL array, dimension (NMAX*NSMAX) 119*> \endverbatim 120*> 121*> \param[out] XACT 122*> \verbatim 123*> XACT is REAL array, dimension (NMAX*NSMAX) 124*> \endverbatim 125*> 126*> \param[out] WORK 127*> \verbatim 128*> WORK is REAL array, dimension 129*> (NMAX*max(3,NSMAX)) 130*> \endverbatim 131*> 132*> \param[out] RWORK 133*> \verbatim 134*> RWORK is REAL array, dimension 135*> (max(NMAX,2*NSMAX)) 136*> \endverbatim 137*> 138*> \param[out] IWORK 139*> \verbatim 140*> IWORK is INTEGER array, dimension (NMAX) 141*> \endverbatim 142*> 143*> \param[in] NOUT 144*> \verbatim 145*> NOUT is INTEGER 146*> The unit number for output. 147*> \endverbatim 148* 149* Authors: 150* ======== 151* 152*> \author Univ. of Tennessee 153*> \author Univ. of California Berkeley 154*> \author Univ. of Colorado Denver 155*> \author NAG Ltd. 156* 157*> \date November 2011 158* 159*> \ingroup single_lin 160* 161* ===================================================================== 162 SUBROUTINE SCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, 163 $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, 164 $ IWORK, NOUT ) 165* 166* -- LAPACK test routine (version 3.4.0) -- 167* -- LAPACK is a software package provided by Univ. of Tennessee, -- 168* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 169* November 2011 170* 171* .. Scalar Arguments .. 172 LOGICAL TSTERR 173 INTEGER NMAX, NN, NNS, NOUT 174 REAL THRESH 175* .. 176* .. Array Arguments .. 177 LOGICAL DOTYPE( * ) 178 INTEGER IWORK( * ), NSVAL( * ), NVAL( * ) 179 REAL A( * ), AFAC( * ), AINV( * ), B( * ), 180 $ RWORK( * ), WORK( * ), X( * ), XACT( * ) 181* .. 182* 183* ===================================================================== 184* 185* .. Parameters .. 186 REAL ZERO 187 PARAMETER ( ZERO = 0.0E+0 ) 188 INTEGER NTYPES 189 PARAMETER ( NTYPES = 9 ) 190 INTEGER NTESTS 191 PARAMETER ( NTESTS = 8 ) 192* .. 193* .. Local Scalars .. 194 LOGICAL ZEROT 195 CHARACTER DIST, PACKIT, TYPE, UPLO, XTYPE 196 CHARACTER*3 PATH 197 INTEGER I, IMAT, IN, INFO, IOFF, IRHS, IUPLO, IZERO, K, 198 $ KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT, NPP, 199 $ NRHS, NRUN 200 REAL ANORM, CNDNUM, RCOND, RCONDC 201* .. 202* .. Local Arrays .. 203 CHARACTER PACKS( 2 ), UPLOS( 2 ) 204 INTEGER ISEED( 4 ), ISEEDY( 4 ) 205 REAL RESULT( NTESTS ) 206* .. 207* .. External Functions .. 208 REAL SGET06, SLANSP 209 EXTERNAL SGET06, SLANSP 210* .. 211* .. External Subroutines .. 212 EXTERNAL ALAERH, ALAHD, ALASUM, SCOPY, SERRPO, SGET04, 213 $ SLACPY, SLARHS, SLATB4, SLATMS, SPPCON, SPPRFS, 214 $ SPPT01, SPPT02, SPPT03, SPPT05, SPPTRF, SPPTRI, 215 $ SPPTRS 216* .. 217* .. Scalars in Common .. 218 LOGICAL LERR, OK 219 CHARACTER*32 SRNAMT 220 INTEGER INFOT, NUNIT 221* .. 222* .. Common blocks .. 223 COMMON / INFOC / INFOT, NUNIT, OK, LERR 224 COMMON / SRNAMC / SRNAMT 225* .. 226* .. Intrinsic Functions .. 227 INTRINSIC MAX 228* .. 229* .. Data statements .. 230 DATA ISEEDY / 1988, 1989, 1990, 1991 / 231 DATA UPLOS / 'U', 'L' / , PACKS / 'C', 'R' / 232* .. 233* .. Executable Statements .. 234* 235* Initialize constants and the random number seed. 236* 237 PATH( 1: 1 ) = 'Single precision' 238 PATH( 2: 3 ) = 'PP' 239 NRUN = 0 240 NFAIL = 0 241 NERRS = 0 242 DO 10 I = 1, 4 243 ISEED( I ) = ISEEDY( I ) 244 10 CONTINUE 245* 246* Test the error exits 247* 248 IF( TSTERR ) 249 $ CALL SERRPO( PATH, NOUT ) 250 INFOT = 0 251* 252* Do for each value of N in NVAL 253* 254 DO 110 IN = 1, NN 255 N = NVAL( IN ) 256 LDA = MAX( N, 1 ) 257 XTYPE = 'N' 258 NIMAT = NTYPES 259 IF( N.LE.0 ) 260 $ NIMAT = 1 261* 262 DO 100 IMAT = 1, NIMAT 263* 264* Do the tests only if DOTYPE( IMAT ) is true. 265* 266 IF( .NOT.DOTYPE( IMAT ) ) 267 $ GO TO 100 268* 269* Skip types 3, 4, or 5 if the matrix size is too small. 270* 271 ZEROT = IMAT.GE.3 .AND. IMAT.LE.5 272 IF( ZEROT .AND. N.LT.IMAT-2 ) 273 $ GO TO 100 274* 275* Do first for UPLO = 'U', then for UPLO = 'L' 276* 277 DO 90 IUPLO = 1, 2 278 UPLO = UPLOS( IUPLO ) 279 PACKIT = PACKS( IUPLO ) 280* 281* Set up parameters with SLATB4 and generate a test matrix 282* with SLATMS. 283* 284 CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 285 $ CNDNUM, DIST ) 286* 287 SRNAMT = 'SLATMS' 288 CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, 289 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK, 290 $ INFO ) 291* 292* Check error code from SLATMS. 293* 294 IF( INFO.NE.0 ) THEN 295 CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1, 296 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 297 GO TO 90 298 END IF 299* 300* For types 3-5, zero one row and column of the matrix to 301* test that INFO is returned correctly. 302* 303 IF( ZEROT ) THEN 304 IF( IMAT.EQ.3 ) THEN 305 IZERO = 1 306 ELSE IF( IMAT.EQ.4 ) THEN 307 IZERO = N 308 ELSE 309 IZERO = N / 2 + 1 310 END IF 311* 312* Set row and column IZERO of A to 0. 313* 314 IF( IUPLO.EQ.1 ) THEN 315 IOFF = ( IZERO-1 )*IZERO / 2 316 DO 20 I = 1, IZERO - 1 317 A( IOFF+I ) = ZERO 318 20 CONTINUE 319 IOFF = IOFF + IZERO 320 DO 30 I = IZERO, N 321 A( IOFF ) = ZERO 322 IOFF = IOFF + I 323 30 CONTINUE 324 ELSE 325 IOFF = IZERO 326 DO 40 I = 1, IZERO - 1 327 A( IOFF ) = ZERO 328 IOFF = IOFF + N - I 329 40 CONTINUE 330 IOFF = IOFF - IZERO 331 DO 50 I = IZERO, N 332 A( IOFF+I ) = ZERO 333 50 CONTINUE 334 END IF 335 ELSE 336 IZERO = 0 337 END IF 338* 339* Compute the L*L' or U'*U factorization of the matrix. 340* 341 NPP = N*( N+1 ) / 2 342 CALL SCOPY( NPP, A, 1, AFAC, 1 ) 343 SRNAMT = 'SPPTRF' 344 CALL SPPTRF( UPLO, N, AFAC, INFO ) 345* 346* Check error code from SPPTRF. 347* 348 IF( INFO.NE.IZERO ) THEN 349 CALL ALAERH( PATH, 'SPPTRF', INFO, IZERO, UPLO, N, N, 350 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) 351 GO TO 90 352 END IF 353* 354* Skip the tests if INFO is not 0. 355* 356 IF( INFO.NE.0 ) 357 $ GO TO 90 358* 359*+ TEST 1 360* Reconstruct matrix from factors and compute residual. 361* 362 CALL SCOPY( NPP, AFAC, 1, AINV, 1 ) 363 CALL SPPT01( UPLO, N, A, AINV, RWORK, RESULT( 1 ) ) 364* 365*+ TEST 2 366* Form the inverse and compute the residual. 367* 368 CALL SCOPY( NPP, AFAC, 1, AINV, 1 ) 369 SRNAMT = 'SPPTRI' 370 CALL SPPTRI( UPLO, N, AINV, INFO ) 371* 372* Check error code from SPPTRI. 373* 374 IF( INFO.NE.0 ) 375 $ CALL ALAERH( PATH, 'SPPTRI', INFO, 0, UPLO, N, N, -1, 376 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 377* 378 CALL SPPT03( UPLO, N, A, AINV, WORK, LDA, RWORK, RCONDC, 379 $ RESULT( 2 ) ) 380* 381* Print information about the tests that did not pass 382* the threshold. 383* 384 DO 60 K = 1, 2 385 IF( RESULT( K ).GE.THRESH ) THEN 386 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 387 $ CALL ALAHD( NOUT, PATH ) 388 WRITE( NOUT, FMT = 9999 )UPLO, N, IMAT, K, 389 $ RESULT( K ) 390 NFAIL = NFAIL + 1 391 END IF 392 60 CONTINUE 393 NRUN = NRUN + 2 394* 395 DO 80 IRHS = 1, NNS 396 NRHS = NSVAL( IRHS ) 397* 398*+ TEST 3 399* Solve and compute residual for A * X = B. 400* 401 SRNAMT = 'SLARHS' 402 CALL SLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, 403 $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, 404 $ INFO ) 405 CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 406* 407 SRNAMT = 'SPPTRS' 408 CALL SPPTRS( UPLO, N, NRHS, AFAC, X, LDA, INFO ) 409* 410* Check error code from SPPTRS. 411* 412 IF( INFO.NE.0 ) 413 $ CALL ALAERH( PATH, 'SPPTRS', INFO, 0, UPLO, N, N, 414 $ -1, -1, NRHS, IMAT, NFAIL, NERRS, 415 $ NOUT ) 416* 417 CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) 418 CALL SPPT02( UPLO, N, NRHS, A, X, LDA, WORK, LDA, 419 $ RWORK, RESULT( 3 ) ) 420* 421*+ TEST 4 422* Check solution from generated exact solution. 423* 424 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 425 $ RESULT( 4 ) ) 426* 427*+ TESTS 5, 6, and 7 428* Use iterative refinement to improve the solution. 429* 430 SRNAMT = 'SPPRFS' 431 CALL SPPRFS( UPLO, N, NRHS, A, AFAC, B, LDA, X, LDA, 432 $ RWORK, RWORK( NRHS+1 ), WORK, IWORK, 433 $ INFO ) 434* 435* Check error code from SPPRFS. 436* 437 IF( INFO.NE.0 ) 438 $ CALL ALAERH( PATH, 'SPPRFS', INFO, 0, UPLO, N, N, 439 $ -1, -1, NRHS, IMAT, NFAIL, NERRS, 440 $ NOUT ) 441* 442 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 443 $ RESULT( 5 ) ) 444 CALL SPPT05( UPLO, N, NRHS, A, B, LDA, X, LDA, XACT, 445 $ LDA, RWORK, RWORK( NRHS+1 ), 446 $ RESULT( 6 ) ) 447* 448* Print information about the tests that did not pass 449* the threshold. 450* 451 DO 70 K = 3, 7 452 IF( RESULT( K ).GE.THRESH ) THEN 453 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 454 $ CALL ALAHD( NOUT, PATH ) 455 WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, IMAT, 456 $ K, RESULT( K ) 457 NFAIL = NFAIL + 1 458 END IF 459 70 CONTINUE 460 NRUN = NRUN + 5 461 80 CONTINUE 462* 463*+ TEST 8 464* Get an estimate of RCOND = 1/CNDNUM. 465* 466 ANORM = SLANSP( '1', UPLO, N, A, RWORK ) 467 SRNAMT = 'SPPCON' 468 CALL SPPCON( UPLO, N, AFAC, ANORM, RCOND, WORK, IWORK, 469 $ INFO ) 470* 471* Check error code from SPPCON. 472* 473 IF( INFO.NE.0 ) 474 $ CALL ALAERH( PATH, 'SPPCON', INFO, 0, UPLO, N, N, -1, 475 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 476* 477 RESULT( 8 ) = SGET06( RCOND, RCONDC ) 478* 479* Print the test ratio if greater than or equal to THRESH. 480* 481 IF( RESULT( 8 ).GE.THRESH ) THEN 482 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 483 $ CALL ALAHD( NOUT, PATH ) 484 WRITE( NOUT, FMT = 9999 )UPLO, N, IMAT, 8, 485 $ RESULT( 8 ) 486 NFAIL = NFAIL + 1 487 END IF 488 NRUN = NRUN + 1 489 90 CONTINUE 490 100 CONTINUE 491 110 CONTINUE 492* 493* Print a summary of the results. 494* 495 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 496* 497 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', type ', I2, ', test ', 498 $ I2, ', ratio =', G12.5 ) 499 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', 500 $ I2, ', test(', I2, ') =', G12.5 ) 501 RETURN 502* 503* End of SCHKPP 504* 505 END 506