1*> \brief \b DCHKTZ 2* 3* =========== DOCUMENTATION =========== 4* 5* Online html documentation available at 6* http://www.netlib.org/lapack/explore-html/ 7* 8* Definition: 9* =========== 10* 11* SUBROUTINE DCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, 12* COPYA, S, TAU, WORK, NOUT ) 13* 14* .. Scalar Arguments .. 15* LOGICAL TSTERR 16* INTEGER NM, NN, NOUT 17* DOUBLE PRECISION THRESH 18* .. 19* .. Array Arguments .. 20* LOGICAL DOTYPE( * ) 21* INTEGER MVAL( * ), NVAL( * ) 22* DOUBLE PRECISION A( * ), COPYA( * ), S( * ), 23* $ TAU( * ), WORK( * ) 24* .. 25* 26* 27*> \par Purpose: 28* ============= 29*> 30*> \verbatim 31*> 32*> DCHKTZ tests DTZRZF. 33*> \endverbatim 34* 35* Arguments: 36* ========== 37* 38*> \param[in] DOTYPE 39*> \verbatim 40*> DOTYPE is LOGICAL array, dimension (NTYPES) 41*> The matrix types to be used for testing. Matrices of type j 42*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 43*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 44*> \endverbatim 45*> 46*> \param[in] NM 47*> \verbatim 48*> NM is INTEGER 49*> The number of values of M contained in the vector MVAL. 50*> \endverbatim 51*> 52*> \param[in] MVAL 53*> \verbatim 54*> MVAL is INTEGER array, dimension (NM) 55*> The values of the matrix row dimension M. 56*> \endverbatim 57*> 58*> \param[in] NN 59*> \verbatim 60*> NN is INTEGER 61*> The number of values of N contained in the vector NVAL. 62*> \endverbatim 63*> 64*> \param[in] NVAL 65*> \verbatim 66*> NVAL is INTEGER array, dimension (NN) 67*> The values of the matrix column dimension N. 68*> \endverbatim 69*> 70*> \param[in] THRESH 71*> \verbatim 72*> THRESH is DOUBLE PRECISION 73*> The threshold value for the test ratios. A result is 74*> included in the output file if RESULT >= THRESH. To have 75*> every test ratio printed, use THRESH = 0. 76*> \endverbatim 77*> 78*> \param[in] TSTERR 79*> \verbatim 80*> TSTERR is LOGICAL 81*> Flag that indicates whether error exits are to be tested. 82*> \endverbatim 83*> 84*> \param[out] A 85*> \verbatim 86*> A is DOUBLE PRECISION array, dimension (MMAX*NMAX) 87*> where MMAX is the maximum value of M in MVAL and NMAX is the 88*> maximum value of N in NVAL. 89*> \endverbatim 90*> 91*> \param[out] COPYA 92*> \verbatim 93*> COPYA is DOUBLE PRECISION array, dimension (MMAX*NMAX) 94*> \endverbatim 95*> 96*> \param[out] S 97*> \verbatim 98*> S is DOUBLE PRECISION array, dimension 99*> (min(MMAX,NMAX)) 100*> \endverbatim 101*> 102*> \param[out] TAU 103*> \verbatim 104*> TAU is DOUBLE PRECISION array, dimension (MMAX) 105*> \endverbatim 106*> 107*> \param[out] WORK 108*> \verbatim 109*> WORK is DOUBLE PRECISION array, dimension 110*> (MMAX*NMAX + 4*NMAX + MMAX) 111*> \endverbatim 112*> 113*> \param[in] NOUT 114*> \verbatim 115*> NOUT is INTEGER 116*> The unit number for output. 117*> \endverbatim 118* 119* Authors: 120* ======== 121* 122*> \author Univ. of Tennessee 123*> \author Univ. of California Berkeley 124*> \author Univ. of Colorado Denver 125*> \author NAG Ltd. 126* 127*> \ingroup double_lin 128* 129* ===================================================================== 130 SUBROUTINE DCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, 131 $ COPYA, S, TAU, WORK, NOUT ) 132* 133* -- LAPACK test routine -- 134* -- LAPACK is a software package provided by Univ. of Tennessee, -- 135* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 136* 137* .. Scalar Arguments .. 138 LOGICAL TSTERR 139 INTEGER NM, NN, NOUT 140 DOUBLE PRECISION THRESH 141* .. 142* .. Array Arguments .. 143 LOGICAL DOTYPE( * ) 144 INTEGER MVAL( * ), NVAL( * ) 145 DOUBLE PRECISION A( * ), COPYA( * ), S( * ), 146 $ TAU( * ), WORK( * ) 147* .. 148* 149* ===================================================================== 150* 151* .. Parameters .. 152 INTEGER NTYPES 153 PARAMETER ( NTYPES = 3 ) 154 INTEGER NTESTS 155 PARAMETER ( NTESTS = 3 ) 156 DOUBLE PRECISION ONE, ZERO 157 PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) 158* .. 159* .. Local Scalars .. 160 CHARACTER*3 PATH 161 INTEGER I, IM, IMODE, IN, INFO, K, LDA, LWORK, M, 162 $ MNMIN, MODE, N, NERRS, NFAIL, NRUN 163 DOUBLE PRECISION EPS 164* .. 165* .. Local Arrays .. 166 INTEGER ISEED( 4 ), ISEEDY( 4 ) 167 DOUBLE PRECISION RESULT( NTESTS ) 168* .. 169* .. External Functions .. 170 DOUBLE PRECISION DLAMCH, DQRT12, DRZT01, DRZT02 171 EXTERNAL DLAMCH, DQRT12, DRZT01, DRZT02 172* .. 173* .. External Subroutines .. 174 EXTERNAL ALAHD, ALASUM, DERRTZ, DGEQR2, DLACPY, DLAORD, 175 $ DLASET, DLATMS, DTZRZF 176* .. 177* .. Intrinsic Functions .. 178 INTRINSIC MAX, MIN 179* .. 180* .. Scalars in Common .. 181 LOGICAL LERR, OK 182 CHARACTER*32 SRNAMT 183 INTEGER INFOT, IOUNIT 184* .. 185* .. Common blocks .. 186 COMMON / INFOC / INFOT, IOUNIT, OK, LERR 187 COMMON / SRNAMC / SRNAMT 188* .. 189* .. Data statements .. 190 DATA ISEEDY / 1988, 1989, 1990, 1991 / 191* .. 192* .. Executable Statements .. 193* 194* Initialize constants and the random number seed. 195* 196 PATH( 1: 1 ) = 'Double precision' 197 PATH( 2: 3 ) = 'TZ' 198 NRUN = 0 199 NFAIL = 0 200 NERRS = 0 201 DO 10 I = 1, 4 202 ISEED( I ) = ISEEDY( I ) 203 10 CONTINUE 204 EPS = DLAMCH( 'Epsilon' ) 205* 206* Test the error exits 207* 208 IF( TSTERR ) 209 $ CALL DERRTZ( PATH, NOUT ) 210 INFOT = 0 211* 212 DO 70 IM = 1, NM 213* 214* Do for each value of M in MVAL. 215* 216 M = MVAL( IM ) 217 LDA = MAX( 1, M ) 218* 219 DO 60 IN = 1, NN 220* 221* Do for each value of N in NVAL for which M .LE. N. 222* 223 N = NVAL( IN ) 224 MNMIN = MIN( M, N ) 225 LWORK = MAX( 1, N*N+4*M+N, M*N+2*MNMIN+4*N ) 226* 227 IF( M.LE.N ) THEN 228 DO 50 IMODE = 1, NTYPES 229 IF( .NOT.DOTYPE( IMODE ) ) 230 $ GO TO 50 231* 232* Do for each type of singular value distribution. 233* 0: zero matrix 234* 1: one small singular value 235* 2: exponential distribution 236* 237 MODE = IMODE - 1 238* 239* Test DTZRQF 240* 241* Generate test matrix of size m by n using 242* singular value distribution indicated by `mode'. 243* 244 IF( MODE.EQ.0 ) THEN 245 CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) 246 DO 30 I = 1, MNMIN 247 S( I ) = ZERO 248 30 CONTINUE 249 ELSE 250 CALL DLATMS( M, N, 'Uniform', ISEED, 251 $ 'Nonsymmetric', S, IMODE, 252 $ ONE / EPS, ONE, M, N, 'No packing', A, 253 $ LDA, WORK, INFO ) 254 CALL DGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ), 255 $ INFO ) 256 CALL DLASET( 'Lower', M-1, N, ZERO, ZERO, A( 2 ), 257 $ LDA ) 258 CALL DLAORD( 'Decreasing', MNMIN, S, 1 ) 259 END IF 260* 261* Save A and its singular values 262* 263 CALL DLACPY( 'All', M, N, A, LDA, COPYA, LDA ) 264* 265* Call DTZRZF to reduce the upper trapezoidal matrix to 266* upper triangular form. 267* 268 SRNAMT = 'DTZRZF' 269 CALL DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) 270* 271* Compute norm(svd(a) - svd(r)) 272* 273 RESULT( 1 ) = DQRT12( M, M, A, LDA, S, WORK, 274 $ LWORK ) 275* 276* Compute norm( A - R*Q ) 277* 278 RESULT( 2 ) = DRZT01( M, N, COPYA, A, LDA, TAU, WORK, 279 $ LWORK ) 280* 281* Compute norm(Q'*Q - I). 282* 283 RESULT( 3 ) = DRZT02( M, N, A, LDA, TAU, WORK, LWORK ) 284* 285* Print information about the tests that did not pass 286* the threshold. 287* 288 DO 40 K = 1, NTESTS 289 IF( RESULT( K ).GE.THRESH ) THEN 290 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 291 $ CALL ALAHD( NOUT, PATH ) 292 WRITE( NOUT, FMT = 9999 )M, N, IMODE, K, 293 $ RESULT( K ) 294 NFAIL = NFAIL + 1 295 END IF 296 40 CONTINUE 297 NRUN = NRUN + 3 298 50 CONTINUE 299 END IF 300 60 CONTINUE 301 70 CONTINUE 302* 303* Print a summary of the results. 304* 305 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 306* 307 9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2, 308 $ ', ratio =', G12.5 ) 309* 310* End if DCHKTZ 311* 312 END 313