![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SCHKTZ 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 SCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, 00012 * COPYA, S, TAU, WORK, 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 MVAL( * ), NVAL( * ) 00022 * REAL A( * ), COPYA( * ), S( * ), 00023 * $ TAU( * ), WORK( * ) 00024 * .. 00025 * 00026 * 00027 *> \par Purpose: 00028 * ============= 00029 *> 00030 *> \verbatim 00031 *> 00032 *> SCHKTZ tests STZRQF and STZRZF. 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[in] NOUT 00114 *> \verbatim 00115 *> NOUT is INTEGER 00116 *> The unit number for output. 00117 *> \endverbatim 00118 * 00119 * Authors: 00120 * ======== 00121 * 00122 *> \author Univ. of Tennessee 00123 *> \author Univ. of California Berkeley 00124 *> \author Univ. of Colorado Denver 00125 *> \author NAG Ltd. 00126 * 00127 *> \date November 2011 00128 * 00129 *> \ingroup single_lin 00130 * 00131 * ===================================================================== 00132 SUBROUTINE SCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, 00133 $ COPYA, S, TAU, WORK, NOUT ) 00134 * 00135 * -- LAPACK test routine (version 3.4.0) -- 00136 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00137 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00138 * November 2011 00139 * 00140 * .. Scalar Arguments .. 00141 LOGICAL TSTERR 00142 INTEGER NM, NN, NOUT 00143 REAL THRESH 00144 * .. 00145 * .. Array Arguments .. 00146 LOGICAL DOTYPE( * ) 00147 INTEGER MVAL( * ), NVAL( * ) 00148 REAL A( * ), COPYA( * ), S( * ), 00149 $ TAU( * ), WORK( * ) 00150 * .. 00151 * 00152 * ===================================================================== 00153 * 00154 * .. Parameters .. 00155 INTEGER NTYPES 00156 PARAMETER ( NTYPES = 3 ) 00157 INTEGER NTESTS 00158 PARAMETER ( NTESTS = 6 ) 00159 REAL ONE, ZERO 00160 PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 ) 00161 * .. 00162 * .. Local Scalars .. 00163 CHARACTER*3 PATH 00164 INTEGER I, IM, IMODE, IN, INFO, K, LDA, LWORK, M, 00165 $ MNMIN, MODE, N, NERRS, NFAIL, NRUN 00166 REAL EPS 00167 * .. 00168 * .. Local Arrays .. 00169 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00170 REAL RESULT( NTESTS ) 00171 * .. 00172 * .. External Functions .. 00173 REAL SLAMCH, SQRT12, SRZT01, SRZT02, STZT01, STZT02 00174 EXTERNAL SLAMCH, SQRT12, SRZT01, SRZT02, STZT01, STZT02 00175 * .. 00176 * .. External Subroutines .. 00177 EXTERNAL ALAHD, ALASUM, SERRTZ, SGEQR2, SLACPY, SLAORD, 00178 $ SLASET, SLATMS, STZRQF, STZRZF 00179 * .. 00180 * .. Intrinsic Functions .. 00181 INTRINSIC MAX, MIN 00182 * .. 00183 * .. Scalars in Common .. 00184 LOGICAL LERR, OK 00185 CHARACTER*32 SRNAMT 00186 INTEGER INFOT, IOUNIT 00187 * .. 00188 * .. Common blocks .. 00189 COMMON / INFOC / INFOT, IOUNIT, OK, LERR 00190 COMMON / SRNAMC / SRNAMT 00191 * .. 00192 * .. Data statements .. 00193 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00194 * .. 00195 * .. Executable Statements .. 00196 * 00197 * Initialize constants and the random number seed. 00198 * 00199 PATH( 1: 1 ) = 'Single precision' 00200 PATH( 2: 3 ) = 'TZ' 00201 NRUN = 0 00202 NFAIL = 0 00203 NERRS = 0 00204 DO 10 I = 1, 4 00205 ISEED( I ) = ISEEDY( I ) 00206 10 CONTINUE 00207 EPS = SLAMCH( 'Epsilon' ) 00208 * 00209 * Test the error exits 00210 * 00211 IF( TSTERR ) 00212 $ CALL SERRTZ( PATH, NOUT ) 00213 INFOT = 0 00214 * 00215 DO 70 IM = 1, NM 00216 * 00217 * Do for each value of M in MVAL. 00218 * 00219 M = MVAL( IM ) 00220 LDA = MAX( 1, M ) 00221 * 00222 DO 60 IN = 1, NN 00223 * 00224 * Do for each value of N in NVAL for which M .LE. N. 00225 * 00226 N = NVAL( IN ) 00227 MNMIN = MIN( M, N ) 00228 LWORK = MAX( 1, N*N+4*M+N, M*N+2*MNMIN+4*N ) 00229 * 00230 IF( M.LE.N ) THEN 00231 DO 50 IMODE = 1, NTYPES 00232 IF( .NOT.DOTYPE( IMODE ) ) 00233 $ GO TO 50 00234 * 00235 * Do for each type of singular value distribution. 00236 * 0: zero matrix 00237 * 1: one small singular value 00238 * 2: exponential distribution 00239 * 00240 MODE = IMODE - 1 00241 * 00242 * Test STZRQF 00243 * 00244 * Generate test matrix of size m by n using 00245 * singular value distribution indicated by `mode'. 00246 * 00247 IF( MODE.EQ.0 ) THEN 00248 CALL SLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) 00249 DO 20 I = 1, MNMIN 00250 S( I ) = ZERO 00251 20 CONTINUE 00252 ELSE 00253 CALL SLATMS( M, N, 'Uniform', ISEED, 00254 $ 'Nonsymmetric', S, IMODE, 00255 $ ONE / EPS, ONE, M, N, 'No packing', A, 00256 $ LDA, WORK, INFO ) 00257 CALL SGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ), 00258 $ INFO ) 00259 CALL SLASET( 'Lower', M-1, N, ZERO, ZERO, A( 2 ), 00260 $ LDA ) 00261 CALL SLAORD( 'Decreasing', MNMIN, S, 1 ) 00262 END IF 00263 * 00264 * Save A and its singular values 00265 * 00266 CALL SLACPY( 'All', M, N, A, LDA, COPYA, LDA ) 00267 * 00268 * Call STZRQF to reduce the upper trapezoidal matrix to 00269 * upper triangular form. 00270 * 00271 SRNAMT = 'STZRQF' 00272 CALL STZRQF( M, N, A, LDA, TAU, INFO ) 00273 * 00274 * Compute norm(svd(a) - svd(r)) 00275 * 00276 RESULT( 1 ) = SQRT12( M, M, A, LDA, S, WORK, 00277 $ LWORK ) 00278 * 00279 * Compute norm( A - R*Q ) 00280 * 00281 RESULT( 2 ) = STZT01( M, N, COPYA, A, LDA, TAU, WORK, 00282 $ LWORK ) 00283 * 00284 * Compute norm(Q'*Q - I). 00285 * 00286 RESULT( 3 ) = STZT02( M, N, A, LDA, TAU, WORK, LWORK ) 00287 * 00288 * Test STZRZF 00289 * 00290 * Generate test matrix of size m by n using 00291 * singular value distribution indicated by `mode'. 00292 * 00293 IF( MODE.EQ.0 ) THEN 00294 CALL SLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) 00295 DO 30 I = 1, MNMIN 00296 S( I ) = ZERO 00297 30 CONTINUE 00298 ELSE 00299 CALL SLATMS( M, N, 'Uniform', ISEED, 00300 $ 'Nonsymmetric', S, IMODE, 00301 $ ONE / EPS, ONE, M, N, 'No packing', A, 00302 $ LDA, WORK, INFO ) 00303 CALL SGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ), 00304 $ INFO ) 00305 CALL SLASET( 'Lower', M-1, N, ZERO, ZERO, A( 2 ), 00306 $ LDA ) 00307 CALL SLAORD( 'Decreasing', MNMIN, S, 1 ) 00308 END IF 00309 * 00310 * Save A and its singular values 00311 * 00312 CALL SLACPY( 'All', M, N, A, LDA, COPYA, LDA ) 00313 * 00314 * Call STZRZF to reduce the upper trapezoidal matrix to 00315 * upper triangular form. 00316 * 00317 SRNAMT = 'STZRZF' 00318 CALL STZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) 00319 * 00320 * Compute norm(svd(a) - svd(r)) 00321 * 00322 RESULT( 4 ) = SQRT12( M, M, A, LDA, S, WORK, 00323 $ LWORK ) 00324 * 00325 * Compute norm( A - R*Q ) 00326 * 00327 RESULT( 5 ) = SRZT01( M, N, COPYA, A, LDA, TAU, WORK, 00328 $ LWORK ) 00329 * 00330 * Compute norm(Q'*Q - I). 00331 * 00332 RESULT( 6 ) = SRZT02( M, N, A, LDA, TAU, WORK, LWORK ) 00333 * 00334 * Print information about the tests that did not pass 00335 * the threshold. 00336 * 00337 DO 40 K = 1, 6 00338 IF( RESULT( K ).GE.THRESH ) THEN 00339 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00340 $ CALL ALAHD( NOUT, PATH ) 00341 WRITE( NOUT, FMT = 9999 )M, N, IMODE, K, 00342 $ RESULT( K ) 00343 NFAIL = NFAIL + 1 00344 END IF 00345 40 CONTINUE 00346 NRUN = NRUN + 6 00347 50 CONTINUE 00348 END IF 00349 60 CONTINUE 00350 70 CONTINUE 00351 * 00352 * Print a summary of the results. 00353 * 00354 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00355 * 00356 9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2, 00357 $ ', ratio =', G12.5 ) 00358 * 00359 * End if SCHKTZ 00360 * 00361 END