|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE ZCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, 00002 $ COPYA, S, COPYS, TAU, WORK, RWORK, NOUT ) 00003 * 00004 * -- LAPACK test routine (version 3.1) -- 00005 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00006 * November 2006 00007 * 00008 * .. Scalar Arguments .. 00009 LOGICAL TSTERR 00010 INTEGER NM, NN, NOUT 00011 DOUBLE PRECISION THRESH 00012 * .. 00013 * .. Array Arguments .. 00014 LOGICAL DOTYPE( * ) 00015 INTEGER MVAL( * ), NVAL( * ) 00016 DOUBLE PRECISION COPYS( * ), RWORK( * ), S( * ) 00017 COMPLEX*16 A( * ), COPYA( * ), TAU( * ), WORK( * ) 00018 * .. 00019 * 00020 * Purpose 00021 * ======= 00022 * 00023 * ZCHKTZ tests ZTZRQF and ZTZRZF. 00024 * 00025 * Arguments 00026 * ========= 00027 * 00028 * DOTYPE (input) LOGICAL array, dimension (NTYPES) 00029 * The matrix types to be used for testing. Matrices of type j 00030 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 00031 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 00032 * 00033 * NM (input) INTEGER 00034 * The number of values of M contained in the vector MVAL. 00035 * 00036 * MVAL (input) INTEGER array, dimension (NM) 00037 * The values of the matrix row dimension M. 00038 * 00039 * NN (input) INTEGER 00040 * The number of values of N contained in the vector NVAL. 00041 * 00042 * NVAL (input) INTEGER array, dimension (NN) 00043 * The values of the matrix column dimension N. 00044 * 00045 * THRESH (input) DOUBLE PRECISION 00046 * The threshold value for the test ratios. A result is 00047 * included in the output file if RESULT >= THRESH. To have 00048 * every test ratio printed, use THRESH = 0. 00049 * 00050 * TSTERR (input) LOGICAL 00051 * Flag that indicates whether error exits are to be tested. 00052 * 00053 * A (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) 00054 * where MMAX is the maximum value of M in MVAL and NMAX is the 00055 * maximum value of N in NVAL. 00056 * 00057 * COPYA (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) 00058 * 00059 * S (workspace) DOUBLE PRECISION array, dimension 00060 * (min(MMAX,NMAX)) 00061 * 00062 * COPYS (workspace) DOUBLE PRECISION array, dimension 00063 * (min(MMAX,NMAX)) 00064 * 00065 * TAU (workspace) COMPLEX*16 array, dimension (MMAX) 00066 * 00067 * WORK (workspace) COMPLEX*16 array, dimension 00068 * (MMAX*NMAX + 4*NMAX + MMAX) 00069 * 00070 * RWORK (workspace) DOUBLE PRECISION array, dimension (2*NMAX) 00071 * 00072 * NOUT (input) INTEGER 00073 * The unit number for output. 00074 * 00075 * ===================================================================== 00076 * 00077 * .. Parameters .. 00078 INTEGER NTYPES 00079 PARAMETER ( NTYPES = 3 ) 00080 INTEGER NTESTS 00081 PARAMETER ( NTESTS = 6 ) 00082 DOUBLE PRECISION ONE, ZERO 00083 PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) 00084 * .. 00085 * .. Local Scalars .. 00086 CHARACTER*3 PATH 00087 INTEGER I, IM, IMODE, IN, INFO, K, LDA, LWORK, M, 00088 $ MNMIN, MODE, N, NERRS, NFAIL, NRUN 00089 DOUBLE PRECISION EPS 00090 * .. 00091 * .. Local Arrays .. 00092 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00093 DOUBLE PRECISION RESULT( NTESTS ) 00094 * .. 00095 * .. External Functions .. 00096 DOUBLE PRECISION DLAMCH, ZQRT12, ZRZT01, ZRZT02, ZTZT01, ZTZT02 00097 EXTERNAL DLAMCH, ZQRT12, ZRZT01, ZRZT02, ZTZT01, ZTZT02 00098 * .. 00099 * .. External Subroutines .. 00100 EXTERNAL ALAHD, ALASUM, DLAORD, ZERRTZ, ZGEQR2, ZLACPY, 00101 $ ZLASET, ZLATMS, ZTZRQF, ZTZRZF 00102 * .. 00103 * .. Intrinsic Functions .. 00104 INTRINSIC DCMPLX, MAX, MIN 00105 * .. 00106 * .. Scalars in Common .. 00107 LOGICAL LERR, OK 00108 CHARACTER*32 SRNAMT 00109 INTEGER INFOT, IOUNIT 00110 * .. 00111 * .. Common blocks .. 00112 COMMON / INFOC / INFOT, IOUNIT, OK, LERR 00113 COMMON / SRNAMC / SRNAMT 00114 * .. 00115 * .. Data statements .. 00116 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00117 * .. 00118 * .. Executable Statements .. 00119 * 00120 * Initialize constants and the random number seed. 00121 * 00122 PATH( 1: 1 ) = 'Zomplex precision' 00123 PATH( 2: 3 ) = 'TZ' 00124 NRUN = 0 00125 NFAIL = 0 00126 NERRS = 0 00127 DO 10 I = 1, 4 00128 ISEED( I ) = ISEEDY( I ) 00129 10 CONTINUE 00130 EPS = DLAMCH( 'Epsilon' ) 00131 * 00132 * Test the error exits 00133 * 00134 IF( TSTERR ) 00135 $ CALL ZERRTZ( PATH, NOUT ) 00136 INFOT = 0 00137 * 00138 DO 70 IM = 1, NM 00139 * 00140 * Do for each value of M in MVAL. 00141 * 00142 M = MVAL( IM ) 00143 LDA = MAX( 1, M ) 00144 * 00145 DO 60 IN = 1, NN 00146 * 00147 * Do for each value of N in NVAL for which M .LE. N. 00148 * 00149 N = NVAL( IN ) 00150 MNMIN = MIN( M, N ) 00151 LWORK = MAX( 1, N*N+4*M+N ) 00152 * 00153 IF( M.LE.N ) THEN 00154 DO 50 IMODE = 1, NTYPES 00155 * 00156 * Do for each type of singular value distribution. 00157 * 0: zero matrix 00158 * 1: one small singular value 00159 * 2: exponential distribution 00160 * 00161 MODE = IMODE - 1 00162 * 00163 * Test ZTZRQF 00164 * 00165 * Generate test matrix of size m by n using 00166 * singular value distribution indicated by `mode'. 00167 * 00168 IF( MODE.EQ.0 ) THEN 00169 CALL ZLASET( 'Full', M, N, DCMPLX( ZERO ), 00170 $ DCMPLX( ZERO ), A, LDA ) 00171 DO 20 I = 1, MNMIN 00172 COPYS( I ) = ZERO 00173 20 CONTINUE 00174 ELSE 00175 CALL ZLATMS( M, N, 'Uniform', ISEED, 00176 $ 'Nonsymmetric', COPYS, IMODE, 00177 $ ONE / EPS, ONE, M, N, 'No packing', A, 00178 $ LDA, WORK, INFO ) 00179 CALL ZGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ), 00180 $ INFO ) 00181 CALL ZLASET( 'Lower', M-1, N, DCMPLX( ZERO ), 00182 $ DCMPLX( ZERO ), A( 2 ), LDA ) 00183 CALL DLAORD( 'Decreasing', MNMIN, COPYS, 1 ) 00184 END IF 00185 * 00186 * Save A and its singular values 00187 * 00188 CALL ZLACPY( 'All', M, N, A, LDA, COPYA, LDA ) 00189 * 00190 * Call ZTZRQF to reduce the upper trapezoidal matrix to 00191 * upper triangular form. 00192 * 00193 SRNAMT = 'ZTZRQF' 00194 CALL ZTZRQF( M, N, A, LDA, TAU, INFO ) 00195 * 00196 * Compute norm(svd(a) - svd(r)) 00197 * 00198 RESULT( 1 ) = ZQRT12( M, M, A, LDA, COPYS, WORK, 00199 $ LWORK, RWORK ) 00200 * 00201 * Compute norm( A - R*Q ) 00202 * 00203 RESULT( 2 ) = ZTZT01( M, N, COPYA, A, LDA, TAU, WORK, 00204 $ LWORK ) 00205 * 00206 * Compute norm(Q'*Q - I). 00207 * 00208 RESULT( 3 ) = ZTZT02( M, N, A, LDA, TAU, WORK, LWORK ) 00209 * 00210 * Test ZTZRZF 00211 * 00212 * Generate test matrix of size m by n using 00213 * singular value distribution indicated by `mode'. 00214 * 00215 IF( MODE.EQ.0 ) THEN 00216 CALL ZLASET( 'Full', M, N, DCMPLX( ZERO ), 00217 $ DCMPLX( ZERO ), A, LDA ) 00218 DO 30 I = 1, MNMIN 00219 COPYS( I ) = ZERO 00220 30 CONTINUE 00221 ELSE 00222 CALL ZLATMS( M, N, 'Uniform', ISEED, 00223 $ 'Nonsymmetric', COPYS, IMODE, 00224 $ ONE / EPS, ONE, M, N, 'No packing', A, 00225 $ LDA, WORK, INFO ) 00226 CALL ZGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ), 00227 $ INFO ) 00228 CALL ZLASET( 'Lower', M-1, N, DCMPLX( ZERO ), 00229 $ DCMPLX( ZERO ), A( 2 ), LDA ) 00230 CALL DLAORD( 'Decreasing', MNMIN, COPYS, 1 ) 00231 END IF 00232 * 00233 * Save A and its singular values 00234 * 00235 CALL ZLACPY( 'All', M, N, A, LDA, COPYA, LDA ) 00236 * 00237 * Call ZTZRZF to reduce the upper trapezoidal matrix to 00238 * upper triangular form. 00239 * 00240 SRNAMT = 'ZTZRZF' 00241 CALL ZTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) 00242 * 00243 * Compute norm(svd(a) - svd(r)) 00244 * 00245 RESULT( 4 ) = ZQRT12( M, M, A, LDA, COPYS, WORK, 00246 $ LWORK, RWORK ) 00247 * 00248 * Compute norm( A - R*Q ) 00249 * 00250 RESULT( 5 ) = ZRZT01( M, N, COPYA, A, LDA, TAU, WORK, 00251 $ LWORK ) 00252 * 00253 * Compute norm(Q'*Q - I). 00254 * 00255 RESULT( 6 ) = ZRZT02( M, N, A, LDA, TAU, WORK, LWORK ) 00256 * 00257 * Print information about the tests that did not pass 00258 * the threshold. 00259 * 00260 DO 40 K = 1, 6 00261 IF( RESULT( K ).GE.THRESH ) THEN 00262 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00263 $ CALL ALAHD( NOUT, PATH ) 00264 WRITE( NOUT, FMT = 9999 )M, N, IMODE, K, 00265 $ RESULT( K ) 00266 NFAIL = NFAIL + 1 00267 END IF 00268 40 CONTINUE 00269 NRUN = NRUN + 6 00270 50 CONTINUE 00271 END IF 00272 60 CONTINUE 00273 70 CONTINUE 00274 * 00275 * Print a summary of the results. 00276 * 00277 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00278 * 00279 9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2, 00280 $ ', ratio =', G12.5 ) 00281 * 00282 * End if ZCHKTZ 00283 * 00284 END
1.7.3 
