133 SUBROUTINE clqt02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK,
141 INTEGER K, LDA, LWORK, M, N
144 REAL RESULT( * ), RWORK( * )
145 COMPLEX A( LDA, * ), AF( LDA, * ), L( LDA, * ),
146 $ q( lda, * ), tau( * ), work( lwork )
153 parameter( zero = 0.0e+0, one = 1.0e+0 )
155 parameter( rogue = ( -1.0e+10, -1.0e+10 ) )
159 REAL ANORM, EPS, RESID
162 REAL CLANGE, CLANSY, SLAMCH
163 EXTERNAL clange, clansy, slamch
169 INTRINSIC cmplx, max, real
175 COMMON / srnamc / srnamt
179 eps = slamch(
'Epsilon' )
183 CALL claset(
'Full', m, n, rogue, rogue, q, lda )
184 CALL clacpy(
'Upper', k, n-1, af( 1, 2 ), lda, q( 1, 2 ), lda )
189 CALL cunglq( m, n, k, q, lda, tau, work, lwork, info )
193 CALL claset(
'Full', k, m, cmplx( zero ), cmplx( zero ), l, lda )
194 CALL clacpy(
'Lower', k, m, af, lda, l, lda )
198 CALL cgemm(
'No transpose',
'Conjugate transpose', k, m, n,
199 $ cmplx( -one ), a, lda, q, lda, cmplx( one ), l, lda )
203 anorm = clange(
'1', k, n, a, lda, rwork )
204 resid = clange(
'1', k, m, l, lda, rwork )
205 IF( anorm.GT.zero )
THEN
206 result( 1 ) = ( ( resid / real( max( 1, n ) ) ) / anorm ) / eps
213 CALL claset(
'Full', m, m, cmplx( zero ), cmplx( one ), l, lda )
214 CALL cherk(
'Upper',
'No transpose', m, n, -one, q, lda, one, l,
219 resid = clansy(
'1',
'Upper', m, l, lda, rwork )
221 result( 2 ) = ( resid / real( max( 1, n ) ) ) / eps
subroutine clqt02(m, n, k, a, af, q, l, lda, tau, work, lwork, rwork, result)
CLQT02
subroutine cgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
CGEMM
subroutine cherk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
CHERK
subroutine clacpy(uplo, m, n, a, lda, b, ldb)
CLACPY copies all or part of one two-dimensional array to another.
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 cunglq(m, n, k, a, lda, tau, work, lwork, info)
CUNGLQ