 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 SUBROUTINE DCHKRQ( 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.1) -- 00006 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00007 * June 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 * DCHKRQ tests DGERQF, DORGRQ and DORMRQ. 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 = 7 ) 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 Subroutines .. 00125 EXTERNAL ALAERH, ALAHD, ALASUM, DERRRQ, DGERQS, DGET02, 00126 $ DLACPY, DLARHS, DLATB4, DLATMS, DRQT01, DRQT02, 00127 $ DRQT03, XLAENV 00128 * .. 00129 * .. Intrinsic Functions .. 00130 INTRINSIC MAX, MIN 00131 * .. 00132 * .. Scalars in Common .. 00133 LOGICAL LERR, OK 00134 CHARACTER*32 SRNAMT 00135 INTEGER INFOT, NUNIT 00136 * .. 00137 * .. Common blocks .. 00138 COMMON / INFOC / INFOT, NUNIT, OK, LERR 00139 COMMON / SRNAMC / SRNAMT 00140 * .. 00141 * .. Data statements .. 00142 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00143 * .. 00144 * .. Executable Statements .. 00145 * 00146 * Initialize constants and the random number seed. 00147 * 00148 PATH( 1: 1 ) = 'Double precision' 00149 PATH( 2: 3 ) = 'RQ' 00150 NRUN = 0 00151 NFAIL = 0 00152 NERRS = 0 00153 DO 10 I = 1, 4 00154 ISEED( I ) = ISEEDY( I ) 00155 10 CONTINUE 00156 * 00157 * Test the error exits 00158 * 00159 IF( TSTERR ) 00160 $ CALL DERRRQ( PATH, NOUT ) 00161 INFOT = 0 00162 CALL XLAENV( 2, 2 ) 00163 * 00164 LDA = NMAX 00165 LWORK = NMAX*MAX( NMAX, NRHS ) 00166 * 00167 * Do for each value of M in MVAL. 00168 * 00169 DO 70 IM = 1, NM 00170 M = MVAL( IM ) 00171 * 00172 * Do for each value of N in NVAL. 00173 * 00174 DO 60 IN = 1, NN 00175 N = NVAL( IN ) 00176 MINMN = MIN( M, N ) 00177 DO 50 IMAT = 1, NTYPES 00178 * 00179 * Do the tests only if DOTYPE( IMAT ) is true. 00180 * 00181 IF( .NOT.DOTYPE( IMAT ) ) 00182 $ GO TO 50 00183 * 00184 * Set up parameters with DLATB4 and generate a test matrix 00185 * with DLATMS. 00186 * 00187 CALL DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, 00188 $ CNDNUM, DIST ) 00189 * 00190 SRNAMT = 'DLATMS' 00191 CALL DLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE, 00192 $ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA, 00193 $ WORK, INFO ) 00194 * 00195 * Check error code from DLATMS. 00196 * 00197 IF( INFO.NE.0 ) THEN 00198 CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, N, -1, 00199 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 00200 GO TO 50 00201 END IF 00202 * 00203 * Set some values for K: the first value must be MINMN, 00204 * corresponding to the call of DRQT01; other values are 00205 * used in the calls of DRQT02, and must not exceed MINMN. 00206 * 00207 KVAL( 1 ) = MINMN 00208 KVAL( 2 ) = 0 00209 KVAL( 3 ) = 1 00210 KVAL( 4 ) = MINMN / 2 00211 IF( MINMN.EQ.0 ) THEN 00212 NK = 1 00213 ELSE IF( MINMN.EQ.1 ) THEN 00214 NK = 2 00215 ELSE IF( MINMN.LE.3 ) THEN 00216 NK = 3 00217 ELSE 00218 NK = 4 00219 END IF 00220 * 00221 * Do for each value of K in KVAL 00222 * 00223 DO 40 IK = 1, NK 00224 K = KVAL( IK ) 00225 * 00226 * Do for each pair of values (NB,NX) in NBVAL and NXVAL. 00227 * 00228 DO 30 INB = 1, NNB 00229 NB = NBVAL( INB ) 00230 CALL XLAENV( 1, NB ) 00231 NX = NXVAL( INB ) 00232 CALL XLAENV( 3, NX ) 00233 DO I = 1, NTESTS 00234 RESULT( I ) = ZERO 00235 END DO 00236 NT = 2 00237 IF( IK.EQ.1 ) THEN 00238 * 00239 * Test DGERQF 00240 * 00241 CALL DRQT01( M, N, A, AF, AQ, AR, LDA, TAU, 00242 $ WORK, LWORK, RWORK, RESULT( 1 ) ) 00243 ELSE IF( M.LE.N ) THEN 00244 * 00245 * Test DORGRQ, using factorization 00246 * returned by DRQT01 00247 * 00248 CALL DRQT02( M, N, K, A, AF, AQ, AR, LDA, TAU, 00249 $ WORK, LWORK, RWORK, RESULT( 1 ) ) 00250 00251 END IF 00252 IF( M.GE.K ) THEN 00253 * 00254 * Test DORMRQ, using factorization returned 00255 * by DRQT01 00256 * 00257 CALL DRQT03( M, N, K, AF, AC, AR, AQ, LDA, TAU, 00258 $ WORK, LWORK, RWORK, RESULT( 3 ) ) 00259 NT = NT + 4 00260 * 00261 * If M>=N and K=N, call DGERQS to solve a system 00262 * with NRHS right hand sides and compute the 00263 * residual. 00264 * 00265 IF( K.EQ.M .AND. INB.EQ.1 ) THEN 00266 * 00267 * Generate a solution and set the right 00268 * hand side. 00269 * 00270 SRNAMT = 'DLARHS' 00271 CALL DLARHS( PATH, 'New', 'Full', 00272 $ 'No transpose', M, N, 0, 0, 00273 $ NRHS, A, LDA, XACT, LDA, B, LDA, 00274 $ ISEED, INFO ) 00275 * 00276 CALL DLACPY( 'Full', M, NRHS, B, LDA, 00277 $ X( N-M+1 ), LDA ) 00278 SRNAMT = 'DGERQS' 00279 CALL DGERQS( M, N, NRHS, AF, LDA, TAU, X, 00280 $ LDA, WORK, LWORK, INFO ) 00281 * 00282 * Check error code from DGERQS. 00283 * 00284 IF( INFO.NE.0 ) 00285 $ CALL ALAERH( PATH, 'DGERQS', INFO, 0, ' ', 00286 $ M, N, NRHS, -1, NB, IMAT, 00287 $ NFAIL, NERRS, NOUT ) 00288 * 00289 CALL DGET02( 'No transpose', M, N, NRHS, A, 00290 $ LDA, X, LDA, B, LDA, RWORK, 00291 $ RESULT( 7 ) ) 00292 NT = NT + 1 00293 END IF 00294 END IF 00295 * 00296 * Print information about the tests that did not 00297 * pass the threshold. 00298 * 00299 DO 20 I = 1, NT 00300 IF( RESULT( I ).GE.THRESH ) THEN 00301 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00302 $ CALL ALAHD( NOUT, PATH ) 00303 WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX, 00304 $ IMAT, I, RESULT( I ) 00305 NFAIL = NFAIL + 1 00306 END IF 00307 20 CONTINUE 00308 NRUN = NRUN + NT 00309 30 CONTINUE 00310 40 CONTINUE 00311 50 CONTINUE 00312 60 CONTINUE 00313 70 CONTINUE 00314 * 00315 * Print a summary of the results. 00316 * 00317 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00318 * 00319 9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=', 00320 $ I5, ', type ', I2, ', test(', I2, ')=', G12.5 ) 00321 RETURN 00322 * 00323 * End of DCHKRQ 00324 * 00325 END
1.7.3 
