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