 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 SUBROUTINE DCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, 00002 $ COPYA, S, COPYS, TAU, WORK, NOUT ) 00003 * 00004 * -- LAPACK test routine (version 3.1.1) -- 00005 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00006 * January 2007 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 A( * ), COPYA( * ), COPYS( * ), S( * ), 00017 $ TAU( * ), WORK( * ) 00018 * .. 00019 * 00020 * Purpose 00021 * ======= 00022 * 00023 * DCHKTZ tests DTZRQF and STZRZF. 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (MMAX) 00066 * 00067 * WORK (workspace) DOUBLE PRECISION array, dimension 00068 * (MMAX*NMAX + 4*NMAX + MMAX) 00069 * 00070 * NOUT (input) INTEGER 00071 * The unit number for output. 00072 * 00073 * ===================================================================== 00074 * 00075 * .. Parameters .. 00076 INTEGER NTYPES 00077 PARAMETER ( NTYPES = 3 ) 00078 INTEGER NTESTS 00079 PARAMETER ( NTESTS = 6 ) 00080 DOUBLE PRECISION ONE, ZERO 00081 PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) 00082 * .. 00083 * .. Local Scalars .. 00084 CHARACTER*3 PATH 00085 INTEGER I, IM, IMODE, IN, INFO, K, LDA, LWORK, M, 00086 $ MNMIN, MODE, N, NERRS, NFAIL, NRUN 00087 DOUBLE PRECISION EPS 00088 * .. 00089 * .. Local Arrays .. 00090 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00091 DOUBLE PRECISION RESULT( NTESTS ) 00092 * .. 00093 * .. External Functions .. 00094 DOUBLE PRECISION DLAMCH, DQRT12, DRZT01, DRZT02, DTZT01, DTZT02 00095 EXTERNAL DLAMCH, DQRT12, DRZT01, DRZT02, DTZT01, DTZT02 00096 * .. 00097 * .. External Subroutines .. 00098 EXTERNAL ALAHD, ALASUM, DERRTZ, DGEQR2, DLACPY, DLAORD, 00099 $ DLASET, DLATMS, DTZRQF, DTZRZF 00100 * .. 00101 * .. Intrinsic Functions .. 00102 INTRINSIC MAX, MIN 00103 * .. 00104 * .. Scalars in Common .. 00105 LOGICAL LERR, OK 00106 CHARACTER*32 SRNAMT 00107 INTEGER INFOT, IOUNIT 00108 * .. 00109 * .. Common blocks .. 00110 COMMON / INFOC / INFOT, IOUNIT, OK, LERR 00111 COMMON / SRNAMC / SRNAMT 00112 * .. 00113 * .. Data statements .. 00114 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00115 * .. 00116 * .. Executable Statements .. 00117 * 00118 * Initialize constants and the random number seed. 00119 * 00120 PATH( 1: 1 ) = 'Double precision' 00121 PATH( 2: 3 ) = 'TZ' 00122 NRUN = 0 00123 NFAIL = 0 00124 NERRS = 0 00125 DO 10 I = 1, 4 00126 ISEED( I ) = ISEEDY( I ) 00127 10 CONTINUE 00128 EPS = DLAMCH( 'Epsilon' ) 00129 * 00130 * Test the error exits 00131 * 00132 IF( TSTERR ) 00133 $ CALL DERRTZ( PATH, NOUT ) 00134 INFOT = 0 00135 * 00136 DO 70 IM = 1, NM 00137 * 00138 * Do for each value of M in MVAL. 00139 * 00140 M = MVAL( IM ) 00141 LDA = MAX( 1, M ) 00142 * 00143 DO 60 IN = 1, NN 00144 * 00145 * Do for each value of N in NVAL for which M .LE. N. 00146 * 00147 N = NVAL( IN ) 00148 MNMIN = MIN( M, N ) 00149 LWORK = MAX( 1, N*N+4*M+N, M*N+2*MNMIN+4*N ) 00150 * 00151 IF( M.LE.N ) THEN 00152 DO 50 IMODE = 1, NTYPES 00153 IF( .NOT.DOTYPE( IMODE ) ) 00154 $ GO TO 50 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 DTZRQF 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 DLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) 00170 DO 20 I = 1, MNMIN 00171 COPYS( I ) = ZERO 00172 20 CONTINUE 00173 ELSE 00174 CALL DLATMS( M, N, 'Uniform', ISEED, 00175 $ 'Nonsymmetric', COPYS, IMODE, 00176 $ ONE / EPS, ONE, M, N, 'No packing', A, 00177 $ LDA, WORK, INFO ) 00178 CALL DGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ), 00179 $ INFO ) 00180 CALL DLASET( 'Lower', M-1, N, ZERO, ZERO, A( 2 ), 00181 $ LDA ) 00182 CALL DLAORD( 'Decreasing', MNMIN, COPYS, 1 ) 00183 END IF 00184 * 00185 * Save A and its singular values 00186 * 00187 CALL DLACPY( 'All', M, N, A, LDA, COPYA, LDA ) 00188 * 00189 * Call DTZRQF to reduce the upper trapezoidal matrix to 00190 * upper triangular form. 00191 * 00192 SRNAMT = 'DTZRQF' 00193 CALL DTZRQF( M, N, A, LDA, TAU, INFO ) 00194 * 00195 * Compute norm(svd(a) - svd(r)) 00196 * 00197 RESULT( 1 ) = DQRT12( M, M, A, LDA, COPYS, WORK, 00198 $ LWORK ) 00199 * 00200 * Compute norm( A - R*Q ) 00201 * 00202 RESULT( 2 ) = DTZT01( M, N, COPYA, A, LDA, TAU, WORK, 00203 $ LWORK ) 00204 * 00205 * Compute norm(Q'*Q - I). 00206 * 00207 RESULT( 3 ) = DTZT02( M, N, A, LDA, TAU, WORK, LWORK ) 00208 * 00209 * Test DTZRZF 00210 * 00211 * Generate test matrix of size m by n using 00212 * singular value distribution indicated by `mode'. 00213 * 00214 IF( MODE.EQ.0 ) THEN 00215 CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) 00216 DO 30 I = 1, MNMIN 00217 COPYS( I ) = ZERO 00218 30 CONTINUE 00219 ELSE 00220 CALL DLATMS( M, N, 'Uniform', ISEED, 00221 $ 'Nonsymmetric', COPYS, IMODE, 00222 $ ONE / EPS, ONE, M, N, 'No packing', A, 00223 $ LDA, WORK, INFO ) 00224 CALL DGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ), 00225 $ INFO ) 00226 CALL DLASET( 'Lower', M-1, N, ZERO, ZERO, A( 2 ), 00227 $ LDA ) 00228 CALL DLAORD( 'Decreasing', MNMIN, COPYS, 1 ) 00229 END IF 00230 * 00231 * Save A and its singular values 00232 * 00233 CALL DLACPY( 'All', M, N, A, LDA, COPYA, LDA ) 00234 * 00235 * Call DTZRZF to reduce the upper trapezoidal matrix to 00236 * upper triangular form. 00237 * 00238 SRNAMT = 'DTZRZF' 00239 CALL DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) 00240 * 00241 * Compute norm(svd(a) - svd(r)) 00242 * 00243 RESULT( 4 ) = DQRT12( M, M, A, LDA, COPYS, WORK, 00244 $ LWORK ) 00245 * 00246 * Compute norm( A - R*Q ) 00247 * 00248 RESULT( 5 ) = DRZT01( M, N, COPYA, A, LDA, TAU, WORK, 00249 $ LWORK ) 00250 * 00251 * Compute norm(Q'*Q - I). 00252 * 00253 RESULT( 6 ) = DRZT02( M, N, A, LDA, TAU, WORK, LWORK ) 00254 * 00255 * Print information about the tests that did not pass 00256 * the threshold. 00257 * 00258 DO 40 K = 1, 6 00259 IF( RESULT( K ).GE.THRESH ) THEN 00260 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00261 $ CALL ALAHD( NOUT, PATH ) 00262 WRITE( NOUT, FMT = 9999 )M, N, IMODE, K, 00263 $ RESULT( K ) 00264 NFAIL = NFAIL + 1 00265 END IF 00266 40 CONTINUE 00267 NRUN = NRUN + 6 00268 50 CONTINUE 00269 END IF 00270 60 CONTINUE 00271 70 CONTINUE 00272 * 00273 * Print a summary of the results. 00274 * 00275 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00276 * 00277 9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2, 00278 $ ', ratio =', G12.5 ) 00279 * 00280 * End if DCHKTZ 00281 * 00282 END
1.7.3 
