1*> \brief \b DDRVSY_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 DDRVSY_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, 12* A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, 13* NOUT ) 14* 15* .. Scalar Arguments .. 16* LOGICAL TSTERR 17* INTEGER NMAX, NN, NOUT, NRHS 18* DOUBLE PRECISION THRESH 19* .. 20* .. Array Arguments .. 21* LOGICAL DOTYPE( * ) 22* INTEGER IWORK( * ), 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*> DDRVSY_AA tests the driver routine DSYSV_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] NRHS 60*> \verbatim 61*> NRHS is INTEGER 62*> The number of right hand side vectors to be generated for 63*> each linear system. 64*> \endverbatim 65*> 66*> \param[in] THRESH 67*> \verbatim 68*> THRESH is DOUBLE PRECISION 69*> The threshold value for the test ratios. A result is 70*> included in the output file if RESULT >= THRESH. To have 71*> every test ratio printed, use THRESH = 0. 72*> \endverbatim 73*> 74*> \param[in] TSTERR 75*> \verbatim 76*> TSTERR is LOGICAL 77*> Flag that indicates whether error exits are to be tested. 78*> \endverbatim 79*> 80*> \param[in] NMAX 81*> \verbatim 82*> NMAX is INTEGER 83*> The maximum value permitted for N, used in dimensioning the 84*> work arrays. 85*> \endverbatim 86*> 87*> \param[out] A 88*> \verbatim 89*> A is DOUBLE PRECISION array, dimension (NMAX*NMAX) 90*> \endverbatim 91*> 92*> \param[out] AFAC 93*> \verbatim 94*> AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX) 95*> \endverbatim 96*> 97*> \param[out] AINV 98*> \verbatim 99*> AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX) 100*> \endverbatim 101*> 102*> \param[out] B 103*> \verbatim 104*> B is DOUBLE PRECISION array, dimension (NMAX*NRHS) 105*> \endverbatim 106*> 107*> \param[out] X 108*> \verbatim 109*> X is DOUBLE PRECISION array, dimension (NMAX*NRHS) 110*> \endverbatim 111*> 112*> \param[out] XACT 113*> \verbatim 114*> XACT is DOUBLE PRECISION array, dimension (NMAX*NRHS) 115*> \endverbatim 116*> 117*> \param[out] WORK 118*> \verbatim 119*> WORK is DOUBLE PRECISION array, dimension (NMAX*max(2,NRHS)) 120*> \endverbatim 121*> 122*> \param[out] RWORK 123*> \verbatim 124*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS) 125*> \endverbatim 126*> 127*> \param[out] IWORK 128*> \verbatim 129*> IWORK is INTEGER array, dimension (2*NMAX) 130*> \endverbatim 131*> 132*> \param[in] NOUT 133*> \verbatim 134*> NOUT is INTEGER 135*> The unit number for output. 136*> \endverbatim 137* 138* Authors: 139* ======== 140* 141*> \author Univ. of Tennessee 142*> \author Univ. of California Berkeley 143*> \author Univ. of Colorado Denver 144*> \author NAG Ltd. 145* 146*> \ingroup double_lin 147* 148* ===================================================================== 149 SUBROUTINE DDRVSY_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, 150 $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, 151 $ RWORK, IWORK, NOUT ) 152* 153* -- LAPACK test routine -- 154* -- LAPACK is a software package provided by Univ. of Tennessee, -- 155* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 156* 157* .. Scalar Arguments .. 158 LOGICAL TSTERR 159 INTEGER NMAX, NN, NOUT, NRHS 160 DOUBLE PRECISION THRESH 161* .. 162* .. Array Arguments .. 163 LOGICAL DOTYPE( * ) 164 INTEGER IWORK( * ), NVAL( * ) 165 DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), 166 $ RWORK( * ), WORK( * ), X( * ), XACT( * ) 167* .. 168* 169* ===================================================================== 170* 171* .. Parameters .. 172 DOUBLE PRECISION ONE, ZERO 173 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 174 INTEGER NTYPES, NTESTS 175 PARAMETER ( NTYPES = 10, NTESTS = 3 ) 176 INTEGER NFACT 177 PARAMETER ( NFACT = 2 ) 178* .. 179* .. Local Scalars .. 180 LOGICAL ZEROT 181 CHARACTER DIST, FACT, TYPE, UPLO, XTYPE 182 CHARACTER*3 MATPATH, PATH 183 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, 184 $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, 185 $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT 186 DOUBLE PRECISION ANORM, CNDNUM 187* .. 188* .. Local Arrays .. 189 CHARACTER FACTS( NFACT ), UPLOS( 2 ) 190 INTEGER ISEED( 4 ), ISEEDY( 4 ) 191 DOUBLE PRECISION RESULT( NTESTS ) 192* .. 193* .. External Functions .. 194 DOUBLE PRECISION DGET06, DLANSY 195 EXTERNAL DGET06, DLANSY 196* .. 197* .. External Subroutines .. 198 EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGET04, DLACPY, 199 $ DLARHS, DLASET, DLATB4, DLATMS, DPOT02, 200 $ DSYSV_AA, DSYT01_AA, DSYTRF_AA, XLAENV 201* .. 202* .. Scalars in Common .. 203 LOGICAL LERR, OK 204 CHARACTER*32 SRNAMT 205 INTEGER INFOT, NUNIT 206* .. 207* .. Common blocks .. 208 COMMON / INFOC / INFOT, NUNIT, OK, LERR 209 COMMON / SRNAMC / SRNAMT 210* .. 211* .. Intrinsic Functions .. 212 INTRINSIC MAX, MIN 213* .. 214* .. Data statements .. 215 DATA ISEEDY / 1988, 1989, 1990, 1991 / 216 DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / 217* .. 218* .. Executable Statements .. 219* 220* Initialize constants and the random number seed. 221* 222* Test path 223* 224 PATH( 1: 1 ) = 'Double precision' 225 PATH( 2: 3 ) = 'SA' 226* 227* Path to generate matrices 228* 229 MATPATH( 1: 1 ) = 'Double precision' 230 MATPATH( 2: 3 ) = 'SY' 231* 232 NRUN = 0 233 NFAIL = 0 234 NERRS = 0 235 DO 10 I = 1, 4 236 ISEED( I ) = ISEEDY( I ) 237 10 CONTINUE 238* 239* Test the error exits 240* 241 IF( TSTERR ) 242 $ CALL DERRVX( PATH, NOUT ) 243 INFOT = 0 244* 245* Set the block size and minimum block size for testing. 246* 247 NB = 1 248 NBMIN = 2 249 CALL XLAENV( 1, NB ) 250 CALL XLAENV( 2, NBMIN ) 251* 252* Do for each value of N in NVAL 253* 254 DO 180 IN = 1, NN 255 N = NVAL( IN ) 256 LWORK = MAX( 3*N-2, N*(1+NB) ) 257 LWORK = MAX( LWORK, 1 ) 258 LDA = MAX( N, 1 ) 259 XTYPE = 'N' 260 NIMAT = NTYPES 261 IF( N.LE.0 ) 262 $ NIMAT = 1 263* 264 DO 170 IMAT = 1, NIMAT 265* 266* Do the tests only if DOTYPE( IMAT ) is true. 267* 268 IF( .NOT.DOTYPE( IMAT ) ) 269 $ GO TO 170 270* 271* Skip types 3, 4, 5, or 6 if the matrix size is too small. 272* 273 ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 274 IF( ZEROT .AND. N.LT.IMAT-2 ) 275 $ GO TO 170 276* 277* Do first for UPLO = 'U', then for UPLO = 'L' 278* 279 DO 160 IUPLO = 1, 2 280 UPLO = UPLOS( IUPLO ) 281* 282* Set up parameters with DLATB4 and generate a test matrix 283* with DLATMS. 284* 285 CALL DLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, 286 $ MODE, CNDNUM, DIST ) 287* 288 SRNAMT = 'DLATMS' 289 CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, 290 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, 291 $ INFO ) 292* 293* Check error code from DLATMS. 294* 295 IF( INFO.NE.0 ) THEN 296 CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1, 297 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 298 GO TO 160 299 END IF 300* 301* For types 3-6, zero one or more rows and columns of the 302* matrix to test that INFO is returned correctly. 303* 304 IF( ZEROT ) THEN 305 IF( IMAT.EQ.3 ) THEN 306 IZERO = 1 307 ELSE IF( IMAT.EQ.4 ) THEN 308 IZERO = N 309 ELSE 310 IZERO = N / 2 + 1 311 END IF 312* 313 IF( IMAT.LT.6 ) THEN 314* 315* Set row and column IZERO to zero. 316* 317 IF( IUPLO.EQ.1 ) THEN 318 IOFF = ( IZERO-1 )*LDA 319 DO 20 I = 1, IZERO - 1 320 A( IOFF+I ) = ZERO 321 20 CONTINUE 322 IOFF = IOFF + IZERO 323 DO 30 I = IZERO, N 324 A( IOFF ) = ZERO 325 IOFF = IOFF + LDA 326 30 CONTINUE 327 ELSE 328 IOFF = IZERO 329 DO 40 I = 1, IZERO - 1 330 A( IOFF ) = ZERO 331 IOFF = IOFF + LDA 332 40 CONTINUE 333 IOFF = IOFF - IZERO 334 DO 50 I = IZERO, N 335 A( IOFF+I ) = ZERO 336 50 CONTINUE 337 END IF 338 ELSE 339 IOFF = 0 340 IF( IUPLO.EQ.1 ) THEN 341* 342* Set the first IZERO rows and columns to zero. 343* 344 DO 70 J = 1, N 345 I2 = MIN( J, IZERO ) 346 DO 60 I = 1, I2 347 A( IOFF+I ) = ZERO 348 60 CONTINUE 349 IOFF = IOFF + LDA 350 70 CONTINUE 351 IZERO = 1 352 ELSE 353* 354* Set the last IZERO rows and columns to zero. 355* 356 DO 90 J = 1, N 357 I1 = MAX( J, IZERO ) 358 DO 80 I = I1, N 359 A( IOFF+I ) = ZERO 360 80 CONTINUE 361 IOFF = IOFF + LDA 362 90 CONTINUE 363 END IF 364 END IF 365 ELSE 366 IZERO = 0 367 END IF 368* 369 DO 150 IFACT = 1, NFACT 370* 371* Do first for FACT = 'F', then for other values. 372* 373 FACT = FACTS( IFACT ) 374* 375* Form an exact solution and set the right hand side. 376* 377 SRNAMT = 'DLARHS' 378 CALL DLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, 379 $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, 380 $ INFO ) 381 XTYPE = 'C' 382* 383* --- Test DSYSV_AA --- 384* 385 IF( IFACT.EQ.2 ) THEN 386 CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) 387 CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 388* 389* Factor the matrix and solve the system using DSYSV_AA. 390* 391 SRNAMT = 'DSYSV_AA' 392 CALL DSYSV_AA( UPLO, N, NRHS, AFAC, LDA, IWORK, 393 $ X, LDA, WORK, LWORK, INFO ) 394* 395* Adjust the expected value of INFO to account for 396* pivoting. 397* 398 IF( IZERO.GT.0 ) THEN 399 J = 1 400 K = IZERO 401 100 CONTINUE 402 IF( J.EQ.K ) THEN 403 K = IWORK( J ) 404 ELSE IF( IWORK( J ).EQ.K ) THEN 405 K = J 406 END IF 407 IF( J.LT.K ) THEN 408 J = J + 1 409 GO TO 100 410 END IF 411 ELSE 412 K = 0 413 END IF 414* 415* Check error code from DSYSV_AA . 416* 417 IF( INFO.NE.K ) THEN 418 CALL ALAERH( PATH, 'DSYSV_AA ', INFO, K, 419 $ UPLO, N, N, -1, -1, NRHS, 420 $ IMAT, NFAIL, NERRS, NOUT ) 421 GO TO 120 422 ELSE IF( INFO.NE.0 ) THEN 423 GO TO 120 424 END IF 425* 426* Reconstruct matrix from factors and compute 427* residual. 428* 429 CALL DSYT01_AA( UPLO, N, A, LDA, AFAC, LDA, 430 $ IWORK, AINV, LDA, RWORK, 431 $ RESULT( 1 ) ) 432* 433* Compute residual of the computed solution. 434* 435 CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) 436 CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, 437 $ LDA, RWORK, RESULT( 2 ) ) 438 NT = 2 439* 440* Print information about the tests that did not pass 441* the threshold. 442* 443 DO 110 K = 1, NT 444 IF( RESULT( K ).GE.THRESH ) THEN 445 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 446 $ CALL ALADHD( NOUT, PATH ) 447 WRITE( NOUT, FMT = 9999 )'DSYSV_AA ', 448 $ UPLO, N, IMAT, K, RESULT( K ) 449 NFAIL = NFAIL + 1 450 END IF 451 110 CONTINUE 452 NRUN = NRUN + NT 453 120 CONTINUE 454 END IF 455* 456 150 CONTINUE 457* 458 160 CONTINUE 459 170 CONTINUE 460 180 CONTINUE 461* 462* Print a summary of the results. 463* 464 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) 465* 466 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, 467 $ ', test ', I2, ', ratio =', G12.5 ) 468 RETURN 469* 470* End of DDRVSY_AA 471* 472 END 473