1*> \brief \b DDRVAC 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 DDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, 12* A, AFAC, B, X, WORK, 13* RWORK, SWORK, NOUT ) 14* 15* .. Scalar Arguments .. 16* INTEGER NMAX, NM, NNS, NOUT 17* DOUBLE PRECISION THRESH 18* .. 19* .. Array Arguments .. 20* LOGICAL DOTYPE( * ) 21* INTEGER MVAL( * ), NSVAL( * ) 22* REAL SWORK(*) 23* DOUBLE PRECISION A( * ), AFAC( * ), B( * ), 24* $ RWORK( * ), WORK( * ), X( * ) 25* .. 26* 27* 28*> \par Purpose: 29* ============= 30*> 31*> \verbatim 32*> 33*> DDRVAC tests DSPOSV. 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] NM 48*> \verbatim 49*> NM is INTEGER 50*> The number of values of N contained in the vector MVAL. 51*> \endverbatim 52*> 53*> \param[in] MVAL 54*> \verbatim 55*> MVAL is INTEGER array, dimension (NM) 56*> The values of the matrix dimension N. 57*> \endverbatim 58*> 59*> \param[in] NNS 60*> \verbatim 61*> NNS is INTEGER 62*> The number of values of NRHS contained in the vector NSVAL. 63*> \endverbatim 64*> 65*> \param[in] NSVAL 66*> \verbatim 67*> NSVAL is INTEGER array, dimension (NNS) 68*> The values of the number of right hand sides NRHS. 69*> \endverbatim 70*> 71*> \param[in] THRESH 72*> \verbatim 73*> THRESH is DOUBLE PRECISION 74*> The threshold value for the test ratios. A result is 75*> included in the output file if RESULT >= THRESH. To have 76*> every test ratio printed, use THRESH = 0. 77*> \endverbatim 78*> 79*> \param[in] NMAX 80*> \verbatim 81*> NMAX is INTEGER 82*> The maximum value permitted for N, used in dimensioning the 83*> work arrays. 84*> \endverbatim 85*> 86*> \param[out] A 87*> \verbatim 88*> A is DOUBLE PRECISION array, dimension (NMAX*NMAX) 89*> \endverbatim 90*> 91*> \param[out] AFAC 92*> \verbatim 93*> AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX) 94*> \endverbatim 95*> 96*> \param[out] B 97*> \verbatim 98*> B is DOUBLE PRECISION array, dimension (NMAX*NSMAX) 99*> \endverbatim 100*> 101*> \param[out] X 102*> \verbatim 103*> X is DOUBLE PRECISION array, dimension (NMAX*NSMAX) 104*> \endverbatim 105*> 106*> \param[out] WORK 107*> \verbatim 108*> WORK is DOUBLE PRECISION array, dimension 109*> (NMAX*max(3,NSMAX)) 110*> \endverbatim 111*> 112*> \param[out] RWORK 113*> \verbatim 114*> RWORK is DOUBLE PRECISION array, dimension 115*> (max(2*NMAX,2*NSMAX+NWORK)) 116*> \endverbatim 117*> 118*> \param[out] SWORK 119*> \verbatim 120*> SWORK is REAL array, dimension 121*> (NMAX*(NSMAX+NMAX)) 122*> \endverbatim 123*> 124*> \param[in] NOUT 125*> \verbatim 126*> NOUT is INTEGER 127*> The unit number for output. 128*> \endverbatim 129* 130* Authors: 131* ======== 132* 133*> \author Univ. of Tennessee 134*> \author Univ. of California Berkeley 135*> \author Univ. of Colorado Denver 136*> \author NAG Ltd. 137* 138*> \date December 2016 139* 140*> \ingroup double_lin 141* 142* ===================================================================== 143 SUBROUTINE DDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, 144 $ A, AFAC, B, X, WORK, 145 $ RWORK, SWORK, NOUT ) 146* 147* -- LAPACK test routine (version 3.7.0) -- 148* -- LAPACK is a software package provided by Univ. of Tennessee, -- 149* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 150* December 2016 151* 152* .. Scalar Arguments .. 153 INTEGER NMAX, NM, NNS, NOUT 154 DOUBLE PRECISION THRESH 155* .. 156* .. Array Arguments .. 157 LOGICAL DOTYPE( * ) 158 INTEGER MVAL( * ), NSVAL( * ) 159 REAL SWORK(*) 160 DOUBLE PRECISION A( * ), AFAC( * ), B( * ), 161 $ RWORK( * ), WORK( * ), X( * ) 162* .. 163* 164* ===================================================================== 165* 166* .. Parameters .. 167 DOUBLE PRECISION ZERO 168 PARAMETER ( ZERO = 0.0D+0 ) 169 INTEGER NTYPES 170 PARAMETER ( NTYPES = 9 ) 171 INTEGER NTESTS 172 PARAMETER ( NTESTS = 1 ) 173* .. 174* .. Local Scalars .. 175 LOGICAL ZEROT 176 CHARACTER DIST, TYPE, UPLO, XTYPE 177 CHARACTER*3 PATH 178 INTEGER I, IM, IMAT, INFO, IOFF, IRHS, IUPLO, 179 $ IZERO, KL, KU, LDA, MODE, N, 180 $ NERRS, NFAIL, NIMAT, NRHS, NRUN 181 DOUBLE PRECISION ANORM, CNDNUM 182* .. 183* .. Local Arrays .. 184 CHARACTER UPLOS( 2 ) 185 INTEGER ISEED( 4 ), ISEEDY( 4 ) 186 DOUBLE PRECISION RESULT( NTESTS ) 187* .. 188* .. Local Variables .. 189 INTEGER ITER, KASE 190* .. 191* .. External Functions .. 192 LOGICAL LSAME 193 EXTERNAL LSAME 194* .. 195* .. External Subroutines .. 196 EXTERNAL ALAERH, DLACPY, 197 $ DLARHS, DLASET, DLATB4, DLATMS, 198 $ DPOT06, DSPOSV 199* .. 200* .. Intrinsic Functions .. 201 INTRINSIC DBLE, MAX, SQRT 202* .. 203* .. Scalars in Common .. 204 LOGICAL LERR, OK 205 CHARACTER*32 SRNAMT 206 INTEGER INFOT, NUNIT 207* .. 208* .. Common blocks .. 209 COMMON / INFOC / INFOT, NUNIT, OK, LERR 210 COMMON / SRNAMC / SRNAMT 211* .. 212* .. Data statements .. 213 DATA ISEEDY / 1988, 1989, 1990, 1991 / 214 DATA UPLOS / 'U', 'L' / 215* .. 216* .. Executable Statements .. 217* 218* Initialize constants and the random number seed. 219* 220 KASE = 0 221 PATH( 1: 1 ) = 'Double precision' 222 PATH( 2: 3 ) = 'PO' 223 NRUN = 0 224 NFAIL = 0 225 NERRS = 0 226 DO 10 I = 1, 4 227 ISEED( I ) = ISEEDY( I ) 228 10 CONTINUE 229* 230 INFOT = 0 231* 232* Do for each value of N in MVAL 233* 234 DO 120 IM = 1, NM 235 N = MVAL( IM ) 236 LDA = MAX( N, 1 ) 237 NIMAT = NTYPES 238 IF( N.LE.0 ) 239 $ NIMAT = 1 240* 241 DO 110 IMAT = 1, NIMAT 242* 243* Do the tests only if DOTYPE( IMAT ) is true. 244* 245 IF( .NOT.DOTYPE( IMAT ) ) 246 $ GO TO 110 247* 248* Skip types 3, 4, or 5 if the matrix size is too small. 249* 250 ZEROT = IMAT.GE.3 .AND. IMAT.LE.5 251 IF( ZEROT .AND. N.LT.IMAT-2 ) 252 $ GO TO 110 253* 254* Do first for UPLO = 'U', then for UPLO = 'L' 255* 256 DO 100 IUPLO = 1, 2 257 UPLO = UPLOS( IUPLO ) 258* 259* Set up parameters with DLATB4 and generate a test matrix 260* with DLATMS. 261* 262 CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 263 $ CNDNUM, DIST ) 264* 265 SRNAMT = 'DLATMS' 266 CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, 267 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, 268 $ INFO ) 269* 270* Check error code from DLATMS. 271* 272 IF( INFO.NE.0 ) THEN 273 CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1, 274 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 275 GO TO 100 276 END IF 277* 278* For types 3-5, zero one row and column of the matrix to 279* test that INFO is returned correctly. 280* 281 IF( ZEROT ) THEN 282 IF( IMAT.EQ.3 ) THEN 283 IZERO = 1 284 ELSE IF( IMAT.EQ.4 ) THEN 285 IZERO = N 286 ELSE 287 IZERO = N / 2 + 1 288 END IF 289 IOFF = ( IZERO-1 )*LDA 290* 291* Set row and column IZERO of A to 0. 292* 293 IF( IUPLO.EQ.1 ) THEN 294 DO 20 I = 1, IZERO - 1 295 A( IOFF+I ) = ZERO 296 20 CONTINUE 297 IOFF = IOFF + IZERO 298 DO 30 I = IZERO, N 299 A( IOFF ) = ZERO 300 IOFF = IOFF + LDA 301 30 CONTINUE 302 ELSE 303 IOFF = IZERO 304 DO 40 I = 1, IZERO - 1 305 A( IOFF ) = ZERO 306 IOFF = IOFF + LDA 307 40 CONTINUE 308 IOFF = IOFF - IZERO 309 DO 50 I = IZERO, N 310 A( IOFF+I ) = ZERO 311 50 CONTINUE 312 END IF 313 ELSE 314 IZERO = 0 315 END IF 316* 317 DO 60 IRHS = 1, NNS 318 NRHS = NSVAL( IRHS ) 319 XTYPE = 'N' 320* 321* Form an exact solution and set the right hand side. 322* 323 SRNAMT = 'DLARHS' 324 CALL DLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, 325 $ NRHS, A, LDA, X, LDA, B, LDA, 326 $ ISEED, INFO ) 327* 328* Compute the L*L' or U'*U factorization of the 329* matrix and solve the system. 330* 331 SRNAMT = 'DSPOSV ' 332 KASE = KASE + 1 333* 334 CALL DLACPY( 'All', N, N, A, LDA, AFAC, LDA) 335* 336 CALL DSPOSV( UPLO, N, NRHS, AFAC, LDA, B, LDA, X, LDA, 337 $ WORK, SWORK, ITER, INFO ) 338 339 IF (ITER.LT.0) THEN 340 CALL DLACPY( 'All', N, N, A, LDA, AFAC, LDA ) 341 ENDIF 342* 343* Check error code from DSPOSV . 344* 345 IF( INFO.NE.IZERO ) THEN 346* 347 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 348 $ CALL ALAHD( NOUT, PATH ) 349 NERRS = NERRS + 1 350* 351 IF( INFO.NE.IZERO .AND. IZERO.NE.0 ) THEN 352 WRITE( NOUT, FMT = 9988 )'DSPOSV',INFO,IZERO,N, 353 $ IMAT 354 ELSE 355 WRITE( NOUT, FMT = 9975 )'DSPOSV',INFO,N,IMAT 356 END IF 357 END IF 358* 359* Skip the remaining test if the matrix is singular. 360* 361 IF( INFO.NE.0 ) 362 $ GO TO 110 363* 364* Check the quality of the solution 365* 366 CALL DLACPY( 'All', N, NRHS, B, LDA, WORK, LDA ) 367* 368 CALL DPOT06( UPLO, N, NRHS, A, LDA, X, LDA, WORK, 369 $ LDA, RWORK, RESULT( 1 ) ) 370* 371* Check if the test passes the tesing. 372* Print information about the tests that did not 373* pass the testing. 374* 375* If iterative refinement has been used and claimed to 376* be successful (ITER>0), we want 377* NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS*SRQT(N)) < 1 378* 379* If double precision has been used (ITER<0), we want 380* NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS) < THRES 381* (Cf. the linear solver testing routines) 382* 383 IF ((THRESH.LE.0.0E+00) 384 $ .OR.((ITER.GE.0).AND.(N.GT.0) 385 $ .AND.(RESULT(1).GE.SQRT(DBLE(N)))) 386 $ .OR.((ITER.LT.0).AND.(RESULT(1).GE.THRESH))) THEN 387* 388 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN 389 WRITE( NOUT, FMT = 8999 )'DPO' 390 WRITE( NOUT, FMT = '( '' Matrix types:'' )' ) 391 WRITE( NOUT, FMT = 8979 ) 392 WRITE( NOUT, FMT = '( '' Test ratios:'' )' ) 393 WRITE( NOUT, FMT = 8960 )1 394 WRITE( NOUT, FMT = '( '' Messages:'' )' ) 395 END IF 396* 397 WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, IMAT, 1, 398 $ RESULT( 1 ) 399* 400 NFAIL = NFAIL + 1 401* 402 END IF 403* 404 NRUN = NRUN + 1 405* 406 60 CONTINUE 407 100 CONTINUE 408 110 CONTINUE 409 120 CONTINUE 410* 411* Print a summary of the results. 412* 413 IF( NFAIL.GT.0 ) THEN 414 WRITE( NOUT, FMT = 9996 )'DSPOSV', NFAIL, NRUN 415 ELSE 416 WRITE( NOUT, FMT = 9995 )'DSPOSV', NRUN 417 END IF 418 IF( NERRS.GT.0 ) THEN 419 WRITE( NOUT, FMT = 9994 )NERRS 420 END IF 421* 422 9998 FORMAT( ' UPLO=''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', 423 $ I2, ', test(', I2, ') =', G12.5 ) 424 9996 FORMAT( 1X, A6, ': ', I6, ' out of ', I6, 425 $ ' tests failed to pass the threshold' ) 426 9995 FORMAT( /1X, 'All tests for ', A6, 427 $ ' routines passed the threshold ( ', I6, ' tests run)' ) 428 9994 FORMAT( 6X, I6, ' error messages recorded' ) 429* 430* SUBNAM, INFO, INFOE, N, IMAT 431* 432 9988 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', 433 $ I5, / ' ==> N =', I5, ', type ', 434 $ I2 ) 435* 436* SUBNAM, INFO, N, IMAT 437* 438 9975 FORMAT( ' *** Error code from ', A6, '=', I5, ' for M=', I5, 439 $ ', type ', I2 ) 440 8999 FORMAT( / 1X, A3, ': positive definite dense matrices' ) 441 8979 FORMAT( 4X, '1. Diagonal', 24X, '7. Last n/2 columns zero', / 4X, 442 $ '2. Upper triangular', 16X, 443 $ '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, 444 $ '3. Lower triangular', 16X, '9. Random, CNDNUM = 0.1/EPS', 445 $ / 4X, '4. Random, CNDNUM = 2', 13X, 446 $ '10. Scaled near underflow', / 4X, '5. First column zero', 447 $ 14X, '11. Scaled near overflow', / 4X, 448 $ '6. Last column zero' ) 449 8960 FORMAT( 3X, I2, ': norm_1( B - A * X ) / ', 450 $ '( norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF', 451 $ / 4x, 'or norm_1( B - A * X ) / ', 452 $ '( norm_1(A) * norm_1(X) * EPS ) > THRES if DPOTRF' ) 453 454 RETURN 455* 456* End of DDRVAC 457* 458 END 459