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