![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b DCHKQR 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 * Definition: 00009 * =========== 00010 * 00011 * SUBROUTINE DCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, 00012 * NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, 00013 * B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) 00014 * 00015 * .. Scalar Arguments .. 00016 * LOGICAL TSTERR 00017 * INTEGER NM, NMAX, NN, NNB, NOUT, NRHS 00018 * DOUBLE PRECISION THRESH 00019 * .. 00020 * .. Array Arguments .. 00021 * LOGICAL DOTYPE( * ) 00022 * INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ), 00023 * $ NXVAL( * ) 00024 * DOUBLE PRECISION A( * ), AC( * ), AF( * ), AQ( * ), AR( * ), 00025 * $ B( * ), RWORK( * ), TAU( * ), WORK( * ), 00026 * $ X( * ), XACT( * ) 00027 * .. 00028 * 00029 * 00030 *> \par Purpose: 00031 * ============= 00032 *> 00033 *> \verbatim 00034 *> 00035 *> DCHKQR tests DGEQRF, DORGQR and DORMQR. 00036 *> \endverbatim 00037 * 00038 * Arguments: 00039 * ========== 00040 * 00041 *> \param[in] DOTYPE 00042 *> \verbatim 00043 *> DOTYPE is LOGICAL array, dimension (NTYPES) 00044 *> The matrix types to be used for testing. Matrices of type j 00045 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 00046 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 00047 *> \endverbatim 00048 *> 00049 *> \param[in] NM 00050 *> \verbatim 00051 *> NM is INTEGER 00052 *> The number of values of M contained in the vector MVAL. 00053 *> \endverbatim 00054 *> 00055 *> \param[in] MVAL 00056 *> \verbatim 00057 *> MVAL is INTEGER array, dimension (NM) 00058 *> The values of the matrix row dimension M. 00059 *> \endverbatim 00060 *> 00061 *> \param[in] NN 00062 *> \verbatim 00063 *> NN is INTEGER 00064 *> The number of values of N contained in the vector NVAL. 00065 *> \endverbatim 00066 *> 00067 *> \param[in] NVAL 00068 *> \verbatim 00069 *> NVAL is INTEGER array, dimension (NN) 00070 *> The values of the matrix column dimension N. 00071 *> \endverbatim 00072 *> 00073 *> \param[in] NNB 00074 *> \verbatim 00075 *> NNB is INTEGER 00076 *> The number of values of NB and NX contained in the 00077 *> vectors NBVAL and NXVAL. The blocking parameters are used 00078 *> in pairs (NB,NX). 00079 *> \endverbatim 00080 *> 00081 *> \param[in] NBVAL 00082 *> \verbatim 00083 *> NBVAL is INTEGER array, dimension (NNB) 00084 *> The values of the blocksize NB. 00085 *> \endverbatim 00086 *> 00087 *> \param[in] NXVAL 00088 *> \verbatim 00089 *> NXVAL is INTEGER array, dimension (NNB) 00090 *> The values of the crossover point NX. 00091 *> \endverbatim 00092 *> 00093 *> \param[in] NRHS 00094 *> \verbatim 00095 *> NRHS is INTEGER 00096 *> The number of right hand side vectors to be generated for 00097 *> each linear system. 00098 *> \endverbatim 00099 *> 00100 *> \param[in] THRESH 00101 *> \verbatim 00102 *> THRESH is DOUBLE PRECISION 00103 *> The threshold value for the test ratios. A result is 00104 *> included in the output file if RESULT >= THRESH. To have 00105 *> every test ratio printed, use THRESH = 0. 00106 *> \endverbatim 00107 *> 00108 *> \param[in] TSTERR 00109 *> \verbatim 00110 *> TSTERR is LOGICAL 00111 *> Flag that indicates whether error exits are to be tested. 00112 *> \endverbatim 00113 *> 00114 *> \param[in] NMAX 00115 *> \verbatim 00116 *> NMAX is INTEGER 00117 *> The maximum value permitted for M or N, used in dimensioning 00118 *> the work arrays. 00119 *> \endverbatim 00120 *> 00121 *> \param[out] A 00122 *> \verbatim 00123 *> A is DOUBLE PRECISION array, dimension (NMAX*NMAX) 00124 *> \endverbatim 00125 *> 00126 *> \param[out] AF 00127 *> \verbatim 00128 *> AF is DOUBLE PRECISION array, dimension (NMAX*NMAX) 00129 *> \endverbatim 00130 *> 00131 *> \param[out] AQ 00132 *> \verbatim 00133 *> AQ is DOUBLE PRECISION array, dimension (NMAX*NMAX) 00134 *> \endverbatim 00135 *> 00136 *> \param[out] AR 00137 *> \verbatim 00138 *> AR is DOUBLE PRECISION array, dimension (NMAX*NMAX) 00139 *> \endverbatim 00140 *> 00141 *> \param[out] AC 00142 *> \verbatim 00143 *> AC is DOUBLE PRECISION array, dimension (NMAX*NMAX) 00144 *> \endverbatim 00145 *> 00146 *> \param[out] B 00147 *> \verbatim 00148 *> B is DOUBLE PRECISION array, dimension (NMAX*NRHS) 00149 *> \endverbatim 00150 *> 00151 *> \param[out] X 00152 *> \verbatim 00153 *> X is DOUBLE PRECISION array, dimension (NMAX*NRHS) 00154 *> \endverbatim 00155 *> 00156 *> \param[out] XACT 00157 *> \verbatim 00158 *> XACT is DOUBLE PRECISION array, dimension (NMAX*NRHS) 00159 *> \endverbatim 00160 *> 00161 *> \param[out] TAU 00162 *> \verbatim 00163 *> TAU is DOUBLE PRECISION array, dimension (NMAX) 00164 *> \endverbatim 00165 *> 00166 *> \param[out] WORK 00167 *> \verbatim 00168 *> WORK is DOUBLE PRECISION array, dimension (NMAX*NMAX) 00169 *> \endverbatim 00170 *> 00171 *> \param[out] RWORK 00172 *> \verbatim 00173 *> RWORK is DOUBLE PRECISION array, dimension (NMAX) 00174 *> \endverbatim 00175 *> 00176 *> \param[out] IWORK 00177 *> \verbatim 00178 *> IWORK is INTEGER array, dimension (NMAX) 00179 *> \endverbatim 00180 *> 00181 *> \param[in] NOUT 00182 *> \verbatim 00183 *> NOUT is INTEGER 00184 *> The unit number for output. 00185 *> \endverbatim 00186 * 00187 * Authors: 00188 * ======== 00189 * 00190 *> \author Univ. of Tennessee 00191 *> \author Univ. of California Berkeley 00192 *> \author Univ. of Colorado Denver 00193 *> \author NAG Ltd. 00194 * 00195 *> \date November 2011 00196 * 00197 *> \ingroup double_lin 00198 * 00199 * ===================================================================== 00200 SUBROUTINE DCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, 00201 $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, 00202 $ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) 00203 * 00204 * -- LAPACK test routine (version 3.4.0) -- 00205 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00206 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00207 * November 2011 00208 * 00209 * .. Scalar Arguments .. 00210 LOGICAL TSTERR 00211 INTEGER NM, NMAX, NN, NNB, NOUT, NRHS 00212 DOUBLE PRECISION THRESH 00213 * .. 00214 * .. Array Arguments .. 00215 LOGICAL DOTYPE( * ) 00216 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ), 00217 $ NXVAL( * ) 00218 DOUBLE PRECISION A( * ), AC( * ), AF( * ), AQ( * ), AR( * ), 00219 $ B( * ), RWORK( * ), TAU( * ), WORK( * ), 00220 $ X( * ), XACT( * ) 00221 * .. 00222 * 00223 * ===================================================================== 00224 * 00225 * .. Parameters .. 00226 INTEGER NTESTS 00227 PARAMETER ( NTESTS = 9 ) 00228 INTEGER NTYPES 00229 PARAMETER ( NTYPES = 8 ) 00230 DOUBLE PRECISION ZERO 00231 PARAMETER ( ZERO = 0.0D0 ) 00232 * .. 00233 * .. Local Scalars .. 00234 CHARACTER DIST, TYPE 00235 CHARACTER*3 PATH 00236 INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA, 00237 $ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK, 00238 $ NRUN, NT, NX 00239 DOUBLE PRECISION ANORM, CNDNUM 00240 * .. 00241 * .. Local Arrays .. 00242 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 ) 00243 DOUBLE PRECISION RESULT( NTESTS ) 00244 * .. 00245 * .. External Functions .. 00246 LOGICAL DGENND 00247 EXTERNAL DGENND 00248 * .. 00249 * .. External Subroutines .. 00250 EXTERNAL ALAERH, ALAHD, ALASUM, DERRQR, DGEQRS, DGET02, 00251 $ DLACPY, DLARHS, DLATB4, DLATMS, DQRT01, 00252 $ DQRT01P, DQRT02, DQRT03, XLAENV 00253 * .. 00254 * .. Intrinsic Functions .. 00255 INTRINSIC MAX, MIN 00256 * .. 00257 * .. Scalars in Common .. 00258 LOGICAL LERR, OK 00259 CHARACTER*32 SRNAMT 00260 INTEGER INFOT, NUNIT 00261 * .. 00262 * .. Common blocks .. 00263 COMMON / INFOC / INFOT, NUNIT, OK, LERR 00264 COMMON / SRNAMC / SRNAMT 00265 * .. 00266 * .. Data statements .. 00267 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00268 * .. 00269 * .. Executable Statements .. 00270 * 00271 * Initialize constants and the random number seed. 00272 * 00273 PATH( 1: 1 ) = 'Double precision' 00274 PATH( 2: 3 ) = 'QR' 00275 NRUN = 0 00276 NFAIL = 0 00277 NERRS = 0 00278 DO 10 I = 1, 4 00279 ISEED( I ) = ISEEDY( I ) 00280 10 CONTINUE 00281 * 00282 * Test the error exits 00283 * 00284 IF( TSTERR ) 00285 $ CALL DERRQR( PATH, NOUT ) 00286 INFOT = 0 00287 CALL XLAENV( 2, 2 ) 00288 * 00289 LDA = NMAX 00290 LWORK = NMAX*MAX( NMAX, NRHS ) 00291 * 00292 * Do for each value of M in MVAL. 00293 * 00294 DO 70 IM = 1, NM 00295 M = MVAL( IM ) 00296 * 00297 * Do for each value of N in NVAL. 00298 * 00299 DO 60 IN = 1, NN 00300 N = NVAL( IN ) 00301 MINMN = MIN( M, N ) 00302 DO 50 IMAT = 1, NTYPES 00303 * 00304 * Do the tests only if DOTYPE( IMAT ) is true. 00305 * 00306 IF( .NOT.DOTYPE( IMAT ) ) 00307 $ GO TO 50 00308 * 00309 * Set up parameters with DLATB4 and generate a test matrix 00310 * with DLATMS. 00311 * 00312 CALL DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, 00313 $ CNDNUM, DIST ) 00314 * 00315 SRNAMT = 'DLATMS' 00316 CALL DLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE, 00317 $ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA, 00318 $ WORK, INFO ) 00319 * 00320 * Check error code from DLATMS. 00321 * 00322 IF( INFO.NE.0 ) THEN 00323 CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, N, -1, 00324 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 00325 GO TO 50 00326 END IF 00327 * 00328 * Set some values for K: the first value must be MINMN, 00329 * corresponding to the call of DQRT01; other values are 00330 * used in the calls of DQRT02, and must not exceed MINMN. 00331 * 00332 KVAL( 1 ) = MINMN 00333 KVAL( 2 ) = 0 00334 KVAL( 3 ) = 1 00335 KVAL( 4 ) = MINMN / 2 00336 IF( MINMN.EQ.0 ) THEN 00337 NK = 1 00338 ELSE IF( MINMN.EQ.1 ) THEN 00339 NK = 2 00340 ELSE IF( MINMN.LE.3 ) THEN 00341 NK = 3 00342 ELSE 00343 NK = 4 00344 END IF 00345 * 00346 * Do for each value of K in KVAL 00347 * 00348 DO 40 IK = 1, NK 00349 K = KVAL( IK ) 00350 * 00351 * Do for each pair of values (NB,NX) in NBVAL and NXVAL. 00352 * 00353 DO 30 INB = 1, NNB 00354 NB = NBVAL( INB ) 00355 CALL XLAENV( 1, NB ) 00356 NX = NXVAL( INB ) 00357 CALL XLAENV( 3, NX ) 00358 DO I = 1, NTESTS 00359 RESULT( I ) = ZERO 00360 END DO 00361 NT = 2 00362 IF( IK.EQ.1 ) THEN 00363 * 00364 * Test DGEQRF 00365 * 00366 CALL DQRT01( M, N, A, AF, AQ, AR, LDA, TAU, 00367 $ WORK, LWORK, RWORK, RESULT( 1 ) ) 00368 00369 * 00370 * Test DGEQRFP 00371 * 00372 CALL DQRT01P( M, N, A, AF, AQ, AR, LDA, TAU, 00373 $ WORK, LWORK, RWORK, RESULT( 8 ) ) 00374 00375 IF( .NOT. DGENND( M, N, AF, LDA ) ) 00376 $ RESULT( 9 ) = 2*THRESH 00377 NT = NT + 1 00378 ELSE IF( M.GE.N ) THEN 00379 * 00380 * Test DORGQR, using factorization 00381 * returned by DQRT01 00382 * 00383 CALL DQRT02( M, N, K, A, AF, AQ, AR, LDA, TAU, 00384 $ WORK, LWORK, RWORK, RESULT( 1 ) ) 00385 END IF 00386 IF( M.GE.K ) THEN 00387 * 00388 * Test DORMQR, using factorization returned 00389 * by DQRT01 00390 * 00391 CALL DQRT03( M, N, K, AF, AC, AR, AQ, LDA, TAU, 00392 $ WORK, LWORK, RWORK, RESULT( 3 ) ) 00393 NT = NT + 4 00394 * 00395 * If M>=N and K=N, call DGEQRS to solve a system 00396 * with NRHS right hand sides and compute the 00397 * residual. 00398 * 00399 IF( K.EQ.N .AND. INB.EQ.1 ) THEN 00400 * 00401 * Generate a solution and set the right 00402 * hand side. 00403 * 00404 SRNAMT = 'DLARHS' 00405 CALL DLARHS( PATH, 'New', 'Full', 00406 $ 'No transpose', M, N, 0, 0, 00407 $ NRHS, A, LDA, XACT, LDA, B, LDA, 00408 $ ISEED, INFO ) 00409 * 00410 CALL DLACPY( 'Full', M, NRHS, B, LDA, X, 00411 $ LDA ) 00412 SRNAMT = 'DGEQRS' 00413 CALL DGEQRS( M, N, NRHS, AF, LDA, TAU, X, 00414 $ LDA, WORK, LWORK, INFO ) 00415 * 00416 * Check error code from DGEQRS. 00417 * 00418 IF( INFO.NE.0 ) 00419 $ CALL ALAERH( PATH, 'DGEQRS', INFO, 0, ' ', 00420 $ M, N, NRHS, -1, NB, IMAT, 00421 $ NFAIL, NERRS, NOUT ) 00422 * 00423 CALL DGET02( 'No transpose', M, N, NRHS, A, 00424 $ LDA, X, LDA, B, LDA, RWORK, 00425 $ RESULT( 7 ) ) 00426 NT = NT + 1 00427 END IF 00428 END IF 00429 * 00430 * Print information about the tests that did not 00431 * pass the threshold. 00432 * 00433 DO 20 I = 1, NTESTS 00434 IF( RESULT( I ).GE.THRESH ) THEN 00435 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00436 $ CALL ALAHD( NOUT, PATH ) 00437 WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX, 00438 $ IMAT, I, RESULT( I ) 00439 NFAIL = NFAIL + 1 00440 END IF 00441 20 CONTINUE 00442 NRUN = NRUN + NT 00443 30 CONTINUE 00444 40 CONTINUE 00445 50 CONTINUE 00446 60 CONTINUE 00447 70 CONTINUE 00448 * 00449 * Print a summary of the results. 00450 * 00451 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00452 * 00453 9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=', 00454 $ I5, ', type ', I2, ', test(', I2, ')=', G12.5 ) 00455 RETURN 00456 * 00457 * End of DCHKQR 00458 * 00459 END