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