 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 SUBROUTINE SCHKRQ( 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 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 * SCHKRQ tests SGERQF, SORGRQ and SORMRQ. 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 = 7 ) 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 Subroutines .. 00125 EXTERNAL ALAERH, ALAHD, ALASUM, SERRRQ, SGERQS, SGET02, 00126 $ SLACPY, SLARHS, SLATB4, SLATMS, SRQT01, SRQT02, 00127 $ SRQT03, 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 ) = 'Single 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 SERRRQ( 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 SLATB4 and generate a test matrix 00185 * with SLATMS. 00186 * 00187 CALL SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, 00188 $ CNDNUM, DIST ) 00189 * 00190 SRNAMT = 'SLATMS' 00191 CALL SLATMS( 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 SLATMS. 00196 * 00197 IF( INFO.NE.0 ) THEN 00198 CALL ALAERH( PATH, 'SLATMS', 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 SRQT01; other values are 00205 * used in the calls of SRQT02, 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 SGERQF 00240 * 00241 CALL SRQT01( M, N, A, AF, AQ, AR, LDA, TAU, 00242 $ WORK, LWORK, RWORK, RESULT( 1 ) ) 00243 ELSE IF( M.LE.N ) THEN 00244 * 00245 * Test SORGRQ, using factorization 00246 * returned by SRQT01 00247 * 00248 CALL SRQT02( M, N, K, A, AF, AQ, AR, LDA, TAU, 00249 $ WORK, LWORK, RWORK, RESULT( 1 ) ) 00250 END IF 00251 IF( M.GE.K ) THEN 00252 * 00253 * Test SORMRQ, using factorization returned 00254 * by SRQT01 00255 * 00256 CALL SRQT03( M, N, K, AF, AC, AR, AQ, LDA, TAU, 00257 $ WORK, LWORK, RWORK, RESULT( 3 ) ) 00258 NT = NT + 4 00259 * 00260 * If M>=N and K=N, call SGERQS to solve a system 00261 * with NRHS right hand sides and compute the 00262 * residual. 00263 * 00264 IF( K.EQ.M .AND. INB.EQ.1 ) THEN 00265 * 00266 * Generate a solution and set the right 00267 * hand side. 00268 * 00269 SRNAMT = 'SLARHS' 00270 CALL SLARHS( PATH, 'New', 'Full', 00271 $ 'No transpose', M, N, 0, 0, 00272 $ NRHS, A, LDA, XACT, LDA, B, LDA, 00273 $ ISEED, INFO ) 00274 * 00275 CALL SLACPY( 'Full', M, NRHS, B, LDA, 00276 $ X( N-M+1 ), LDA ) 00277 SRNAMT = 'SGERQS' 00278 CALL SGERQS( M, N, NRHS, AF, LDA, TAU, X, 00279 $ LDA, WORK, LWORK, INFO ) 00280 * 00281 * Check error code from SGERQS. 00282 * 00283 IF( INFO.NE.0 ) 00284 $ CALL ALAERH( PATH, 'SGERQS', INFO, 0, ' ', 00285 $ M, N, NRHS, -1, NB, IMAT, 00286 $ NFAIL, NERRS, NOUT ) 00287 * 00288 CALL SGET02( 'No transpose', M, N, NRHS, A, 00289 $ LDA, X, LDA, B, LDA, RWORK, 00290 $ RESULT( 7 ) ) 00291 NT = NT + 1 00292 END IF 00293 END IF 00294 * 00295 * Print information about the tests that did not 00296 * pass the threshold. 00297 * 00298 DO 20 I = 1, NTESTS 00299 IF( RESULT( I ).GE.THRESH ) THEN 00300 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00301 $ CALL ALAHD( NOUT, PATH ) 00302 WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX, 00303 $ IMAT, I, RESULT( I ) 00304 NFAIL = NFAIL + 1 00305 END IF 00306 20 CONTINUE 00307 NRUN = NRUN + NT 00308 30 CONTINUE 00309 40 CONTINUE 00310 50 CONTINUE 00311 60 CONTINUE 00312 70 CONTINUE 00313 * 00314 * Print a summary of the results. 00315 * 00316 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00317 * 00318 9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=', 00319 $ I5, ', type ', I2, ', test(', I2, ')=', G12.5 ) 00320 RETURN 00321 * 00322 * End of SCHKRQ 00323 * 00324 END
1.7.3 
