 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 SUBROUTINE DCHKQP( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, 00002 $ COPYA, S, COPYS, TAU, WORK, IWORK, 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 IWORK( * ), MVAL( * ), NVAL( * ) 00016 DOUBLE PRECISION A( * ), COPYA( * ), COPYS( * ), S( * ), 00017 $ TAU( * ), WORK( * ) 00018 * .. 00019 * 00020 * Purpose 00021 * ======= 00022 * 00023 * DCHKQP tests DGEQPF. 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 * IWORK (workspace) INTEGER array, dimension (NMAX) 00071 * 00072 * NOUT (input) INTEGER 00073 * The unit number for output. 00074 * 00075 * ===================================================================== 00076 * 00077 * .. Parameters .. 00078 INTEGER NTYPES 00079 PARAMETER ( NTYPES = 6 ) 00080 INTEGER NTESTS 00081 PARAMETER ( NTESTS = 3 ) 00082 DOUBLE PRECISION ONE, ZERO 00083 PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) 00084 * .. 00085 * .. Local Scalars .. 00086 CHARACTER*3 PATH 00087 INTEGER I, IHIGH, ILOW, IM, IMODE, IN, INFO, ISTEP, K, 00088 $ LDA, LWORK, M, MNMIN, MODE, N, NERRS, NFAIL, 00089 $ NRUN 00090 DOUBLE PRECISION EPS 00091 * .. 00092 * .. Local Arrays .. 00093 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00094 DOUBLE PRECISION RESULT( NTESTS ) 00095 * .. 00096 * .. External Functions .. 00097 DOUBLE PRECISION DLAMCH, DQPT01, DQRT11, DQRT12 00098 EXTERNAL DLAMCH, DQPT01, DQRT11, DQRT12 00099 * .. 00100 * .. External Subroutines .. 00101 EXTERNAL ALAHD, ALASUM, DERRQP, DGEQPF, DLACPY, DLAORD, 00102 $ DLASET, DLATMS 00103 * .. 00104 * .. Intrinsic Functions .. 00105 INTRINSIC MAX, MIN 00106 * .. 00107 * .. Scalars in Common .. 00108 LOGICAL LERR, OK 00109 CHARACTER*32 SRNAMT 00110 INTEGER INFOT, IOUNIT 00111 * .. 00112 * .. Common blocks .. 00113 COMMON / INFOC / INFOT, IOUNIT, OK, LERR 00114 COMMON / SRNAMC / SRNAMT 00115 * .. 00116 * .. Data statements .. 00117 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00118 * .. 00119 * .. Executable Statements .. 00120 * 00121 * Initialize constants and the random number seed. 00122 * 00123 PATH( 1: 1 ) = 'Double precision' 00124 PATH( 2: 3 ) = 'QP' 00125 NRUN = 0 00126 NFAIL = 0 00127 NERRS = 0 00128 DO 10 I = 1, 4 00129 ISEED( I ) = ISEEDY( I ) 00130 10 CONTINUE 00131 EPS = DLAMCH( 'Epsilon' ) 00132 * 00133 * Test the error exits 00134 * 00135 IF( TSTERR ) 00136 $ CALL DERRQP( PATH, NOUT ) 00137 INFOT = 0 00138 * 00139 DO 80 IM = 1, NM 00140 * 00141 * Do for each value of M in MVAL. 00142 * 00143 M = MVAL( IM ) 00144 LDA = MAX( 1, M ) 00145 * 00146 DO 70 IN = 1, NN 00147 * 00148 * Do for each value of N in NVAL. 00149 * 00150 N = NVAL( IN ) 00151 MNMIN = MIN( M, N ) 00152 LWORK = MAX( 1, M*MAX( M, N ) + 4*MNMIN + MAX( M, N ), 00153 $ M*N + 2*MNMIN + 4*N ) 00154 * 00155 DO 60 IMODE = 1, NTYPES 00156 IF( .NOT.DOTYPE( IMODE ) ) 00157 $ GO TO 60 00158 * 00159 * Do for each type of matrix 00160 * 1: zero matrix 00161 * 2: one small singular value 00162 * 3: geometric distribution of singular values 00163 * 4: first n/2 columns fixed 00164 * 5: last n/2 columns fixed 00165 * 6: every second column fixed 00166 * 00167 MODE = IMODE 00168 IF( IMODE.GT.3 ) 00169 $ MODE = 1 00170 * 00171 * Generate test matrix of size m by n using 00172 * singular value distribution indicated by `mode'. 00173 * 00174 DO 20 I = 1, N 00175 IWORK( I ) = 0 00176 20 CONTINUE 00177 IF( IMODE.EQ.1 ) THEN 00178 CALL DLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA ) 00179 DO 30 I = 1, MNMIN 00180 COPYS( I ) = ZERO 00181 30 CONTINUE 00182 ELSE 00183 CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', COPYS, 00184 $ MODE, ONE / EPS, ONE, M, N, 'No packing', 00185 $ COPYA, LDA, WORK, INFO ) 00186 IF( IMODE.GE.4 ) THEN 00187 IF( IMODE.EQ.4 ) THEN 00188 ILOW = 1 00189 ISTEP = 1 00190 IHIGH = MAX( 1, N / 2 ) 00191 ELSE IF( IMODE.EQ.5 ) THEN 00192 ILOW = MAX( 1, N / 2 ) 00193 ISTEP = 1 00194 IHIGH = N 00195 ELSE IF( IMODE.EQ.6 ) THEN 00196 ILOW = 1 00197 ISTEP = 2 00198 IHIGH = N 00199 END IF 00200 DO 40 I = ILOW, IHIGH, ISTEP 00201 IWORK( I ) = 1 00202 40 CONTINUE 00203 END IF 00204 CALL DLAORD( 'Decreasing', MNMIN, COPYS, 1 ) 00205 END IF 00206 * 00207 * Save A and its singular values 00208 * 00209 CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA ) 00210 * 00211 * Compute the QR factorization with pivoting of A 00212 * 00213 SRNAMT = 'DGEQPF' 00214 CALL DGEQPF( M, N, A, LDA, IWORK, TAU, WORK, INFO ) 00215 * 00216 * Compute norm(svd(a) - svd(r)) 00217 * 00218 RESULT( 1 ) = DQRT12( M, N, A, LDA, COPYS, WORK, LWORK ) 00219 * 00220 * Compute norm( A*P - Q*R ) 00221 * 00222 RESULT( 2 ) = DQPT01( M, N, MNMIN, COPYA, A, LDA, TAU, 00223 $ IWORK, WORK, LWORK ) 00224 * 00225 * Compute Q'*Q 00226 * 00227 RESULT( 3 ) = DQRT11( M, MNMIN, A, LDA, TAU, WORK, 00228 $ LWORK ) 00229 * 00230 * Print information about the tests that did not pass 00231 * the threshold. 00232 * 00233 DO 50 K = 1, 3 00234 IF( RESULT( K ).GE.THRESH ) THEN 00235 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00236 $ CALL ALAHD( NOUT, PATH ) 00237 WRITE( NOUT, FMT = 9999 )M, N, IMODE, K, 00238 $ RESULT( K ) 00239 NFAIL = NFAIL + 1 00240 END IF 00241 50 CONTINUE 00242 NRUN = NRUN + 3 00243 60 CONTINUE 00244 70 CONTINUE 00245 80 CONTINUE 00246 * 00247 * Print a summary of the results. 00248 * 00249 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00250 * 00251 9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2, 00252 $ ', ratio =', G12.5 ) 00253 * 00254 * End of DCHKQP 00255 * 00256 END
1.7.3 
