![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b CCHKTZ 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 CCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, 00012 * COPYA, S, TAU, WORK, RWORK, 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 S( * ), RWORK( * ) 00023 * COMPLEX A( * ), COPYA( * ), TAU( * ), WORK( * ) 00024 * .. 00025 * 00026 * 00027 *> \par Purpose: 00028 * ============= 00029 *> 00030 *> \verbatim 00031 *> 00032 *> CCHKTZ tests CTZRQF and CTZRZF. 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 COMPLEX 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 COMPLEX 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 COMPLEX array, dimension (MMAX) 00105 *> \endverbatim 00106 *> 00107 *> \param[out] WORK 00108 *> \verbatim 00109 *> WORK is COMPLEX array, dimension 00110 *> (MMAX*NMAX + 4*NMAX + MMAX) 00111 *> \endverbatim 00112 *> 00113 *> \param[out] RWORK 00114 *> \verbatim 00115 *> RWORK is REAL array, dimension (2*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 complex_lin 00135 * 00136 * ===================================================================== 00137 SUBROUTINE CCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, 00138 $ COPYA, S, TAU, WORK, RWORK, 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 MVAL( * ), NVAL( * ) 00153 REAL S( * ), RWORK( * ) 00154 COMPLEX A( * ), COPYA( * ), TAU( * ), WORK( * ) 00155 * .. 00156 * 00157 * ===================================================================== 00158 * 00159 * .. Parameters .. 00160 INTEGER NTYPES 00161 PARAMETER ( NTYPES = 3 ) 00162 INTEGER NTESTS 00163 PARAMETER ( NTESTS = 6 ) 00164 REAL ONE, ZERO 00165 PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 ) 00166 * .. 00167 * .. Local Scalars .. 00168 CHARACTER*3 PATH 00169 INTEGER I, IM, IMODE, IN, INFO, K, LDA, LWORK, M, 00170 $ MNMIN, MODE, N, NERRS, NFAIL, NRUN 00171 REAL EPS 00172 * .. 00173 * .. Local Arrays .. 00174 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00175 REAL RESULT( NTESTS ) 00176 * .. 00177 * .. External Functions .. 00178 REAL CQRT12, CRZT01, CRZT02, CTZT01, CTZT02, SLAMCH 00179 EXTERNAL CQRT12, CRZT01, CRZT02, CTZT01, CTZT02, SLAMCH 00180 * .. 00181 * .. External Subroutines .. 00182 EXTERNAL ALAHD, ALASUM, CERRTZ, CGEQR2, CLACPY, CLASET, 00183 $ CLATMS, CTZRQF, CTZRZF, SLAORD 00184 * .. 00185 * .. Intrinsic Functions .. 00186 INTRINSIC CMPLX, MAX, MIN 00187 * .. 00188 * .. Scalars in Common .. 00189 LOGICAL LERR, OK 00190 CHARACTER*32 SRNAMT 00191 INTEGER INFOT, IOUNIT 00192 * .. 00193 * .. Common blocks .. 00194 COMMON / INFOC / INFOT, IOUNIT, OK, LERR 00195 COMMON / SRNAMC / SRNAMT 00196 * .. 00197 * .. Data statements .. 00198 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00199 * .. 00200 * .. Executable Statements .. 00201 * 00202 * Initialize constants and the random number seed. 00203 * 00204 PATH( 1: 1 ) = 'Complex precision' 00205 PATH( 2: 3 ) = 'TZ' 00206 NRUN = 0 00207 NFAIL = 0 00208 NERRS = 0 00209 DO 10 I = 1, 4 00210 ISEED( I ) = ISEEDY( I ) 00211 10 CONTINUE 00212 EPS = SLAMCH( 'Epsilon' ) 00213 * 00214 * Test the error exits 00215 * 00216 IF( TSTERR ) 00217 $ CALL CERRTZ( PATH, NOUT ) 00218 INFOT = 0 00219 * 00220 DO 70 IM = 1, NM 00221 * 00222 * Do for each value of M in MVAL. 00223 * 00224 M = MVAL( IM ) 00225 LDA = MAX( 1, M ) 00226 * 00227 DO 60 IN = 1, NN 00228 * 00229 * Do for each value of N in NVAL for which M .LE. N. 00230 * 00231 N = NVAL( IN ) 00232 MNMIN = MIN( M, N ) 00233 LWORK = MAX( 1, N*N+4*M+N ) 00234 * 00235 IF( M.LE.N ) THEN 00236 DO 50 IMODE = 1, NTYPES 00237 IF( .NOT.DOTYPE( IMODE ) ) 00238 $ GO TO 50 00239 * 00240 * Do for each type of singular value distribution. 00241 * 0: zero matrix 00242 * 1: one small singular value 00243 * 2: exponential distribution 00244 * 00245 MODE = IMODE - 1 00246 * 00247 * Test CTZRQF 00248 * 00249 * Generate test matrix of size m by n using 00250 * singular value distribution indicated by `mode'. 00251 * 00252 IF( MODE.EQ.0 ) THEN 00253 CALL CLASET( 'Full', M, N, CMPLX( ZERO ), 00254 $ CMPLX( ZERO ), A, LDA ) 00255 DO 20 I = 1, MNMIN 00256 S( I ) = ZERO 00257 20 CONTINUE 00258 ELSE 00259 CALL CLATMS( M, N, 'Uniform', ISEED, 00260 $ 'Nonsymmetric', S, IMODE, 00261 $ ONE / EPS, ONE, M, N, 'No packing', A, 00262 $ LDA, WORK, INFO ) 00263 CALL CGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ), 00264 $ INFO ) 00265 CALL CLASET( 'Lower', M-1, N, CMPLX( ZERO ), 00266 $ CMPLX( ZERO ), A( 2 ), LDA ) 00267 CALL SLAORD( 'Decreasing', MNMIN, S, 1 ) 00268 END IF 00269 * 00270 * Save A and its singular values 00271 * 00272 CALL CLACPY( 'All', M, N, A, LDA, COPYA, LDA ) 00273 * 00274 * Call CTZRQF to reduce the upper trapezoidal matrix to 00275 * upper triangular form. 00276 * 00277 SRNAMT = 'CTZRQF' 00278 CALL CTZRQF( M, N, A, LDA, TAU, INFO ) 00279 * 00280 * Compute norm(svd(a) - svd(r)) 00281 * 00282 RESULT( 1 ) = CQRT12( M, M, A, LDA, S, WORK, 00283 $ LWORK, RWORK ) 00284 * 00285 * Compute norm( A - R*Q ) 00286 * 00287 RESULT( 2 ) = CTZT01( M, N, COPYA, A, LDA, TAU, WORK, 00288 $ LWORK ) 00289 * 00290 * Compute norm(Q'*Q - I). 00291 * 00292 RESULT( 3 ) = CTZT02( M, N, A, LDA, TAU, WORK, LWORK ) 00293 * 00294 * Test CTZRZF 00295 * 00296 * Generate test matrix of size m by n using 00297 * singular value distribution indicated by `mode'. 00298 * 00299 IF( MODE.EQ.0 ) THEN 00300 CALL CLASET( 'Full', M, N, CMPLX( ZERO ), 00301 $ CMPLX( ZERO ), A, LDA ) 00302 DO 30 I = 1, MNMIN 00303 S( I ) = ZERO 00304 30 CONTINUE 00305 ELSE 00306 CALL CLATMS( M, N, 'Uniform', ISEED, 00307 $ 'Nonsymmetric', S, IMODE, 00308 $ ONE / EPS, ONE, M, N, 'No packing', A, 00309 $ LDA, WORK, INFO ) 00310 CALL CGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ), 00311 $ INFO ) 00312 CALL CLASET( 'Lower', M-1, N, CMPLX( ZERO ), 00313 $ CMPLX( ZERO ), A( 2 ), LDA ) 00314 CALL SLAORD( 'Decreasing', MNMIN, S, 1 ) 00315 END IF 00316 * 00317 * Save A and its singular values 00318 * 00319 CALL CLACPY( 'All', M, N, A, LDA, COPYA, LDA ) 00320 * 00321 * Call CTZRZF to reduce the upper trapezoidal matrix to 00322 * upper triangular form. 00323 * 00324 SRNAMT = 'CTZRZF' 00325 CALL CTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) 00326 * 00327 * Compute norm(svd(a) - svd(r)) 00328 * 00329 RESULT( 4 ) = CQRT12( M, M, A, LDA, S, WORK, 00330 $ LWORK, RWORK ) 00331 * 00332 * Compute norm( A - R*Q ) 00333 * 00334 RESULT( 5 ) = CRZT01( M, N, COPYA, A, LDA, TAU, WORK, 00335 $ LWORK ) 00336 * 00337 * Compute norm(Q'*Q - I). 00338 * 00339 RESULT( 6 ) = CRZT02( M, N, A, LDA, TAU, WORK, LWORK ) 00340 * 00341 * Print information about the tests that did not pass 00342 * the threshold. 00343 * 00344 DO 40 K = 1, 6 00345 IF( RESULT( K ).GE.THRESH ) THEN 00346 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00347 $ CALL ALAHD( NOUT, PATH ) 00348 WRITE( NOUT, FMT = 9999 )M, N, IMODE, K, 00349 $ RESULT( K ) 00350 NFAIL = NFAIL + 1 00351 END IF 00352 40 CONTINUE 00353 NRUN = NRUN + 6 00354 50 CONTINUE 00355 END IF 00356 60 CONTINUE 00357 70 CONTINUE 00358 * 00359 * Print a summary of the results. 00360 * 00361 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00362 * 00363 9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2, 00364 $ ', ratio =', G12.5 ) 00365 * 00366 * End if CCHKTZ 00367 * 00368 END