1*> \brief \b DDRVAB 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 DDRVAB( DOTYPE, NM, MVAL, NNS, 12* NSVAL, THRESH, NMAX, A, AFAC, B, 13* X, WORK, RWORK, SWORK, IWORK, NOUT ) 14* 15* .. Scalar Arguments .. 16* INTEGER NM, NMAX, NNS, NOUT 17* DOUBLE PRECISION THRESH 18* .. 19* .. Array Arguments .. 20* LOGICAL DOTYPE( * ) 21* INTEGER MVAL( * ), NSVAL( * ), IWORK( * ) 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*> DDRVAB tests DSGESV 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 M 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 row dimension M. 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 M or N, used in dimensioning 83*> the 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*> where NSMAX is the largest entry in NSVAL. 100*> \endverbatim 101*> 102*> \param[out] X 103*> \verbatim 104*> X is DOUBLE PRECISION array, dimension (NMAX*NSMAX) 105*> \endverbatim 106*> 107*> \param[out] WORK 108*> \verbatim 109*> WORK is DOUBLE PRECISION array, dimension 110*> (NMAX*max(3,NSMAX)) 111*> \endverbatim 112*> 113*> \param[out] RWORK 114*> \verbatim 115*> RWORK is DOUBLE PRECISION array, dimension 116*> (max(2*NMAX,2*NSMAX+NWORK)) 117*> \endverbatim 118*> 119*> \param[out] SWORK 120*> \verbatim 121*> SWORK is REAL array, dimension 122*> (NMAX*(NSMAX+NMAX)) 123*> \endverbatim 124*> 125*> \param[out] IWORK 126*> \verbatim 127*> IWORK is INTEGER array, dimension 128*> NMAX 129*> \endverbatim 130*> 131*> \param[in] NOUT 132*> \verbatim 133*> NOUT is INTEGER 134*> The unit number for output. 135*> \endverbatim 136* 137* Authors: 138* ======== 139* 140*> \author Univ. of Tennessee 141*> \author Univ. of California Berkeley 142*> \author Univ. of Colorado Denver 143*> \author NAG Ltd. 144* 145*> \date December 2016 146* 147*> \ingroup double_lin 148* 149* ===================================================================== 150 SUBROUTINE DDRVAB( DOTYPE, NM, MVAL, NNS, 151 $ NSVAL, THRESH, NMAX, A, AFAC, B, 152 $ X, WORK, RWORK, SWORK, IWORK, NOUT ) 153* 154* -- LAPACK test routine (version 3.7.0) -- 155* -- LAPACK is a software package provided by Univ. of Tennessee, -- 156* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 157* December 2016 158* 159* .. Scalar Arguments .. 160 INTEGER NM, NMAX, NNS, NOUT 161 DOUBLE PRECISION THRESH 162* .. 163* .. Array Arguments .. 164 LOGICAL DOTYPE( * ) 165 INTEGER MVAL( * ), NSVAL( * ), IWORK( * ) 166 REAL SWORK(*) 167 DOUBLE PRECISION A( * ), AFAC( * ), B( * ), 168 $ RWORK( * ), WORK( * ), X( * ) 169* .. 170* 171* ===================================================================== 172* 173* .. Parameters .. 174 DOUBLE PRECISION ZERO 175 PARAMETER ( ZERO = 0.0D+0 ) 176 INTEGER NTYPES 177 PARAMETER ( NTYPES = 11 ) 178 INTEGER NTESTS 179 PARAMETER ( NTESTS = 1 ) 180* .. 181* .. Local Scalars .. 182 LOGICAL ZEROT 183 CHARACTER DIST, TRANS, TYPE, XTYPE 184 CHARACTER*3 PATH 185 INTEGER I, IM, IMAT, INFO, IOFF, IRHS, 186 $ IZERO, KL, KU, LDA, M, MODE, N, 187 $ NERRS, NFAIL, NIMAT, NRHS, NRUN 188 DOUBLE PRECISION ANORM, CNDNUM 189* .. 190* .. Local Arrays .. 191 INTEGER ISEED( 4 ), ISEEDY( 4 ) 192 DOUBLE PRECISION RESULT( NTESTS ) 193* .. 194* .. Local Variables .. 195 INTEGER ITER, KASE 196* .. 197* .. External Subroutines .. 198 EXTERNAL ALAERH, ALAHD, DGET08, DLACPY, DLARHS, DLASET, 199 $ DLATB4, DLATMS 200* .. 201* .. Intrinsic Functions .. 202 INTRINSIC DBLE, MAX, MIN, SQRT 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* .. Data statements .. 214 DATA ISEEDY / 2006, 2007, 2008, 2009 / 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 ) = 'GE' 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 M in MVAL 233* 234 DO 120 IM = 1, NM 235 M = MVAL( IM ) 236 LDA = MAX( 1, M ) 237* 238 N = M 239 NIMAT = NTYPES 240 IF( M.LE.0 .OR. N.LE.0 ) 241 $ NIMAT = 1 242* 243 DO 100 IMAT = 1, NIMAT 244* 245* Do the tests only if DOTYPE( IMAT ) is true. 246* 247 IF( .NOT.DOTYPE( IMAT ) ) 248 $ GO TO 100 249* 250* Skip types 5, 6, or 7 if the matrix size is too small. 251* 252 ZEROT = IMAT.GE.5 .AND. IMAT.LE.7 253 IF( ZEROT .AND. N.LT.IMAT-4 ) 254 $ GO TO 100 255* 256* Set up parameters with DLATB4 and generate a test matrix 257* with DLATMS. 258* 259 CALL DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, 260 $ CNDNUM, DIST ) 261* 262 SRNAMT = 'DLATMS' 263 CALL DLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE, 264 $ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA, 265 $ WORK, INFO ) 266* 267* Check error code from DLATMS. 268* 269 IF( INFO.NE.0 ) THEN 270 CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, N, -1, 271 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 272 GO TO 100 273 END IF 274* 275* For types 5-7, zero one or more columns of the matrix to 276* test that INFO is returned correctly. 277* 278 IF( ZEROT ) THEN 279 IF( IMAT.EQ.5 ) THEN 280 IZERO = 1 281 ELSE IF( IMAT.EQ.6 ) THEN 282 IZERO = MIN( M, N ) 283 ELSE 284 IZERO = MIN( M, N ) / 2 + 1 285 END IF 286 IOFF = ( IZERO-1 )*LDA 287 IF( IMAT.LT.7 ) THEN 288 DO 20 I = 1, M 289 A( IOFF+I ) = ZERO 290 20 CONTINUE 291 ELSE 292 CALL DLASET( 'Full', M, N-IZERO+1, ZERO, ZERO, 293 $ A( IOFF+1 ), LDA ) 294 END IF 295 ELSE 296 IZERO = 0 297 END IF 298* 299 DO 60 IRHS = 1, NNS 300 NRHS = NSVAL( IRHS ) 301 XTYPE = 'N' 302 TRANS = 'N' 303* 304 SRNAMT = 'DLARHS' 305 CALL DLARHS( PATH, XTYPE, ' ', TRANS, N, N, KL, 306 $ KU, NRHS, A, LDA, X, LDA, B, 307 $ LDA, ISEED, INFO ) 308* 309 SRNAMT = 'DSGESV' 310* 311 KASE = KASE + 1 312* 313 CALL DLACPY( 'Full', M, N, A, LDA, AFAC, LDA ) 314* 315 CALL DSGESV( N, NRHS, A, LDA, IWORK, B, LDA, X, LDA, 316 $ WORK, SWORK, ITER, INFO) 317* 318 IF (ITER.LT.0) THEN 319 CALL DLACPY( 'Full', M, N, AFAC, LDA, A, LDA ) 320 ENDIF 321* 322* Check error code from DSGESV. This should be the same as 323* the one of DGETRF. 324* 325 IF( INFO.NE.IZERO ) THEN 326* 327 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 328 $ CALL ALAHD( NOUT, PATH ) 329 NERRS = NERRS + 1 330* 331 IF( INFO.NE.IZERO .AND. IZERO.NE.0 ) THEN 332 WRITE( NOUT, FMT = 9988 )'DSGESV',INFO, 333 $ IZERO,M,IMAT 334 ELSE 335 WRITE( NOUT, FMT = 9975 )'DSGESV',INFO, 336 $ M, IMAT 337 END IF 338 END IF 339* 340* Skip the remaining test if the matrix is singular. 341* 342 IF( INFO.NE.0 ) 343 $ GO TO 100 344* 345* Check the quality of the solution 346* 347 CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) 348* 349 CALL DGET08( TRANS, N, N, NRHS, A, LDA, X, LDA, WORK, 350 $ LDA, RWORK, RESULT( 1 ) ) 351* 352* Check if the test passes the tesing. 353* Print information about the tests that did not 354* pass the testing. 355* 356* If iterative refinement has been used and claimed to 357* be successful (ITER>0), we want 358* NORMI(B - A*X)/(NORMI(A)*NORMI(X)*EPS*SRQT(N)) < 1 359* 360* If double precision has been used (ITER<0), we want 361* NORMI(B - A*X)/(NORMI(A)*NORMI(X)*EPS) < THRES 362* (Cf. the linear solver testing routines) 363* 364 IF ((THRESH.LE.0.0E+00) 365 $ .OR.((ITER.GE.0).AND.(N.GT.0) 366 $ .AND.(RESULT(1).GE.SQRT(DBLE(N)))) 367 $ .OR.((ITER.LT.0).AND.(RESULT(1).GE.THRESH))) THEN 368* 369 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN 370 WRITE( NOUT, FMT = 8999 )'DGE' 371 WRITE( NOUT, FMT = '( '' Matrix types:'' )' ) 372 WRITE( NOUT, FMT = 8979 ) 373 WRITE( NOUT, FMT = '( '' Test ratios:'' )' ) 374 WRITE( NOUT, FMT = 8960 )1 375 WRITE( NOUT, FMT = '( '' Messages:'' )' ) 376 END IF 377* 378 WRITE( NOUT, FMT = 9998 )TRANS, N, NRHS, 379 $ IMAT, 1, RESULT( 1 ) 380 NFAIL = NFAIL + 1 381 END IF 382 NRUN = NRUN + 1 383 60 CONTINUE 384 100 CONTINUE 385 120 CONTINUE 386* 387* Print a summary of the results. 388* 389 IF( NFAIL.GT.0 ) THEN 390 WRITE( NOUT, FMT = 9996 )'DSGESV', NFAIL, NRUN 391 ELSE 392 WRITE( NOUT, FMT = 9995 )'DSGESV', NRUN 393 END IF 394 IF( NERRS.GT.0 ) THEN 395 WRITE( NOUT, FMT = 9994 )NERRS 396 END IF 397* 398 9998 FORMAT( ' TRANS=''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', 399 $ I2, ', test(', I2, ') =', G12.5 ) 400 9996 FORMAT( 1X, A6, ': ', I6, ' out of ', I6, 401 $ ' tests failed to pass the threshold' ) 402 9995 FORMAT( /1X, 'All tests for ', A6, 403 $ ' routines passed the threshold ( ', I6, ' tests run)' ) 404 9994 FORMAT( 6X, I6, ' error messages recorded' ) 405* 406* SUBNAM, INFO, INFOE, M, IMAT 407* 408 9988 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', 409 $ I5, / ' ==> M =', I5, ', type ', 410 $ I2 ) 411* 412* SUBNAM, INFO, M, IMAT 413* 414 9975 FORMAT( ' *** Error code from ', A6, '=', I5, ' for M=', I5, 415 $ ', type ', I2 ) 416 8999 FORMAT( / 1X, A3, ': General dense matrices' ) 417 8979 FORMAT( 4X, '1. Diagonal', 24X, '7. Last n/2 columns zero', / 4X, 418 $ '2. Upper triangular', 16X, 419 $ '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, 420 $ '3. Lower triangular', 16X, '9. Random, CNDNUM = 0.1/EPS', 421 $ / 4X, '4. Random, CNDNUM = 2', 13X, 422 $ '10. Scaled near underflow', / 4X, '5. First column zero', 423 $ 14X, '11. Scaled near overflow', / 4X, 424 $ '6. Last column zero' ) 425 8960 FORMAT( 3X, I2, ': norm_1( B - A * X ) / ', 426 $ '( norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF', 427 $ / 4x, 'or norm_1( B - A * X ) / ', 428 $ '( norm_1(A) * norm_1(X) * EPS ) > THRES if DGETRF' ) 429 RETURN 430* 431* End of DDRVAB 432* 433 END 434