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