|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE SCHKQR( 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 REAL THRESH 00013 * .. 00014 * .. Array Arguments .. 00015 LOGICAL DOTYPE( * ) 00016 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ), 00017 $ NXVAL( * ) 00018 REAL A( * ), AC( * ), AF( * ), AQ( * ), AR( * ), 00019 $ B( * ), RWORK( * ), TAU( * ), WORK( * ), 00020 $ X( * ), XACT( * ) 00021 * .. 00022 * 00023 * Purpose 00024 * ======= 00025 * 00026 * SCHKQR tests SGEQRF, SORGQR and SORMQR. 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) REAL 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) REAL array, dimension (NMAX*NMAX) 00076 * 00077 * AF (workspace) REAL array, dimension (NMAX*NMAX) 00078 * 00079 * AQ (workspace) REAL array, dimension (NMAX*NMAX) 00080 * 00081 * AR (workspace) REAL array, dimension (NMAX*NMAX) 00082 * 00083 * AC (workspace) REAL array, dimension (NMAX*NMAX) 00084 * 00085 * B (workspace) REAL array, dimension (NMAX*NRHS) 00086 * 00087 * X (workspace) REAL array, dimension (NMAX*NRHS) 00088 * 00089 * XACT (workspace) REAL array, dimension (NMAX*NRHS) 00090 * 00091 * TAU (workspace) REAL array, dimension (NMAX) 00092 * 00093 * WORK (workspace) REAL array, dimension (NMAX*NMAX) 00094 * 00095 * RWORK (workspace) REAL 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 REAL ZERO 00110 PARAMETER ( ZERO = 0.0E0 ) 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 REAL ANORM, CNDNUM 00119 * .. 00120 * .. Local Arrays .. 00121 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 ) 00122 REAL RESULT( NTESTS ) 00123 * .. 00124 * .. External Functions .. 00125 LOGICAL SGENND 00126 EXTERNAL SGENND 00127 * .. 00128 * .. External Subroutines .. 00129 EXTERNAL ALAERH, ALAHD, ALASUM, SERRQR, SGEQRS, SGET02, 00130 $ SLACPY, SLARHS, SLATB4, SLATMS, SQRT01, 00131 $ SQRT01P, SQRT02, SQRT03, 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 ) = 'Single 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 SERRQR( 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 SLATB4 and generate a test matrix 00189 * with SLATMS. 00190 * 00191 CALL SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, 00192 $ CNDNUM, DIST ) 00193 * 00194 SRNAMT = 'SLATMS' 00195 CALL SLATMS( 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 SLATMS. 00200 * 00201 IF( INFO.NE.0 ) THEN 00202 CALL ALAERH( PATH, 'SLATMS', 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 SQRT01; other values are 00209 * used in the calls of SQRT02, 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 SGEQRF 00244 * 00245 CALL SQRT01( M, N, A, AF, AQ, AR, LDA, TAU, 00246 $ WORK, LWORK, RWORK, RESULT( 1 ) ) 00247 * 00248 * Test SGEQRFP 00249 * 00250 CALL SQRT01P( M, N, A, AF, AQ, AR, LDA, TAU, 00251 $ WORK, LWORK, RWORK, RESULT( 8 ) ) 00252 00253 IF( .NOT. SGENND( M, N, AF, LDA ) ) 00254 $ RESULT( 9 ) = 2*THRESH 00255 NT = NT + 1 00256 ELSE IF( M.GE.N ) THEN 00257 * 00258 * Test SORGQR, using factorization 00259 * returned by SQRT01 00260 * 00261 CALL SQRT02( M, N, K, A, AF, AQ, AR, LDA, TAU, 00262 $ WORK, LWORK, RWORK, RESULT( 1 ) ) 00263 END IF 00264 IF( M.GE.K ) THEN 00265 * 00266 * Test SORMQR, using factorization returned 00267 * by SQRT01 00268 * 00269 CALL SQRT03( M, N, K, AF, AC, AR, AQ, LDA, TAU, 00270 $ WORK, LWORK, RWORK, RESULT( 3 ) ) 00271 NT = NT + 4 00272 * 00273 * If M>=N and K=N, call SGEQRS to solve a system 00274 * with NRHS right hand sides and compute the 00275 * residual. 00276 * 00277 IF( K.EQ.N .AND. INB.EQ.1 ) THEN 00278 * 00279 * Generate a solution and set the right 00280 * hand side. 00281 * 00282 SRNAMT = 'SLARHS' 00283 CALL SLARHS( PATH, 'New', 'Full', 00284 $ 'No transpose', M, N, 0, 0, 00285 $ NRHS, A, LDA, XACT, LDA, B, LDA, 00286 $ ISEED, INFO ) 00287 * 00288 CALL SLACPY( 'Full', M, NRHS, B, LDA, X, 00289 $ LDA ) 00290 SRNAMT = 'SGEQRS' 00291 CALL SGEQRS( M, N, NRHS, AF, LDA, TAU, X, 00292 $ LDA, WORK, LWORK, INFO ) 00293 * 00294 * Check error code from SGEQRS. 00295 * 00296 IF( INFO.NE.0 ) 00297 $ CALL ALAERH( PATH, 'SGEQRS', INFO, 0, ' ', 00298 $ M, N, NRHS, -1, NB, IMAT, 00299 $ NFAIL, NERRS, NOUT ) 00300 * 00301 CALL SGET02( 'No transpose', M, N, NRHS, A, 00302 $ LDA, X, LDA, B, LDA, RWORK, 00303 $ RESULT( 7 ) ) 00304 NT = NT + 1 00305 END IF 00306 END IF 00307 * 00308 * Print information about the tests that did not 00309 * pass the threshold. 00310 * 00311 DO 20 I = 1, NTESTS 00312 IF( RESULT( I ).GE.THRESH ) THEN 00313 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00314 $ CALL ALAHD( NOUT, PATH ) 00315 WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX, 00316 $ IMAT, I, RESULT( I ) 00317 NFAIL = NFAIL + 1 00318 END IF 00319 20 CONTINUE 00320 NRUN = NRUN + NT 00321 30 CONTINUE 00322 40 CONTINUE 00323 50 CONTINUE 00324 60 CONTINUE 00325 70 CONTINUE 00326 * 00327 * Print a summary of the results. 00328 * 00329 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00330 * 00331 9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=', 00332 $ I5, ', type ', I2, ', test(', I2, ')=', G12.5 ) 00333 RETURN 00334 * 00335 * End of SCHKQR 00336 * 00337 END
1.7.3 
