1*> \brief \b DDRVSY_ROOK 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_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, 12* $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, 13* $ RWORK, IWORK, 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_ROOK tests the driver routines DSYSV_ROOK. 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_ROOK( 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 PATH, MATPATH 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 AINVNM, ANORM, CNDNUM, RCONDC 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 DLANSY 195 EXTERNAL DLANSY 196* .. 197* .. External Subroutines .. 198 EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGET04, DLACPY, 199 $ DLARHS, DLASET, DLATB4, DLATMS, DPOT02, DPOT05, 200 $ DSYSV_ROOK, DSYT01_ROOK, DSYTRF_ROOK, 201 $ DSYTRI_ROOK, 202 $ XLAENV 203* .. 204* .. Scalars in Common .. 205 LOGICAL LERR, OK 206 CHARACTER*32 SRNAMT 207 INTEGER INFOT, NUNIT 208* .. 209* .. Common blocks .. 210 COMMON / INFOC / INFOT, NUNIT, OK, LERR 211 COMMON / SRNAMC / SRNAMT 212* .. 213* .. Intrinsic Functions .. 214 INTRINSIC MAX, MIN 215* .. 216* .. Data statements .. 217 DATA ISEEDY / 1988, 1989, 1990, 1991 / 218 DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / 219* .. 220* .. Executable Statements .. 221* 222* Initialize constants and the random number seed. 223* 224* Test path 225* 226 PATH( 1: 1 ) = 'Double precision' 227 PATH( 2: 3 ) = 'SR' 228* 229* Path to generate matrices 230* 231 MATPATH( 1: 1 ) = 'Double precision' 232 MATPATH( 2: 3 ) = 'SY' 233* 234 NRUN = 0 235 NFAIL = 0 236 NERRS = 0 237 DO 10 I = 1, 4 238 ISEED( I ) = ISEEDY( I ) 239 10 CONTINUE 240 LWORK = MAX( 2*NMAX, NMAX*NRHS ) 241* 242* Test the error exits 243* 244 IF( TSTERR ) 245 $ CALL DERRVX( PATH, NOUT ) 246 INFOT = 0 247* 248* Set the block size and minimum block size for which the block 249* routine should be used, which will be later returned by ILAENV. 250* 251 NB = 1 252 NBMIN = 2 253 CALL XLAENV( 1, NB ) 254 CALL XLAENV( 2, NBMIN ) 255* 256* Do for each value of N in NVAL 257* 258 DO 180 IN = 1, NN 259 N = NVAL( IN ) 260 LDA = MAX( N, 1 ) 261 XTYPE = 'N' 262 NIMAT = NTYPES 263 IF( N.LE.0 ) 264 $ NIMAT = 1 265* 266 DO 170 IMAT = 1, NIMAT 267* 268* Do the tests only if DOTYPE( IMAT ) is true. 269* 270 IF( .NOT.DOTYPE( IMAT ) ) 271 $ GO TO 170 272* 273* Skip types 3, 4, 5, or 6 if the matrix size is too small. 274* 275 ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 276 IF( ZEROT .AND. N.LT.IMAT-2 ) 277 $ GO TO 170 278* 279* Do first for UPLO = 'U', then for UPLO = 'L' 280* 281 DO 160 IUPLO = 1, 2 282 UPLO = UPLOS( IUPLO ) 283* 284* Begin generate the test matrix A. 285* 286* Set up parameters with DLATB4 for the matrix generator 287* based on the type of matrix to be generated. 288* 289 CALL DLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, 290 $ MODE, CNDNUM, DIST ) 291* 292* Generate a matrix with DLATMS. 293* 294 SRNAMT = 'DLATMS' 295 CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, 296 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, 297 $ INFO ) 298* 299* Check error code from DLATMS and handle error. 300* 301 IF( INFO.NE.0 ) THEN 302 CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1, 303 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 304* 305* Skip all tests for this generated matrix 306* 307 GO TO 160 308 END IF 309* 310* For types 3-6, zero one or more rows and columns of the 311* matrix to test that INFO is returned correctly. 312* 313 IF( ZEROT ) THEN 314 IF( IMAT.EQ.3 ) THEN 315 IZERO = 1 316 ELSE IF( IMAT.EQ.4 ) THEN 317 IZERO = N 318 ELSE 319 IZERO = N / 2 + 1 320 END IF 321* 322 IF( IMAT.LT.6 ) THEN 323* 324* Set row and column IZERO to zero. 325* 326 IF( IUPLO.EQ.1 ) THEN 327 IOFF = ( IZERO-1 )*LDA 328 DO 20 I = 1, IZERO - 1 329 A( IOFF+I ) = ZERO 330 20 CONTINUE 331 IOFF = IOFF + IZERO 332 DO 30 I = IZERO, N 333 A( IOFF ) = ZERO 334 IOFF = IOFF + LDA 335 30 CONTINUE 336 ELSE 337 IOFF = IZERO 338 DO 40 I = 1, IZERO - 1 339 A( IOFF ) = ZERO 340 IOFF = IOFF + LDA 341 40 CONTINUE 342 IOFF = IOFF - IZERO 343 DO 50 I = IZERO, N 344 A( IOFF+I ) = ZERO 345 50 CONTINUE 346 END IF 347 ELSE 348 IOFF = 0 349 IF( IUPLO.EQ.1 ) THEN 350* 351* Set the first IZERO rows and columns to zero. 352* 353 DO 70 J = 1, N 354 I2 = MIN( J, IZERO ) 355 DO 60 I = 1, I2 356 A( IOFF+I ) = ZERO 357 60 CONTINUE 358 IOFF = IOFF + LDA 359 70 CONTINUE 360 ELSE 361* 362* Set the last IZERO rows and columns to zero. 363* 364 DO 90 J = 1, N 365 I1 = MAX( J, IZERO ) 366 DO 80 I = I1, N 367 A( IOFF+I ) = ZERO 368 80 CONTINUE 369 IOFF = IOFF + LDA 370 90 CONTINUE 371 END IF 372 END IF 373 ELSE 374 IZERO = 0 375 END IF 376* 377* End generate the test matrix A. 378* 379 DO 150 IFACT = 1, NFACT 380* 381* Do first for FACT = 'F', then for other values. 382* 383 FACT = FACTS( IFACT ) 384* 385* Compute the condition number for comparison with 386* the value returned by DSYSVX_ROOK. 387* 388 IF( ZEROT ) THEN 389 IF( IFACT.EQ.1 ) 390 $ GO TO 150 391 RCONDC = ZERO 392* 393 ELSE IF( IFACT.EQ.1 ) THEN 394* 395* Compute the 1-norm of A. 396* 397 ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK ) 398* 399* Factor the matrix A. 400* 401 CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) 402 CALL DSYTRF_ROOK( UPLO, N, AFAC, LDA, IWORK, WORK, 403 $ LWORK, INFO ) 404* 405* Compute inv(A) and take its norm. 406* 407 CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) 408 LWORK = (N+NB+1)*(NB+3) 409 CALL DSYTRI_ROOK( UPLO, N, AINV, LDA, IWORK, 410 $ WORK, INFO ) 411 AINVNM = DLANSY( '1', UPLO, N, AINV, LDA, RWORK ) 412* 413* Compute the 1-norm condition number of A. 414* 415 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 416 RCONDC = ONE 417 ELSE 418 RCONDC = ( ONE / ANORM ) / AINVNM 419 END IF 420 END IF 421* 422* Form an exact solution and set the right hand side. 423* 424 SRNAMT = 'DLARHS' 425 CALL DLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, 426 $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, 427 $ INFO ) 428 XTYPE = 'C' 429* 430* --- Test DSYSV_ROOK --- 431* 432 IF( IFACT.EQ.2 ) THEN 433 CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) 434 CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 435* 436* Factor the matrix and solve the system using 437* DSYSV_ROOK. 438* 439 SRNAMT = 'DSYSV_ROOK' 440 CALL DSYSV_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK, 441 $ X, LDA, WORK, LWORK, INFO ) 442* 443* Adjust the expected value of INFO to account for 444* pivoting. 445* 446 K = IZERO 447 IF( K.GT.0 ) THEN 448 100 CONTINUE 449 IF( IWORK( K ).LT.0 ) THEN 450 IF( IWORK( K ).NE.-K ) THEN 451 K = -IWORK( K ) 452 GO TO 100 453 END IF 454 ELSE IF( IWORK( K ).NE.K ) THEN 455 K = IWORK( K ) 456 GO TO 100 457 END IF 458 END IF 459* 460* Check error code from DSYSV_ROOK and handle error. 461* 462 IF( INFO.NE.K ) THEN 463 CALL ALAERH( PATH, 'DSYSV_ROOK', INFO, K, UPLO, 464 $ N, N, -1, -1, NRHS, IMAT, NFAIL, 465 $ NERRS, NOUT ) 466 GO TO 120 467 ELSE IF( INFO.NE.0 ) THEN 468 GO TO 120 469 END IF 470* 471*+ TEST 1 Reconstruct matrix from factors and compute 472* residual. 473* 474 CALL DSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDA, 475 $ IWORK, AINV, LDA, RWORK, 476 $ RESULT( 1 ) ) 477* 478*+ TEST 2 Compute residual of the computed solution. 479* 480 CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) 481 CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, 482 $ LDA, RWORK, RESULT( 2 ) ) 483* 484*+ TEST 3 485* Check solution from generated exact solution. 486* 487 CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 488 $ RESULT( 3 ) ) 489 NT = 3 490* 491* Print information about the tests that did not pass 492* the threshold. 493* 494 DO 110 K = 1, NT 495 IF( RESULT( K ).GE.THRESH ) THEN 496 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 497 $ CALL ALADHD( NOUT, PATH ) 498 WRITE( NOUT, FMT = 9999 )'DSYSV_ROOK', UPLO, 499 $ N, IMAT, K, RESULT( K ) 500 NFAIL = NFAIL + 1 501 END IF 502 110 CONTINUE 503 NRUN = NRUN + NT 504 120 CONTINUE 505 END IF 506* 507 150 CONTINUE 508* 509 160 CONTINUE 510 170 CONTINUE 511 180 CONTINUE 512* 513* Print a summary of the results. 514* 515 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) 516* 517 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, 518 $ ', test ', I2, ', ratio =', G12.5 ) 519 RETURN 520* 521* End of DDRVSY_ROOK 522* 523 END 524