1*> \brief \b DCHKQR 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 DCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, 12* NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, 13* B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) 14* 15* .. Scalar Arguments .. 16* LOGICAL TSTERR 17* INTEGER NM, NMAX, NN, NNB, NOUT, NRHS 18* DOUBLE PRECISION THRESH 19* .. 20* .. Array Arguments .. 21* LOGICAL DOTYPE( * ) 22* INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ), 23* $ NXVAL( * ) 24* DOUBLE PRECISION A( * ), AC( * ), AF( * ), AQ( * ), AR( * ), 25* $ B( * ), RWORK( * ), TAU( * ), WORK( * ), 26* $ X( * ), XACT( * ) 27* .. 28* 29* 30*> \par Purpose: 31* ============= 32*> 33*> \verbatim 34*> 35*> DCHKQR tests DGEQRF, DORGQR and DORMQR. 36*> \endverbatim 37* 38* Arguments: 39* ========== 40* 41*> \param[in] DOTYPE 42*> \verbatim 43*> DOTYPE is LOGICAL array, dimension (NTYPES) 44*> The matrix types to be used for testing. Matrices of type j 45*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 46*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 47*> \endverbatim 48*> 49*> \param[in] NM 50*> \verbatim 51*> NM is INTEGER 52*> The number of values of M contained in the vector MVAL. 53*> \endverbatim 54*> 55*> \param[in] MVAL 56*> \verbatim 57*> MVAL is INTEGER array, dimension (NM) 58*> The values of the matrix row dimension M. 59*> \endverbatim 60*> 61*> \param[in] NN 62*> \verbatim 63*> NN is INTEGER 64*> The number of values of N contained in the vector NVAL. 65*> \endverbatim 66*> 67*> \param[in] NVAL 68*> \verbatim 69*> NVAL is INTEGER array, dimension (NN) 70*> The values of the matrix column dimension N. 71*> \endverbatim 72*> 73*> \param[in] NNB 74*> \verbatim 75*> NNB is INTEGER 76*> The number of values of NB and NX contained in the 77*> vectors NBVAL and NXVAL. The blocking parameters are used 78*> in pairs (NB,NX). 79*> \endverbatim 80*> 81*> \param[in] NBVAL 82*> \verbatim 83*> NBVAL is INTEGER array, dimension (NNB) 84*> The values of the blocksize NB. 85*> \endverbatim 86*> 87*> \param[in] NXVAL 88*> \verbatim 89*> NXVAL is INTEGER array, dimension (NNB) 90*> The values of the crossover point NX. 91*> \endverbatim 92*> 93*> \param[in] NRHS 94*> \verbatim 95*> NRHS is INTEGER 96*> The number of right hand side vectors to be generated for 97*> each linear system. 98*> \endverbatim 99*> 100*> \param[in] THRESH 101*> \verbatim 102*> THRESH is DOUBLE PRECISION 103*> The threshold value for the test ratios. A result is 104*> included in the output file if RESULT >= THRESH. To have 105*> every test ratio printed, use THRESH = 0. 106*> \endverbatim 107*> 108*> \param[in] TSTERR 109*> \verbatim 110*> TSTERR is LOGICAL 111*> Flag that indicates whether error exits are to be tested. 112*> \endverbatim 113*> 114*> \param[in] NMAX 115*> \verbatim 116*> NMAX is INTEGER 117*> The maximum value permitted for M or N, used in dimensioning 118*> the work arrays. 119*> \endverbatim 120*> 121*> \param[out] A 122*> \verbatim 123*> A is DOUBLE PRECISION array, dimension (NMAX*NMAX) 124*> \endverbatim 125*> 126*> \param[out] AF 127*> \verbatim 128*> AF is DOUBLE PRECISION array, dimension (NMAX*NMAX) 129*> \endverbatim 130*> 131*> \param[out] AQ 132*> \verbatim 133*> AQ is DOUBLE PRECISION array, dimension (NMAX*NMAX) 134*> \endverbatim 135*> 136*> \param[out] AR 137*> \verbatim 138*> AR is DOUBLE PRECISION array, dimension (NMAX*NMAX) 139*> \endverbatim 140*> 141*> \param[out] AC 142*> \verbatim 143*> AC is DOUBLE PRECISION array, dimension (NMAX*NMAX) 144*> \endverbatim 145*> 146*> \param[out] B 147*> \verbatim 148*> B is DOUBLE PRECISION array, dimension (NMAX*NRHS) 149*> \endverbatim 150*> 151*> \param[out] X 152*> \verbatim 153*> X is DOUBLE PRECISION array, dimension (NMAX*NRHS) 154*> \endverbatim 155*> 156*> \param[out] XACT 157*> \verbatim 158*> XACT is DOUBLE PRECISION array, dimension (NMAX*NRHS) 159*> \endverbatim 160*> 161*> \param[out] TAU 162*> \verbatim 163*> TAU is DOUBLE PRECISION array, dimension (NMAX) 164*> \endverbatim 165*> 166*> \param[out] WORK 167*> \verbatim 168*> WORK is DOUBLE PRECISION array, dimension (NMAX*NMAX) 169*> \endverbatim 170*> 171*> \param[out] RWORK 172*> \verbatim 173*> RWORK is DOUBLE PRECISION array, dimension (NMAX) 174*> \endverbatim 175*> 176*> \param[out] IWORK 177*> \verbatim 178*> IWORK is INTEGER array, dimension (NMAX) 179*> \endverbatim 180*> 181*> \param[in] NOUT 182*> \verbatim 183*> NOUT is INTEGER 184*> The unit number for output. 185*> \endverbatim 186* 187* Authors: 188* ======== 189* 190*> \author Univ. of Tennessee 191*> \author Univ. of California Berkeley 192*> \author Univ. of Colorado Denver 193*> \author NAG Ltd. 194* 195*> \date November 2011 196* 197*> \ingroup double_lin 198* 199* ===================================================================== 200 SUBROUTINE DCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, 201 $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, 202 $ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) 203* 204* -- LAPACK test routine (version 3.4.0) -- 205* -- LAPACK is a software package provided by Univ. of Tennessee, -- 206* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 207* November 2011 208* 209* .. Scalar Arguments .. 210 LOGICAL TSTERR 211 INTEGER NM, NMAX, NN, NNB, NOUT, NRHS 212 DOUBLE PRECISION THRESH 213* .. 214* .. Array Arguments .. 215 LOGICAL DOTYPE( * ) 216 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ), 217 $ NXVAL( * ) 218 DOUBLE PRECISION A( * ), AC( * ), AF( * ), AQ( * ), AR( * ), 219 $ B( * ), RWORK( * ), TAU( * ), WORK( * ), 220 $ X( * ), XACT( * ) 221* .. 222* 223* ===================================================================== 224* 225* .. Parameters .. 226 INTEGER NTESTS 227 PARAMETER ( NTESTS = 9 ) 228 INTEGER NTYPES 229 PARAMETER ( NTYPES = 8 ) 230 DOUBLE PRECISION ZERO 231 PARAMETER ( ZERO = 0.0D0 ) 232* .. 233* .. Local Scalars .. 234 CHARACTER DIST, TYPE 235 CHARACTER*3 PATH 236 INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA, 237 $ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK, 238 $ NRUN, NT, NX 239 DOUBLE PRECISION ANORM, CNDNUM 240* .. 241* .. Local Arrays .. 242 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 ) 243 DOUBLE PRECISION RESULT( NTESTS ) 244* .. 245* .. External Functions .. 246 LOGICAL DGENND 247 EXTERNAL DGENND 248* .. 249* .. External Subroutines .. 250 EXTERNAL ALAERH, ALAHD, ALASUM, DERRQR, DGEQRS, DGET02, 251 $ DLACPY, DLARHS, DLATB4, DLATMS, DQRT01, 252 $ DQRT01P, DQRT02, DQRT03, XLAENV 253* .. 254* .. Intrinsic Functions .. 255 INTRINSIC MAX, MIN 256* .. 257* .. Scalars in Common .. 258 LOGICAL LERR, OK 259 CHARACTER*32 SRNAMT 260 INTEGER INFOT, NUNIT 261* .. 262* .. Common blocks .. 263 COMMON / INFOC / INFOT, NUNIT, OK, LERR 264 COMMON / SRNAMC / SRNAMT 265* .. 266* .. Data statements .. 267 DATA ISEEDY / 1988, 1989, 1990, 1991 / 268* .. 269* .. Executable Statements .. 270* 271* Initialize constants and the random number seed. 272* 273 PATH( 1: 1 ) = 'Double precision' 274 PATH( 2: 3 ) = 'QR' 275 NRUN = 0 276 NFAIL = 0 277 NERRS = 0 278 DO 10 I = 1, 4 279 ISEED( I ) = ISEEDY( I ) 280 10 CONTINUE 281* 282* Test the error exits 283* 284 IF( TSTERR ) 285 $ CALL DERRQR( PATH, NOUT ) 286 INFOT = 0 287 CALL XLAENV( 2, 2 ) 288* 289 LDA = NMAX 290 LWORK = NMAX*MAX( NMAX, NRHS ) 291* 292* Do for each value of M in MVAL. 293* 294 DO 70 IM = 1, NM 295 M = MVAL( IM ) 296* 297* Do for each value of N in NVAL. 298* 299 DO 60 IN = 1, NN 300 N = NVAL( IN ) 301 MINMN = MIN( M, N ) 302 DO 50 IMAT = 1, NTYPES 303* 304* Do the tests only if DOTYPE( IMAT ) is true. 305* 306 IF( .NOT.DOTYPE( IMAT ) ) 307 $ GO TO 50 308* 309* Set up parameters with DLATB4 and generate a test matrix 310* with DLATMS. 311* 312 CALL DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, 313 $ CNDNUM, DIST ) 314* 315 SRNAMT = 'DLATMS' 316 CALL DLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE, 317 $ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA, 318 $ WORK, INFO ) 319* 320* Check error code from DLATMS. 321* 322 IF( INFO.NE.0 ) THEN 323 CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, N, -1, 324 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 325 GO TO 50 326 END IF 327* 328* Set some values for K: the first value must be MINMN, 329* corresponding to the call of DQRT01; other values are 330* used in the calls of DQRT02, and must not exceed MINMN. 331* 332 KVAL( 1 ) = MINMN 333 KVAL( 2 ) = 0 334 KVAL( 3 ) = 1 335 KVAL( 4 ) = MINMN / 2 336 IF( MINMN.EQ.0 ) THEN 337 NK = 1 338 ELSE IF( MINMN.EQ.1 ) THEN 339 NK = 2 340 ELSE IF( MINMN.LE.3 ) THEN 341 NK = 3 342 ELSE 343 NK = 4 344 END IF 345* 346* Do for each value of K in KVAL 347* 348 DO 40 IK = 1, NK 349 K = KVAL( IK ) 350* 351* Do for each pair of values (NB,NX) in NBVAL and NXVAL. 352* 353 DO 30 INB = 1, NNB 354 NB = NBVAL( INB ) 355 CALL XLAENV( 1, NB ) 356 NX = NXVAL( INB ) 357 CALL XLAENV( 3, NX ) 358 DO I = 1, NTESTS 359 RESULT( I ) = ZERO 360 END DO 361 NT = 2 362 IF( IK.EQ.1 ) THEN 363* 364* Test DGEQRF 365* 366 CALL DQRT01( M, N, A, AF, AQ, AR, LDA, TAU, 367 $ WORK, LWORK, RWORK, RESULT( 1 ) ) 368 369* 370* Test DGEQRFP 371* 372 CALL DQRT01P( M, N, A, AF, AQ, AR, LDA, TAU, 373 $ WORK, LWORK, RWORK, RESULT( 8 ) ) 374 375 IF( .NOT. DGENND( M, N, AF, LDA ) ) 376 $ RESULT( 9 ) = 2*THRESH 377 NT = NT + 1 378 ELSE IF( M.GE.N ) THEN 379* 380* Test DORGQR, using factorization 381* returned by DQRT01 382* 383 CALL DQRT02( M, N, K, A, AF, AQ, AR, LDA, TAU, 384 $ WORK, LWORK, RWORK, RESULT( 1 ) ) 385 END IF 386 IF( M.GE.K ) THEN 387* 388* Test DORMQR, using factorization returned 389* by DQRT01 390* 391 CALL DQRT03( M, N, K, AF, AC, AR, AQ, LDA, TAU, 392 $ WORK, LWORK, RWORK, RESULT( 3 ) ) 393 NT = NT + 4 394* 395* If M>=N and K=N, call DGEQRS to solve a system 396* with NRHS right hand sides and compute the 397* residual. 398* 399 IF( K.EQ.N .AND. INB.EQ.1 ) THEN 400* 401* Generate a solution and set the right 402* hand side. 403* 404 SRNAMT = 'DLARHS' 405 CALL DLARHS( PATH, 'New', 'Full', 406 $ 'No transpose', M, N, 0, 0, 407 $ NRHS, A, LDA, XACT, LDA, B, LDA, 408 $ ISEED, INFO ) 409* 410 CALL DLACPY( 'Full', M, NRHS, B, LDA, X, 411 $ LDA ) 412 SRNAMT = 'DGEQRS' 413 CALL DGEQRS( M, N, NRHS, AF, LDA, TAU, X, 414 $ LDA, WORK, LWORK, INFO ) 415* 416* Check error code from DGEQRS. 417* 418 IF( INFO.NE.0 ) 419 $ CALL ALAERH( PATH, 'DGEQRS', INFO, 0, ' ', 420 $ M, N, NRHS, -1, NB, IMAT, 421 $ NFAIL, NERRS, NOUT ) 422* 423 CALL DGET02( 'No transpose', M, N, NRHS, A, 424 $ LDA, X, LDA, B, LDA, RWORK, 425 $ RESULT( 7 ) ) 426 NT = NT + 1 427 END IF 428 END IF 429* 430* Print information about the tests that did not 431* pass the threshold. 432* 433 DO 20 I = 1, NTESTS 434 IF( RESULT( I ).GE.THRESH ) THEN 435 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 436 $ CALL ALAHD( NOUT, PATH ) 437 WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX, 438 $ IMAT, I, RESULT( I ) 439 NFAIL = NFAIL + 1 440 END IF 441 20 CONTINUE 442 NRUN = NRUN + NT 443 30 CONTINUE 444 40 CONTINUE 445 50 CONTINUE 446 60 CONTINUE 447 70 CONTINUE 448* 449* Print a summary of the results. 450* 451 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 452* 453 9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=', 454 $ I5, ', type ', I2, ', test(', I2, ')=', G12.5 ) 455 RETURN 456* 457* End of DCHKQR 458* 459 END 460