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