|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE DCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, 00002 $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, 00003 $ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) 00004 * 00005 * -- LAPACK test routine (version 3.3.0) -- 00006 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00007 * November 2010 00008 * 00009 * .. Scalar Arguments .. 00010 LOGICAL TSTERR 00011 INTEGER NM, NMAX, NN, NNB, NOUT, NRHS 00012 DOUBLE PRECISION THRESH 00013 * .. 00014 * .. Array Arguments .. 00015 LOGICAL DOTYPE( * ) 00016 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ), 00017 $ NXVAL( * ) 00018 DOUBLE PRECISION A( * ), AC( * ), AF( * ), AQ( * ), AR( * ), 00019 $ B( * ), RWORK( * ), TAU( * ), WORK( * ), 00020 $ X( * ), XACT( * ) 00021 * .. 00022 * 00023 * Purpose 00024 * ======= 00025 * 00026 * DCHKQR tests DGEQRF, DORGQR and DORMQR. 00027 * 00028 * Arguments 00029 * ========= 00030 * 00031 * DOTYPE (input) LOGICAL array, dimension (NTYPES) 00032 * The matrix types to be used for testing. Matrices of type j 00033 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 00034 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 00035 * 00036 * NM (input) INTEGER 00037 * The number of values of M contained in the vector MVAL. 00038 * 00039 * MVAL (input) INTEGER array, dimension (NM) 00040 * The values of the matrix row dimension M. 00041 * 00042 * NN (input) INTEGER 00043 * The number of values of N contained in the vector NVAL. 00044 * 00045 * NVAL (input) INTEGER array, dimension (NN) 00046 * The values of the matrix column dimension N. 00047 * 00048 * NNB (input) INTEGER 00049 * The number of values of NB and NX contained in the 00050 * vectors NBVAL and NXVAL. The blocking parameters are used 00051 * in pairs (NB,NX). 00052 * 00053 * NBVAL (input) INTEGER array, dimension (NNB) 00054 * The values of the blocksize NB. 00055 * 00056 * NXVAL (input) INTEGER array, dimension (NNB) 00057 * The values of the crossover point NX. 00058 * 00059 * NRHS (input) INTEGER 00060 * The number of right hand side vectors to be generated for 00061 * each linear system. 00062 * 00063 * THRESH (input) DOUBLE PRECISION 00064 * The threshold value for the test ratios. A result is 00065 * included in the output file if RESULT >= THRESH. To have 00066 * every test ratio printed, use THRESH = 0. 00067 * 00068 * TSTERR (input) LOGICAL 00069 * Flag that indicates whether error exits are to be tested. 00070 * 00071 * NMAX (input) INTEGER 00072 * The maximum value permitted for M or N, used in dimensioning 00073 * the work arrays. 00074 * 00075 * A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) 00076 * 00077 * AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) 00078 * 00079 * AQ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) 00080 * 00081 * AR (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) 00082 * 00083 * AC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) 00084 * 00085 * B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) 00086 * 00087 * X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) 00088 * 00089 * XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) 00090 * 00091 * TAU (workspace) DOUBLE PRECISION array, dimension (NMAX) 00092 * 00093 * WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) 00094 * 00095 * RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) 00096 * 00097 * IWORK (workspace) INTEGER array, dimension (NMAX) 00098 * 00099 * NOUT (input) INTEGER 00100 * The unit number for output. 00101 * 00102 * ===================================================================== 00103 * 00104 * .. Parameters .. 00105 INTEGER NTESTS 00106 PARAMETER ( NTESTS = 9 ) 00107 INTEGER NTYPES 00108 PARAMETER ( NTYPES = 8 ) 00109 DOUBLE PRECISION ZERO 00110 PARAMETER ( ZERO = 0.0D0 ) 00111 * .. 00112 * .. Local Scalars .. 00113 CHARACTER DIST, TYPE 00114 CHARACTER*3 PATH 00115 INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA, 00116 $ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK, 00117 $ NRUN, NT, NX 00118 DOUBLE PRECISION ANORM, CNDNUM 00119 * .. 00120 * .. Local Arrays .. 00121 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 ) 00122 DOUBLE PRECISION RESULT( NTESTS ) 00123 * .. 00124 * .. External Functions .. 00125 LOGICAL DGENND 00126 EXTERNAL DGENND 00127 * .. 00128 * .. External Subroutines .. 00129 EXTERNAL ALAERH, ALAHD, ALASUM, DERRQR, DGEQRS, DGET02, 00130 $ DLACPY, DLARHS, DLATB4, DLATMS, DQRT01, 00131 $ DQRT01P, DQRT02, DQRT03, XLAENV 00132 * .. 00133 * .. Intrinsic Functions .. 00134 INTRINSIC MAX, MIN 00135 * .. 00136 * .. Scalars in Common .. 00137 LOGICAL LERR, OK 00138 CHARACTER*32 SRNAMT 00139 INTEGER INFOT, NUNIT 00140 * .. 00141 * .. Common blocks .. 00142 COMMON / INFOC / INFOT, NUNIT, OK, LERR 00143 COMMON / SRNAMC / SRNAMT 00144 * .. 00145 * .. Data statements .. 00146 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00147 * .. 00148 * .. Executable Statements .. 00149 * 00150 * Initialize constants and the random number seed. 00151 * 00152 PATH( 1: 1 ) = 'Double precision' 00153 PATH( 2: 3 ) = 'QR' 00154 NRUN = 0 00155 NFAIL = 0 00156 NERRS = 0 00157 DO 10 I = 1, 4 00158 ISEED( I ) = ISEEDY( I ) 00159 10 CONTINUE 00160 * 00161 * Test the error exits 00162 * 00163 IF( TSTERR ) 00164 $ CALL DERRQR( PATH, NOUT ) 00165 INFOT = 0 00166 CALL XLAENV( 2, 2 ) 00167 * 00168 LDA = NMAX 00169 LWORK = NMAX*MAX( NMAX, NRHS ) 00170 * 00171 * Do for each value of M in MVAL. 00172 * 00173 DO 70 IM = 1, NM 00174 M = MVAL( IM ) 00175 * 00176 * Do for each value of N in NVAL. 00177 * 00178 DO 60 IN = 1, NN 00179 N = NVAL( IN ) 00180 MINMN = MIN( M, N ) 00181 DO 50 IMAT = 1, NTYPES 00182 * 00183 * Do the tests only if DOTYPE( IMAT ) is true. 00184 * 00185 IF( .NOT.DOTYPE( IMAT ) ) 00186 $ GO TO 50 00187 * 00188 * Set up parameters with DLATB4 and generate a test matrix 00189 * with DLATMS. 00190 * 00191 CALL DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, 00192 $ CNDNUM, DIST ) 00193 * 00194 SRNAMT = 'DLATMS' 00195 CALL DLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE, 00196 $ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA, 00197 $ WORK, INFO ) 00198 * 00199 * Check error code from DLATMS. 00200 * 00201 IF( INFO.NE.0 ) THEN 00202 CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, N, -1, 00203 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 00204 GO TO 50 00205 END IF 00206 * 00207 * Set some values for K: the first value must be MINMN, 00208 * corresponding to the call of DQRT01; other values are 00209 * used in the calls of DQRT02, and must not exceed MINMN. 00210 * 00211 KVAL( 1 ) = MINMN 00212 KVAL( 2 ) = 0 00213 KVAL( 3 ) = 1 00214 KVAL( 4 ) = MINMN / 2 00215 IF( MINMN.EQ.0 ) THEN 00216 NK = 1 00217 ELSE IF( MINMN.EQ.1 ) THEN 00218 NK = 2 00219 ELSE IF( MINMN.LE.3 ) THEN 00220 NK = 3 00221 ELSE 00222 NK = 4 00223 END IF 00224 * 00225 * Do for each value of K in KVAL 00226 * 00227 DO 40 IK = 1, NK 00228 K = KVAL( IK ) 00229 * 00230 * Do for each pair of values (NB,NX) in NBVAL and NXVAL. 00231 * 00232 DO 30 INB = 1, NNB 00233 NB = NBVAL( INB ) 00234 CALL XLAENV( 1, NB ) 00235 NX = NXVAL( INB ) 00236 CALL XLAENV( 3, NX ) 00237 DO I = 1, NTESTS 00238 RESULT( I ) = ZERO 00239 END DO 00240 NT = 2 00241 IF( IK.EQ.1 ) THEN 00242 * 00243 * Test DGEQRF 00244 * 00245 CALL DQRT01( M, N, A, AF, AQ, AR, LDA, TAU, 00246 $ WORK, LWORK, RWORK, RESULT( 1 ) ) 00247 00248 * 00249 * Test DGEQRFP 00250 * 00251 CALL DQRT01P( M, N, A, AF, AQ, AR, LDA, TAU, 00252 $ WORK, LWORK, RWORK, RESULT( 8 ) ) 00253 00254 IF( .NOT. DGENND( M, N, AF, LDA ) ) 00255 $ RESULT( 9 ) = 2*THRESH 00256 NT = NT + 1 00257 ELSE IF( M.GE.N ) THEN 00258 * 00259 * Test DORGQR, using factorization 00260 * returned by DQRT01 00261 * 00262 CALL DQRT02( M, N, K, A, AF, AQ, AR, LDA, TAU, 00263 $ WORK, LWORK, RWORK, RESULT( 1 ) ) 00264 END IF 00265 IF( M.GE.K ) THEN 00266 * 00267 * Test DORMQR, using factorization returned 00268 * by DQRT01 00269 * 00270 CALL DQRT03( M, N, K, AF, AC, AR, AQ, LDA, TAU, 00271 $ WORK, LWORK, RWORK, RESULT( 3 ) ) 00272 NT = NT + 4 00273 * 00274 * If M>=N and K=N, call DGEQRS to solve a system 00275 * with NRHS right hand sides and compute the 00276 * residual. 00277 * 00278 IF( K.EQ.N .AND. INB.EQ.1 ) THEN 00279 * 00280 * Generate a solution and set the right 00281 * hand side. 00282 * 00283 SRNAMT = 'DLARHS' 00284 CALL DLARHS( PATH, 'New', 'Full', 00285 $ 'No transpose', M, N, 0, 0, 00286 $ NRHS, A, LDA, XACT, LDA, B, LDA, 00287 $ ISEED, INFO ) 00288 * 00289 CALL DLACPY( 'Full', M, NRHS, B, LDA, X, 00290 $ LDA ) 00291 SRNAMT = 'DGEQRS' 00292 CALL DGEQRS( M, N, NRHS, AF, LDA, TAU, X, 00293 $ LDA, WORK, LWORK, INFO ) 00294 * 00295 * Check error code from DGEQRS. 00296 * 00297 IF( INFO.NE.0 ) 00298 $ CALL ALAERH( PATH, 'DGEQRS', INFO, 0, ' ', 00299 $ M, N, NRHS, -1, NB, IMAT, 00300 $ NFAIL, NERRS, NOUT ) 00301 * 00302 CALL DGET02( 'No transpose', M, N, NRHS, A, 00303 $ LDA, X, LDA, B, LDA, RWORK, 00304 $ RESULT( 7 ) ) 00305 NT = NT + 1 00306 END IF 00307 END IF 00308 * 00309 * Print information about the tests that did not 00310 * pass the threshold. 00311 * 00312 DO 20 I = 1, NTESTS 00313 IF( RESULT( I ).GE.THRESH ) THEN 00314 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00315 $ CALL ALAHD( NOUT, PATH ) 00316 WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX, 00317 $ IMAT, I, RESULT( I ) 00318 NFAIL = NFAIL + 1 00319 END IF 00320 20 CONTINUE 00321 NRUN = NRUN + NT 00322 30 CONTINUE 00323 40 CONTINUE 00324 50 CONTINUE 00325 60 CONTINUE 00326 70 CONTINUE 00327 * 00328 * Print a summary of the results. 00329 * 00330 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00331 * 00332 9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=', 00333 $ I5, ', type ', I2, ', test(', I2, ')=', G12.5 ) 00334 RETURN 00335 * 00336 * End of DCHKQR 00337 * 00338 END
1.7.3 
