![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SCHKQ3 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 SCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, 00012 * THRESH, A, COPYA, S, TAU, WORK, IWORK, 00013 * NOUT ) 00014 * 00015 * .. Scalar Arguments .. 00016 * INTEGER NM, NN, NNB, NOUT 00017 * REAL THRESH 00018 * .. 00019 * .. Array Arguments .. 00020 * LOGICAL DOTYPE( * ) 00021 * INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ), 00022 * $ NXVAL( * ) 00023 * REAL A( * ), COPYA( * ), S( * ), 00024 * $ TAU( * ), WORK( * ) 00025 * .. 00026 * 00027 * 00028 *> \par Purpose: 00029 * ============= 00030 *> 00031 *> \verbatim 00032 *> 00033 *> SCHKQ3 tests SGEQP3. 00034 *> \endverbatim 00035 * 00036 * Arguments: 00037 * ========== 00038 * 00039 *> \param[in] DOTYPE 00040 *> \verbatim 00041 *> DOTYPE is LOGICAL array, dimension (NTYPES) 00042 *> The matrix types to be used for testing. Matrices of type j 00043 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 00044 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 00045 *> \endverbatim 00046 *> 00047 *> \param[in] NM 00048 *> \verbatim 00049 *> NM is INTEGER 00050 *> The number of values of M contained in the vector MVAL. 00051 *> \endverbatim 00052 *> 00053 *> \param[in] MVAL 00054 *> \verbatim 00055 *> MVAL is INTEGER array, dimension (NM) 00056 *> The values of the matrix row dimension M. 00057 *> \endverbatim 00058 *> 00059 *> \param[in] NN 00060 *> \verbatim 00061 *> NN is INTEGER 00062 *> The number of values of N contained in the vector NVAL. 00063 *> \endverbatim 00064 *> 00065 *> \param[in] NVAL 00066 *> \verbatim 00067 *> NVAL is INTEGER array, dimension (NN) 00068 *> The values of the matrix column dimension N. 00069 *> \endverbatim 00070 *> 00071 *> \param[in] NNB 00072 *> \verbatim 00073 *> NNB is INTEGER 00074 *> The number of values of NB and NX contained in the 00075 *> vectors NBVAL and NXVAL. The blocking parameters are used 00076 *> in pairs (NB,NX). 00077 *> \endverbatim 00078 *> 00079 *> \param[in] NBVAL 00080 *> \verbatim 00081 *> NBVAL is INTEGER array, dimension (NNB) 00082 *> The values of the blocksize NB. 00083 *> \endverbatim 00084 *> 00085 *> \param[in] NXVAL 00086 *> \verbatim 00087 *> NXVAL is INTEGER array, dimension (NNB) 00088 *> The values of the crossover point NX. 00089 *> \endverbatim 00090 *> 00091 *> \param[in] THRESH 00092 *> \verbatim 00093 *> THRESH is REAL 00094 *> The threshold value for the test ratios. A result is 00095 *> included in the output file if RESULT >= THRESH. To have 00096 *> every test ratio printed, use THRESH = 0. 00097 *> \endverbatim 00098 *> 00099 *> \param[out] A 00100 *> \verbatim 00101 *> A is REAL array, dimension (MMAX*NMAX) 00102 *> where MMAX is the maximum value of M in MVAL and NMAX is the 00103 *> maximum value of N in NVAL. 00104 *> \endverbatim 00105 *> 00106 *> \param[out] COPYA 00107 *> \verbatim 00108 *> COPYA is REAL array, dimension (MMAX*NMAX) 00109 *> \endverbatim 00110 *> 00111 *> \param[out] S 00112 *> \verbatim 00113 *> S is REAL array, dimension 00114 *> (min(MMAX,NMAX)) 00115 *> \endverbatim 00116 *> 00117 *> \param[out] TAU 00118 *> \verbatim 00119 *> TAU is REAL array, dimension (MMAX) 00120 *> \endverbatim 00121 *> 00122 *> \param[out] WORK 00123 *> \verbatim 00124 *> WORK is REAL array, dimension 00125 *> (MMAX*NMAX + 4*NMAX + MMAX) 00126 *> \endverbatim 00127 *> 00128 *> \param[out] IWORK 00129 *> \verbatim 00130 *> IWORK is INTEGER array, dimension (2*NMAX) 00131 *> \endverbatim 00132 *> 00133 *> \param[in] NOUT 00134 *> \verbatim 00135 *> NOUT is INTEGER 00136 *> The unit number for output. 00137 *> \endverbatim 00138 * 00139 * Authors: 00140 * ======== 00141 * 00142 *> \author Univ. of Tennessee 00143 *> \author Univ. of California Berkeley 00144 *> \author Univ. of Colorado Denver 00145 *> \author NAG Ltd. 00146 * 00147 *> \date November 2011 00148 * 00149 *> \ingroup single_lin 00150 * 00151 * ===================================================================== 00152 SUBROUTINE SCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, 00153 $ THRESH, A, COPYA, S, TAU, WORK, IWORK, 00154 $ NOUT ) 00155 * 00156 * -- LAPACK test routine (version 3.4.0) -- 00157 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00158 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00159 * November 2011 00160 * 00161 * .. Scalar Arguments .. 00162 INTEGER NM, NN, NNB, NOUT 00163 REAL THRESH 00164 * .. 00165 * .. Array Arguments .. 00166 LOGICAL DOTYPE( * ) 00167 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ), 00168 $ NXVAL( * ) 00169 REAL A( * ), COPYA( * ), S( * ), 00170 $ TAU( * ), WORK( * ) 00171 * .. 00172 * 00173 * ===================================================================== 00174 * 00175 * .. Parameters .. 00176 INTEGER NTYPES 00177 PARAMETER ( NTYPES = 6 ) 00178 INTEGER NTESTS 00179 PARAMETER ( NTESTS = 3 ) 00180 REAL ONE, ZERO 00181 PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 ) 00182 * .. 00183 * .. Local Scalars .. 00184 CHARACTER*3 PATH 00185 INTEGER I, IHIGH, ILOW, IM, IMODE, IN, INB, INFO, 00186 $ ISTEP, K, LDA, LW, LWORK, M, MNMIN, MODE, N, 00187 $ NB, NERRS, NFAIL, NRUN, NX 00188 REAL EPS 00189 * .. 00190 * .. Local Arrays .. 00191 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00192 REAL RESULT( NTESTS ) 00193 * .. 00194 * .. External Functions .. 00195 REAL SLAMCH, SQPT01, SQRT11, SQRT12 00196 EXTERNAL SLAMCH, SQPT01, SQRT11, SQRT12 00197 * .. 00198 * .. External Subroutines .. 00199 EXTERNAL ALAHD, ALASUM, ICOPY, SGEQP3, SLACPY, SLAORD, 00200 $ SLASET, SLATMS, XLAENV 00201 * .. 00202 * .. Intrinsic Functions .. 00203 INTRINSIC MAX, MIN 00204 * .. 00205 * .. Scalars in Common .. 00206 LOGICAL LERR, OK 00207 CHARACTER*32 SRNAMT 00208 INTEGER INFOT, IOUNIT 00209 * .. 00210 * .. Common blocks .. 00211 COMMON / INFOC / INFOT, IOUNIT, OK, LERR 00212 COMMON / SRNAMC / SRNAMT 00213 * .. 00214 * .. Data statements .. 00215 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00216 * .. 00217 * .. Executable Statements .. 00218 * 00219 * Initialize constants and the random number seed. 00220 * 00221 PATH( 1: 1 ) = 'Single precision' 00222 PATH( 2: 3 ) = 'Q3' 00223 NRUN = 0 00224 NFAIL = 0 00225 NERRS = 0 00226 DO 10 I = 1, 4 00227 ISEED( I ) = ISEEDY( I ) 00228 10 CONTINUE 00229 EPS = SLAMCH( 'Epsilon' ) 00230 INFOT = 0 00231 * 00232 DO 90 IM = 1, NM 00233 * 00234 * Do for each value of M in MVAL. 00235 * 00236 M = MVAL( IM ) 00237 LDA = MAX( 1, M ) 00238 * 00239 DO 80 IN = 1, NN 00240 * 00241 * Do for each value of N in NVAL. 00242 * 00243 N = NVAL( IN ) 00244 MNMIN = MIN( M, N ) 00245 LWORK = MAX( 1, M*MAX( M, N )+4*MNMIN+MAX( M, N ), 00246 $ M*N + 2*MNMIN + 4*N ) 00247 * 00248 DO 70 IMODE = 1, NTYPES 00249 IF( .NOT.DOTYPE( IMODE ) ) 00250 $ GO TO 70 00251 * 00252 * Do for each type of matrix 00253 * 1: zero matrix 00254 * 2: one small singular value 00255 * 3: geometric distribution of singular values 00256 * 4: first n/2 columns fixed 00257 * 5: last n/2 columns fixed 00258 * 6: every second column fixed 00259 * 00260 MODE = IMODE 00261 IF( IMODE.GT.3 ) 00262 $ MODE = 1 00263 * 00264 * Generate test matrix of size m by n using 00265 * singular value distribution indicated by `mode'. 00266 * 00267 DO 20 I = 1, N 00268 IWORK( I ) = 0 00269 20 CONTINUE 00270 IF( IMODE.EQ.1 ) THEN 00271 CALL SLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA ) 00272 DO 30 I = 1, MNMIN 00273 S( I ) = ZERO 00274 30 CONTINUE 00275 ELSE 00276 CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', S, 00277 $ MODE, ONE / EPS, ONE, M, N, 'No packing', 00278 $ COPYA, LDA, WORK, INFO ) 00279 IF( IMODE.GE.4 ) THEN 00280 IF( IMODE.EQ.4 ) THEN 00281 ILOW = 1 00282 ISTEP = 1 00283 IHIGH = MAX( 1, N / 2 ) 00284 ELSE IF( IMODE.EQ.5 ) THEN 00285 ILOW = MAX( 1, N / 2 ) 00286 ISTEP = 1 00287 IHIGH = N 00288 ELSE IF( IMODE.EQ.6 ) THEN 00289 ILOW = 1 00290 ISTEP = 2 00291 IHIGH = N 00292 END IF 00293 DO 40 I = ILOW, IHIGH, ISTEP 00294 IWORK( I ) = 1 00295 40 CONTINUE 00296 END IF 00297 CALL SLAORD( 'Decreasing', MNMIN, S, 1 ) 00298 END IF 00299 * 00300 DO 60 INB = 1, NNB 00301 * 00302 * Do for each pair of values (NB,NX) in NBVAL and NXVAL. 00303 * 00304 NB = NBVAL( INB ) 00305 CALL XLAENV( 1, NB ) 00306 NX = NXVAL( INB ) 00307 CALL XLAENV( 3, NX ) 00308 * 00309 * Get a working copy of COPYA into A and a copy of 00310 * vector IWORK. 00311 * 00312 CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA ) 00313 CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 ) 00314 * 00315 * Compute the QR factorization with pivoting of A 00316 * 00317 LW = MAX( 1, 2*N+NB*( N+1 ) ) 00318 * 00319 * Compute the QP3 factorization of A 00320 * 00321 SRNAMT = 'SGEQP3' 00322 CALL SGEQP3( M, N, A, LDA, IWORK( N+1 ), TAU, WORK, 00323 $ LW, INFO ) 00324 * 00325 * Compute norm(svd(a) - svd(r)) 00326 * 00327 RESULT( 1 ) = SQRT12( M, N, A, LDA, S, WORK, 00328 $ LWORK ) 00329 * 00330 * Compute norm( A*P - Q*R ) 00331 * 00332 RESULT( 2 ) = SQPT01( M, N, MNMIN, COPYA, A, LDA, TAU, 00333 $ IWORK( N+1 ), WORK, LWORK ) 00334 * 00335 * Compute Q'*Q 00336 * 00337 RESULT( 3 ) = SQRT11( M, MNMIN, A, LDA, TAU, WORK, 00338 $ LWORK ) 00339 * 00340 * Print information about the tests that did not pass 00341 * the threshold. 00342 * 00343 DO 50 K = 1, NTESTS 00344 IF( RESULT( K ).GE.THRESH ) THEN 00345 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00346 $ CALL ALAHD( NOUT, PATH ) 00347 WRITE( NOUT, FMT = 9999 )'SGEQP3', M, N, NB, 00348 $ IMODE, K, RESULT( K ) 00349 NFAIL = NFAIL + 1 00350 END IF 00351 50 CONTINUE 00352 NRUN = NRUN + NTESTS 00353 * 00354 60 CONTINUE 00355 70 CONTINUE 00356 80 CONTINUE 00357 90 CONTINUE 00358 * 00359 * Print a summary of the results. 00360 * 00361 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00362 * 00363 9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, ', NB =', I4, ', type ', 00364 $ I2, ', test ', I2, ', ratio =', G12.5 ) 00365 * 00366 * End of SCHKQ3 00367 * 00368 END