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