![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b ZCHKQP 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 * Definition: 00009 * =========== 00010 * 00011 * SUBROUTINE ZCHKQP( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, 00012 * COPYA, S, TAU, WORK, RWORK, IWORK, 00013 * NOUT ) 00014 * 00015 * .. Scalar Arguments .. 00016 * LOGICAL TSTERR 00017 * INTEGER NM, NN, NOUT 00018 * DOUBLE PRECISION THRESH 00019 * .. 00020 * .. Array Arguments .. 00021 * LOGICAL DOTYPE( * ) 00022 * INTEGER IWORK( * ), MVAL( * ), NVAL( * ) 00023 * DOUBLE PRECISION S( * ), RWORK( * ) 00024 * COMPLEX*16 A( * ), COPYA( * ), TAU( * ), WORK( * ) 00025 * .. 00026 * 00027 * 00028 *> \par Purpose: 00029 * ============= 00030 *> 00031 *> \verbatim 00032 *> 00033 *> ZCHKQP tests ZGEQPF. 00034 *> \endverbatim 00035 * 00036 * Arguments: 00037 * ========== 00038 * 00039 *> \param[in] DOTYPE 00040 *> \verbatim 00041 *> DOTYPE is LOGICAL array, dimension (NTYPES) 00042 *> The matrix types to be used for testing. Matrices of type j 00043 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 00044 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 00045 *> \endverbatim 00046 *> 00047 *> \param[in] NM 00048 *> \verbatim 00049 *> NM is INTEGER 00050 *> The number of values of M contained in the vector MVAL. 00051 *> \endverbatim 00052 *> 00053 *> \param[in] MVAL 00054 *> \verbatim 00055 *> MVAL is INTEGER array, dimension (NM) 00056 *> The values of the matrix row dimension M. 00057 *> \endverbatim 00058 *> 00059 *> \param[in] NN 00060 *> \verbatim 00061 *> NN is INTEGER 00062 *> The number of values of N contained in the vector NVAL. 00063 *> \endverbatim 00064 *> 00065 *> \param[in] NVAL 00066 *> \verbatim 00067 *> NVAL is INTEGER array, dimension (NN) 00068 *> The values of the matrix column dimension N. 00069 *> \endverbatim 00070 *> 00071 *> \param[in] THRESH 00072 *> \verbatim 00073 *> THRESH is DOUBLE PRECISION 00074 *> The threshold value for the test ratios. A result is 00075 *> included in the output file if RESULT >= THRESH. To have 00076 *> every test ratio printed, use THRESH = 0. 00077 *> \endverbatim 00078 *> 00079 *> \param[in] TSTERR 00080 *> \verbatim 00081 *> TSTERR is LOGICAL 00082 *> Flag that indicates whether error exits are to be tested. 00083 *> \endverbatim 00084 *> 00085 *> \param[out] A 00086 *> \verbatim 00087 *> A is COMPLEX*16 array, dimension (MMAX*NMAX) 00088 *> where MMAX is the maximum value of M in MVAL and NMAX is the 00089 *> maximum value of N in NVAL. 00090 *> \endverbatim 00091 *> 00092 *> \param[out] COPYA 00093 *> \verbatim 00094 *> COPYA is COMPLEX*16 array, dimension (MMAX*NMAX) 00095 *> \endverbatim 00096 *> 00097 *> \param[out] S 00098 *> \verbatim 00099 *> S is DOUBLE PRECISION array, dimension 00100 *> (min(MMAX,NMAX)) 00101 *> \endverbatim 00102 *> 00103 *> \param[out] TAU 00104 *> \verbatim 00105 *> TAU is COMPLEX*16 array, dimension (MMAX) 00106 *> \endverbatim 00107 *> 00108 *> \param[out] WORK 00109 *> \verbatim 00110 *> WORK is COMPLEX*16 array, dimension 00111 *> (max(M*max(M,N) + 4*min(M,N) + max(M,N))) 00112 *> \endverbatim 00113 *> 00114 *> \param[out] RWORK 00115 *> \verbatim 00116 *> RWORK is DOUBLE PRECISION array, dimension (4*NMAX) 00117 *> \endverbatim 00118 *> 00119 *> \param[out] IWORK 00120 *> \verbatim 00121 *> IWORK is INTEGER array, dimension (NMAX) 00122 *> \endverbatim 00123 *> 00124 *> \param[in] NOUT 00125 *> \verbatim 00126 *> NOUT is INTEGER 00127 *> The unit number for output. 00128 *> \endverbatim 00129 * 00130 * Authors: 00131 * ======== 00132 * 00133 *> \author Univ. of Tennessee 00134 *> \author Univ. of California Berkeley 00135 *> \author Univ. of Colorado Denver 00136 *> \author NAG Ltd. 00137 * 00138 *> \date November 2011 00139 * 00140 *> \ingroup complex16_lin 00141 * 00142 * ===================================================================== 00143 SUBROUTINE ZCHKQP( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, 00144 $ COPYA, S, TAU, WORK, RWORK, IWORK, 00145 $ NOUT ) 00146 * 00147 * -- LAPACK test routine (version 3.4.0) -- 00148 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00149 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00150 * November 2011 00151 * 00152 * .. Scalar Arguments .. 00153 LOGICAL TSTERR 00154 INTEGER NM, NN, NOUT 00155 DOUBLE PRECISION THRESH 00156 * .. 00157 * .. Array Arguments .. 00158 LOGICAL DOTYPE( * ) 00159 INTEGER IWORK( * ), MVAL( * ), NVAL( * ) 00160 DOUBLE PRECISION S( * ), RWORK( * ) 00161 COMPLEX*16 A( * ), COPYA( * ), TAU( * ), WORK( * ) 00162 * .. 00163 * 00164 * ===================================================================== 00165 * 00166 * .. Parameters .. 00167 INTEGER NTYPES 00168 PARAMETER ( NTYPES = 6 ) 00169 INTEGER NTESTS 00170 PARAMETER ( NTESTS = 3 ) 00171 DOUBLE PRECISION ONE, ZERO 00172 PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) 00173 * .. 00174 * .. Local Scalars .. 00175 CHARACTER*3 PATH 00176 INTEGER I, IHIGH, ILOW, IM, IMODE, IN, INFO, ISTEP, K, 00177 $ LDA, LWORK, M, MNMIN, MODE, N, NERRS, NFAIL, 00178 $ NRUN 00179 DOUBLE PRECISION EPS 00180 * .. 00181 * .. Local Arrays .. 00182 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00183 DOUBLE PRECISION RESULT( NTESTS ) 00184 * .. 00185 * .. External Functions .. 00186 DOUBLE PRECISION DLAMCH, ZQPT01, ZQRT11, ZQRT12 00187 EXTERNAL DLAMCH, ZQPT01, ZQRT11, ZQRT12 00188 * .. 00189 * .. External Subroutines .. 00190 EXTERNAL ALAHD, ALASUM, DLAORD, ZERRQP, ZGEQPF, ZLACPY, 00191 $ ZLASET, ZLATMS 00192 * .. 00193 * .. Intrinsic Functions .. 00194 INTRINSIC DCMPLX, MAX, MIN 00195 * .. 00196 * .. Scalars in Common .. 00197 LOGICAL LERR, OK 00198 CHARACTER*32 SRNAMT 00199 INTEGER INFOT, IOUNIT 00200 * .. 00201 * .. Common blocks .. 00202 COMMON / INFOC / INFOT, IOUNIT, OK, LERR 00203 COMMON / SRNAMC / SRNAMT 00204 * .. 00205 * .. Data statements .. 00206 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00207 * .. 00208 * .. Executable Statements .. 00209 * 00210 * Initialize constants and the random number seed. 00211 * 00212 PATH( 1: 1 ) = 'Zomplex precision' 00213 PATH( 2: 3 ) = 'QP' 00214 NRUN = 0 00215 NFAIL = 0 00216 NERRS = 0 00217 DO 10 I = 1, 4 00218 ISEED( I ) = ISEEDY( I ) 00219 10 CONTINUE 00220 EPS = DLAMCH( 'Epsilon' ) 00221 * 00222 * Test the error exits 00223 * 00224 IF( TSTERR ) 00225 $ CALL ZERRQP( PATH, NOUT ) 00226 INFOT = 0 00227 * 00228 DO 80 IM = 1, NM 00229 * 00230 * Do for each value of M in MVAL. 00231 * 00232 M = MVAL( IM ) 00233 LDA = MAX( 1, M ) 00234 * 00235 DO 70 IN = 1, NN 00236 * 00237 * Do for each value of N in NVAL. 00238 * 00239 N = NVAL( IN ) 00240 MNMIN = MIN( M, N ) 00241 LWORK = MAX( 1, M*MAX( M, N )+4*MNMIN+MAX( M, N ) ) 00242 * 00243 DO 60 IMODE = 1, NTYPES 00244 IF( .NOT.DOTYPE( IMODE ) ) 00245 $ GO TO 60 00246 * 00247 * Do for each type of matrix 00248 * 1: zero matrix 00249 * 2: one small singular value 00250 * 3: geometric distribution of singular values 00251 * 4: first n/2 columns fixed 00252 * 5: last n/2 columns fixed 00253 * 6: every second column fixed 00254 * 00255 MODE = IMODE 00256 IF( IMODE.GT.3 ) 00257 $ MODE = 1 00258 * 00259 * Generate test matrix of size m by n using 00260 * singular value distribution indicated by `mode'. 00261 * 00262 DO 20 I = 1, N 00263 IWORK( I ) = 0 00264 20 CONTINUE 00265 IF( IMODE.EQ.1 ) THEN 00266 CALL ZLASET( 'Full', M, N, DCMPLX( ZERO ), 00267 $ DCMPLX( ZERO ), COPYA, LDA ) 00268 DO 30 I = 1, MNMIN 00269 S( I ) = ZERO 00270 30 CONTINUE 00271 ELSE 00272 CALL ZLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', S, 00273 $ MODE, ONE / EPS, ONE, M, N, 'No packing', 00274 $ COPYA, LDA, WORK, INFO ) 00275 IF( IMODE.GE.4 ) THEN 00276 IF( IMODE.EQ.4 ) THEN 00277 ILOW = 1 00278 ISTEP = 1 00279 IHIGH = MAX( 1, N / 2 ) 00280 ELSE IF( IMODE.EQ.5 ) THEN 00281 ILOW = MAX( 1, N / 2 ) 00282 ISTEP = 1 00283 IHIGH = N 00284 ELSE IF( IMODE.EQ.6 ) THEN 00285 ILOW = 1 00286 ISTEP = 2 00287 IHIGH = N 00288 END IF 00289 DO 40 I = ILOW, IHIGH, ISTEP 00290 IWORK( I ) = 1 00291 40 CONTINUE 00292 END IF 00293 CALL DLAORD( 'Decreasing', MNMIN, S, 1 ) 00294 END IF 00295 * 00296 * Save A and its singular values 00297 * 00298 CALL ZLACPY( 'All', M, N, COPYA, LDA, A, LDA ) 00299 * 00300 * Compute the QR factorization with pivoting of A 00301 * 00302 SRNAMT = 'ZGEQPF' 00303 CALL ZGEQPF( M, N, A, LDA, IWORK, TAU, WORK, RWORK, 00304 $ INFO ) 00305 * 00306 * Compute norm(svd(a) - svd(r)) 00307 * 00308 RESULT( 1 ) = ZQRT12( M, N, A, LDA, S, WORK, LWORK, 00309 $ RWORK ) 00310 * 00311 * Compute norm( A*P - Q*R ) 00312 * 00313 RESULT( 2 ) = ZQPT01( M, N, MNMIN, COPYA, A, LDA, TAU, 00314 $ IWORK, WORK, LWORK ) 00315 * 00316 * Compute Q'*Q 00317 * 00318 RESULT( 3 ) = ZQRT11( M, MNMIN, A, LDA, TAU, WORK, 00319 $ LWORK ) 00320 * 00321 * Print information about the tests that did not pass 00322 * the threshold. 00323 * 00324 DO 50 K = 1, 3 00325 IF( RESULT( K ).GE.THRESH ) THEN 00326 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00327 $ CALL ALAHD( NOUT, PATH ) 00328 WRITE( NOUT, FMT = 9999 )M, N, IMODE, K, 00329 $ RESULT( K ) 00330 NFAIL = NFAIL + 1 00331 END IF 00332 50 CONTINUE 00333 NRUN = NRUN + 3 00334 60 CONTINUE 00335 70 CONTINUE 00336 80 CONTINUE 00337 * 00338 * Print a summary of the results. 00339 * 00340 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00341 * 00342 9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2, 00343 $ ', ratio =', G12.5 ) 00344 * 00345 * End of ZCHKQP 00346 * 00347 END