1*> \brief \b DCHKSY_AA 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 DCHKSY_AA( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 12* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, 13* XACT, WORK, RWORK, IWORK, NOUT ) 14* 15* .. Scalar Arguments .. 16* LOGICAL TSTERR 17* INTEGER NMAX, NN, NNB, NNS, NOUT 18* DOUBLE PRECISION THRESH 19* .. 20* .. Array Arguments .. 21* LOGICAL DOTYPE( * ) 22* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) 23* DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), 24* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) 25* .. 26* 27* 28*> \par Purpose: 29* ============= 30*> 31*> \verbatim 32*> 33*> DCHKSY_AA tests DSYTRF_AA, -TRS_AA. 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] NNB 60*> \verbatim 61*> NNB is INTEGER 62*> The number of values of NB contained in the vector NBVAL. 63*> \endverbatim 64*> 65*> \param[in] NBVAL 66*> \verbatim 67*> NBVAL is INTEGER array, dimension (NNB) 68*> The values of the blocksize NB. 69*> \endverbatim 70*> 71*> \param[in] NNS 72*> \verbatim 73*> NNS is INTEGER 74*> The number of values of NRHS contained in the vector NSVAL. 75*> \endverbatim 76*> 77*> \param[in] NSVAL 78*> \verbatim 79*> NSVAL is INTEGER array, dimension (NNS) 80*> The values of the number of right hand sides NRHS. 81*> \endverbatim 82*> 83*> \param[in] THRESH 84*> \verbatim 85*> THRESH is DOUBLE PRECISION 86*> The threshold value for the test ratios. A result is 87*> included in the output file if RESULT >= THRESH. To have 88*> every test ratio printed, use THRESH = 0. 89*> \endverbatim 90*> 91*> \param[in] TSTERR 92*> \verbatim 93*> TSTERR is LOGICAL 94*> Flag that indicates whether error exits are to be tested. 95*> \endverbatim 96*> 97*> \param[in] NMAX 98*> \verbatim 99*> NMAX is INTEGER 100*> The maximum value permitted for N, used in dimensioning the 101*> work arrays. 102*> \endverbatim 103*> 104*> \param[out] A 105*> \verbatim 106*> A is DOUBLE PRECISION array, dimension (NMAX*NMAX) 107*> \endverbatim 108*> 109*> \param[out] AFAC 110*> \verbatim 111*> AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX) 112*> \endverbatim 113*> 114*> \param[out] AINV 115*> \verbatim 116*> AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX) 117*> \endverbatim 118*> 119*> \param[out] B 120*> \verbatim 121*> B is DOUBLE PRECISION array, dimension (NMAX*NSMAX) 122*> where NSMAX is the largest entry in NSVAL. 123*> \endverbatim 124*> 125*> \param[out] X 126*> \verbatim 127*> X is DOUBLE PRECISION array, dimension (NMAX*NSMAX) 128*> \endverbatim 129*> 130*> \param[out] XACT 131*> \verbatim 132*> XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX) 133*> \endverbatim 134*> 135*> \param[out] WORK 136*> \verbatim 137*> WORK is DOUBLE PRECISION array, dimension (NMAX*max(3,NSMAX)) 138*> \endverbatim 139*> 140*> \param[out] RWORK 141*> \verbatim 142*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX)) 143*> \endverbatim 144*> 145*> \param[out] IWORK 146*> \verbatim 147*> IWORK is INTEGER array, dimension (2*NMAX) 148*> \endverbatim 149*> 150*> \param[in] NOUT 151*> \verbatim 152*> NOUT is INTEGER 153*> The unit number for output. 154*> \endverbatim 155* 156* Authors: 157* ======== 158* 159*> \author Univ. of Tennessee 160*> \author Univ. of California Berkeley 161*> \author Univ. of Colorado Denver 162*> \author NAG Ltd. 163* 164*> \ingroup double_lin 165* 166* ===================================================================== 167 SUBROUTINE DCHKSY_AA( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 168 $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, 169 $ X, XACT, WORK, RWORK, IWORK, NOUT ) 170* 171* -- LAPACK test routine -- 172* -- LAPACK is a software package provided by Univ. of Tennessee, -- 173* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 174* 175 IMPLICIT NONE 176* 177* .. Scalar Arguments .. 178 LOGICAL TSTERR 179 INTEGER NN, NNB, NNS, NMAX, NOUT 180 DOUBLE PRECISION THRESH 181* .. 182* .. Array Arguments .. 183 LOGICAL DOTYPE( * ) 184 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) 185 DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), 186 $ RWORK( * ), WORK( * ), X( * ), XACT( * ) 187* .. 188* 189* ===================================================================== 190* 191* .. Parameters .. 192 DOUBLE PRECISION ZERO, ONE 193 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 194 INTEGER NTYPES 195 PARAMETER ( NTYPES = 10 ) 196 INTEGER NTESTS 197 PARAMETER ( NTESTS = 9 ) 198* .. 199* .. Local Scalars .. 200 LOGICAL ZEROT 201 CHARACTER DIST, TYPE, UPLO, XTYPE 202 CHARACTER*3 PATH, MATPATH 203 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, 204 $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE, 205 $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT 206 DOUBLE PRECISION ANORM, CNDNUM 207* .. 208* .. Local Arrays .. 209 CHARACTER UPLOS( 2 ) 210 INTEGER ISEED( 4 ), ISEEDY( 4 ) 211 DOUBLE PRECISION RESULT( NTESTS ) 212* .. 213* .. External Subroutines .. 214 EXTERNAL ALAERH, ALAHD, ALASUM, DERRSY, DLACPY, DLARHS, 215 $ DLATB4, DLATMS, DPOT02, DSYT01_AA, DSYTRF_AA, 216 $ DSYTRS_AA, XLAENV 217* .. 218* .. Intrinsic Functions .. 219 INTRINSIC MAX, MIN 220* .. 221* .. Scalars in Common .. 222 LOGICAL LERR, OK 223 CHARACTER*32 SRNAMT 224 INTEGER INFOT, NUNIT 225* .. 226* .. Common blocks .. 227 COMMON / INFOC / INFOT, NUNIT, OK, LERR 228 COMMON / SRNAMC / SRNAMT 229* .. 230* .. Data statements .. 231 DATA ISEEDY / 1988, 1989, 1990, 1991 / 232 DATA UPLOS / 'U', 'L' / 233* .. 234* .. Executable Statements .. 235* 236* Initialize constants and the random number seed. 237* 238* Test path 239* 240 PATH( 1: 1 ) = 'Double precision' 241 PATH( 2: 3 ) = 'SA' 242* 243* Path to generate matrices 244* 245 MATPATH( 1: 1 ) = 'Double precision' 246 MATPATH( 2: 3 ) = 'SY' 247 NRUN = 0 248 NFAIL = 0 249 NERRS = 0 250 DO 10 I = 1, 4 251 ISEED( I ) = ISEEDY( I ) 252 10 CONTINUE 253* 254* Test the error exits 255* 256 IF( TSTERR ) 257 $ CALL DERRSY( PATH, NOUT ) 258 INFOT = 0 259* 260* Set the minimum block size for which the block routine should 261* be used, which will be later returned by ILAENV 262* 263 CALL XLAENV( 2, 2 ) 264* 265* Do for each value of N in NVAL 266* 267 DO 180 IN = 1, NN 268 N = NVAL( IN ) 269 IF( N .GT. NMAX ) THEN 270 NFAIL = NFAIL + 1 271 WRITE(NOUT, 9995) 'M ', N, NMAX 272 GO TO 180 273 END IF 274 LDA = MAX( N, 1 ) 275 XTYPE = 'N' 276 NIMAT = NTYPES 277 IF( N.LE.0 ) 278 $ NIMAT = 1 279* 280 IZERO = 0 281* 282* Do for each value of matrix type IMAT 283* 284 DO 170 IMAT = 1, NIMAT 285* 286* Do the tests only if DOTYPE( IMAT ) is true. 287* 288 IF( .NOT.DOTYPE( IMAT ) ) 289 $ GO TO 170 290* 291* Skip types 3, 4, 5, or 6 if the matrix size is too small. 292* 293 ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 294 IF( ZEROT .AND. N.LT.IMAT-2 ) 295 $ GO TO 170 296* 297* Do first for UPLO = 'U', then for UPLO = 'L' 298* 299 DO 160 IUPLO = 1, 2 300 UPLO = UPLOS( IUPLO ) 301* 302* Begin generate the test matrix A. 303* 304* 305* Set up parameters with DLATB4 for the matrix generator 306* based on the type of matrix to be generated. 307* 308 CALL DLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, 309 $ ANORM, MODE, CNDNUM, DIST ) 310* 311* Generate a matrix with DLATMS. 312* 313 SRNAMT = 'DLATMS' 314 CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, 315 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, 316 $ INFO ) 317* 318* Check error code from DLATMS and handle error. 319* 320 IF( INFO.NE.0 ) THEN 321 CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1, 322 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 323* 324* Skip all tests for this generated matrix 325* 326 GO TO 160 327 END IF 328* 329* For matrix types 3-6, zero one or more rows and 330* columns of the matrix to test that INFO is returned 331* correctly. 332* 333 IF( ZEROT ) THEN 334 IF( IMAT.EQ.3 ) THEN 335 IZERO = 1 336 ELSE IF( IMAT.EQ.4 ) THEN 337 IZERO = N 338 ELSE 339 IZERO = N / 2 + 1 340 END IF 341* 342 IF( IMAT.LT.6 ) THEN 343* 344* Set row and column IZERO to zero. 345* 346 IF( IUPLO.EQ.1 ) THEN 347 IOFF = ( IZERO-1 )*LDA 348 DO 20 I = 1, IZERO - 1 349 A( IOFF+I ) = ZERO 350 20 CONTINUE 351 IOFF = IOFF + IZERO 352 DO 30 I = IZERO, N 353 A( IOFF ) = ZERO 354 IOFF = IOFF + LDA 355 30 CONTINUE 356 ELSE 357 IOFF = IZERO 358 DO 40 I = 1, IZERO - 1 359 A( IOFF ) = ZERO 360 IOFF = IOFF + LDA 361 40 CONTINUE 362 IOFF = IOFF - IZERO 363 DO 50 I = IZERO, N 364 A( IOFF+I ) = ZERO 365 50 CONTINUE 366 END IF 367 ELSE 368 IF( IUPLO.EQ.1 ) THEN 369* 370* Set the first IZERO rows and columns to zero. 371* 372 IOFF = 0 373 DO 70 J = 1, N 374 I2 = MIN( J, IZERO ) 375 DO 60 I = 1, I2 376 A( IOFF+I ) = ZERO 377 60 CONTINUE 378 IOFF = IOFF + LDA 379 70 CONTINUE 380 IZERO = 1 381 ELSE 382* 383* Set the last IZERO rows and columns to zero. 384* 385 IOFF = 0 386 DO 90 J = 1, N 387 I1 = MAX( J, IZERO ) 388 DO 80 I = I1, N 389 A( IOFF+I ) = ZERO 390 80 CONTINUE 391 IOFF = IOFF + LDA 392 90 CONTINUE 393 END IF 394 END IF 395 ELSE 396 IZERO = 0 397 END IF 398* 399* End generate the test matrix A. 400* 401* Do for each value of NB in NBVAL 402* 403 DO 150 INB = 1, NNB 404* 405* Set the optimal blocksize, which will be later 406* returned by ILAENV. 407* 408 NB = NBVAL( INB ) 409 CALL XLAENV( 1, NB ) 410* 411* Copy the test matrix A into matrix AFAC which 412* will be factorized in place. This is needed to 413* preserve the test matrix A for subsequent tests. 414* 415 CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) 416* 417* Compute the L*D*L**T or U*D*U**T factorization of the 418* matrix. IWORK stores details of the interchanges and 419* the block structure of D. AINV is a work array for 420* block factorization, LWORK is the length of AINV. 421* 422 SRNAMT = 'DSYTRF_AA' 423 LWORK = MAX( 1, N*NB + N ) 424 CALL DSYTRF_AA( UPLO, N, AFAC, LDA, IWORK, AINV, 425 $ LWORK, INFO ) 426* 427* Adjust the expected value of INFO to account for 428* pivoting. 429* 430c IF( IZERO.GT.0 ) THEN 431c J = 1 432c K = IZERO 433c 100 CONTINUE 434c IF( J.EQ.K ) THEN 435c K = IWORK( J ) 436c ELSE IF( IWORK( J ).EQ.K ) THEN 437c K = J 438c END IF 439c IF( J.LT.K ) THEN 440c J = J + 1 441c GO TO 100 442c END IF 443c ELSE 444 K = 0 445c END IF 446* 447* Check error code from DSYTRF and handle error. 448* 449 IF( INFO.NE.K ) THEN 450 CALL ALAERH( PATH, 'DSYTRF_AA', INFO, K, UPLO, 451 $ N, N, -1, -1, NB, IMAT, NFAIL, NERRS, 452 $ NOUT ) 453 END IF 454* 455*+ TEST 1 456* Reconstruct matrix from factors and compute residual. 457* 458 CALL DSYT01_AA( UPLO, N, A, LDA, AFAC, LDA, IWORK, 459 $ AINV, LDA, RWORK, RESULT( 1 ) ) 460 NT = 1 461* 462* 463* Print information about the tests that did not pass 464* the threshold. 465* 466 DO 110 K = 1, NT 467 IF( RESULT( K ).GE.THRESH ) THEN 468 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 469 $ CALL ALAHD( NOUT, PATH ) 470 WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, 471 $ RESULT( K ) 472 NFAIL = NFAIL + 1 473 END IF 474 110 CONTINUE 475 NRUN = NRUN + NT 476* 477* Skip solver test if INFO is not 0. 478* 479 IF( INFO.NE.0 ) THEN 480 GO TO 140 481 END IF 482* 483* Do for each value of NRHS in NSVAL. 484* 485 DO 130 IRHS = 1, NNS 486 NRHS = NSVAL( IRHS ) 487* 488*+ TEST 2 (Using TRS) 489* Solve and compute residual for A * X = B. 490* 491* Choose a set of NRHS random solution vectors 492* stored in XACT and set up the right hand side B 493* 494 SRNAMT = 'DLARHS' 495 CALL DLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, 496 $ KL, KU, NRHS, A, LDA, XACT, LDA, 497 $ B, LDA, ISEED, INFO ) 498 CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 499* 500 SRNAMT = 'DSYTRS_AA' 501 LWORK = MAX( 1, 3*N-2 ) 502 CALL DSYTRS_AA( UPLO, N, NRHS, AFAC, LDA, 503 $ IWORK, X, LDA, WORK, LWORK, 504 $ INFO ) 505* 506* Check error code from DSYTRS and handle error. 507* 508 IF( INFO.NE.0 ) THEN 509 IF( IZERO.EQ.0 ) THEN 510 CALL ALAERH( PATH, 'DSYTRS_AA', INFO, 0, 511 $ UPLO, N, N, -1, -1, NRHS, IMAT, 512 $ NFAIL, NERRS, NOUT ) 513 END IF 514 ELSE 515 CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA 516 $ ) 517* 518* Compute the residual for the solution 519* 520 CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, 521 $ WORK, LDA, RWORK, RESULT( 2 ) ) 522* 523* 524* Print information about the tests that did not pass 525* the threshold. 526* 527 DO 120 K = 2, 2 528 IF( RESULT( K ).GE.THRESH ) THEN 529 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 530 $ CALL ALAHD( NOUT, PATH ) 531 WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, 532 $ IMAT, K, RESULT( K ) 533 NFAIL = NFAIL + 1 534 END IF 535 120 CONTINUE 536 END IF 537 NRUN = NRUN + 1 538* 539* End do for each value of NRHS in NSVAL. 540* 541 130 CONTINUE 542 140 CONTINUE 543 150 CONTINUE 544 160 CONTINUE 545 170 CONTINUE 546 180 CONTINUE 547* 548* Print a summary of the results. 549* 550 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 551* 552 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', 553 $ I2, ', test ', I2, ', ratio =', G12.5 ) 554 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', 555 $ I2, ', test(', I2, ') =', G12.5 ) 556 9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=', 557 $ I6 ) 558 RETURN 559* 560* End of DCHKSY_AA 561* 562 END 563