137 SUBROUTINE cchktz( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A,
138 $ copya, s, tau, work, rwork, nout )
152 INTEGER MVAL( * ), NVAL( * )
153 REAL S( * ), RWORK( * )
154 COMPLEX A( * ), COPYA( * ), TAU( * ), WORK( * )
161 parameter( ntypes = 3 )
163 parameter( ntests = 6 )
165 parameter( one = 1.0e0, zero = 0.0e0 )
169 INTEGER I, IM, IMODE, IN, INFO, K, LDA, LWORK, M,
170 $ mnmin, mode, n, nerrs, nfail, nrun
174 INTEGER ISEED( 4 ), ISEEDY( 4 )
175 REAL RESULT( ntests )
178 REAL CQRT12, CRZT01, CRZT02, CTZT01, CTZT02, SLAMCH
179 EXTERNAL cqrt12, crzt01, crzt02, ctzt01, ctzt02, slamch
186 INTRINSIC cmplx, max, min
191 INTEGER INFOT, IOUNIT
194 COMMON / infoc / infot, iounit, ok, lerr
195 COMMON / srnamc / srnamt
198 DATA iseedy / 1988, 1989, 1990, 1991 /
204 path( 1: 1 ) =
'Complex precision'
210 iseed( i ) = iseedy( i )
212 eps = slamch(
'Epsilon' )
217 $
CALL cerrtz( path, nout )
233 lwork = max( 1, n*n+4*m+n )
236 DO 50 imode = 1, ntypes
237 IF( .NOT.dotype( imode ) )
253 CALL claset(
'Full', m, n, cmplx( zero ),
254 $ cmplx( zero ), a, lda )
259 CALL clatms( m, n,
'Uniform', iseed,
260 $
'Nonsymmetric', s, imode,
261 $ one / eps, one, m, n,
'No packing', a,
263 CALL cgeqr2( m, n, a, lda, work, work( mnmin+1 ),
265 CALL claset(
'Lower', m-1, n, cmplx( zero ),
266 $ cmplx( zero ), a( 2 ), lda )
267 CALL slaord(
'Decreasing', mnmin, s, 1 )
272 CALL clacpy(
'All', m, n, a, lda, copya, lda )
278 CALL ctzrqf( m, n, a, lda, tau, info )
282 result( 1 ) = cqrt12( m, m, a, lda, s, work,
287 result( 2 ) = ctzt01( m, n, copya, a, lda, tau, work,
292 result( 3 ) = ctzt02( m, n, a, lda, tau, work, lwork )
300 CALL claset(
'Full', m, n, cmplx( zero ),
301 $ cmplx( zero ), a, lda )
306 CALL clatms( m, n,
'Uniform', iseed,
307 $
'Nonsymmetric', s, imode,
308 $ one / eps, one, m, n,
'No packing', a,
310 CALL cgeqr2( m, n, a, lda, work, work( mnmin+1 ),
312 CALL claset(
'Lower', m-1, n, cmplx( zero ),
313 $ cmplx( zero ), a( 2 ), lda )
314 CALL slaord(
'Decreasing', mnmin, s, 1 )
319 CALL clacpy(
'All', m, n, a, lda, copya, lda )
325 CALL ctzrzf( m, n, a, lda, tau, work, lwork, info )
329 result( 4 ) = cqrt12( m, m, a, lda, s, work,
334 result( 5 ) = crzt01( m, n, copya, a, lda, tau, work,
339 result( 6 ) = crzt02( m, n, a, lda, tau, work, lwork )
345 IF( result( k ).GE.thresh )
THEN
346 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
347 $
CALL alahd( nout, path )
348 WRITE( nout, fmt = 9999 )m, n, imode, k,
361 CALL alasum( path, nout, nfail, nrun, nerrs )
363 9999
FORMAT(
' M =', i5,
', N =', i5,
', type ', i2,
', test ', i2,
364 $
', ratio =', g12.5 )
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine cerrtz(PATH, NUNIT)
CERRTZ
subroutine ctzrqf(M, N, A, LDA, TAU, INFO)
CTZRQF
subroutine cgeqr2(M, N, A, LDA, TAU, WORK, INFO)
CGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm...
subroutine cchktz(DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, COPYA, S, TAU, WORK, RWORK, NOUT)
CCHKTZ
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine slaord(JOB, N, X, INCX)
SLAORD
subroutine ctzrzf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
CTZRZF