135 SUBROUTINE cqrt02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK,
144 INTEGER K, LDA, LWORK, M, N
147 REAL RESULT( * ), RWORK( * )
148 COMPLEX A( lda, * ), AF( lda, * ), Q( lda, * ),
149 $ r( lda, * ), tau( * ), work( lwork )
156 parameter ( zero = 0.0e+0, one = 1.0e+0 )
158 parameter ( rogue = ( -1.0e+10, -1.0e+10 ) )
162 REAL ANORM, EPS, RESID
165 REAL CLANGE, CLANSY, SLAMCH
166 EXTERNAL clange, clansy, slamch
172 INTRINSIC cmplx, max, real
178 COMMON / srnamc / srnamt
182 eps = slamch(
'Epsilon' )
186 CALL claset(
'Full', m, n, rogue, rogue, q, lda )
187 CALL clacpy(
'Lower', m-1, k, af( 2, 1 ), lda, q( 2, 1 ), lda )
192 CALL cungqr( m, n, k, q, lda, tau, work, lwork, info )
196 CALL claset(
'Full', n, k, cmplx( zero ), cmplx( zero ), r, lda )
197 CALL clacpy(
'Upper', n, k, af, lda, r, lda )
201 CALL cgemm(
'Conjugate transpose',
'No transpose', n, k, m,
202 $ cmplx( -one ), q, lda, a, lda, cmplx( one ), r, lda )
206 anorm = clange(
'1', m, k, a, lda, rwork )
207 resid = clange(
'1', n, k, r, lda, rwork )
208 IF( anorm.GT.zero )
THEN
209 result( 1 ) = ( ( resid /
REAL( MAX( 1, M ) ) ) / anorm ) / eps
216 CALL claset(
'Full', n, n, cmplx( zero ), cmplx( one ), r, lda )
217 CALL cherk(
'Upper',
'Conjugate transpose', n, m, -one, q, lda,
222 resid = clansy(
'1',
'Upper', n, r, lda, rwork )
224 result( 2 ) = ( resid /
REAL( MAX( 1, M ) ) ) / eps
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 cungqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
CUNGQR
subroutine cqrt02(M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, RWORK, RESULT)
CQRT02
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 cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM