126 SUBROUTINE cqlt01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK,
135 INTEGER LDA, LWORK, M, N
138 REAL RESULT( * ), RWORK( * )
139 COMPLEX A( lda, * ), AF( lda, * ), L( lda, * ),
140 $ q( lda, * ), tau( * ), work( lwork )
147 parameter ( zero = 0.0e+0, one = 1.0e+0 )
149 parameter ( rogue = ( -1.0e+10, -1.0e+10 ) )
153 REAL ANORM, EPS, RESID
156 REAL CLANGE, CLANSY, SLAMCH
157 EXTERNAL clange, clansy, slamch
163 INTRINSIC cmplx, max, min, real
169 COMMON / srnamc / srnamt
174 eps = slamch(
'Epsilon' )
178 CALL clacpy(
'Full', m, n, a, lda, af, lda )
183 CALL cgeqlf( m, n, af, lda, tau, work, lwork, info )
187 CALL claset(
'Full', m, m, rogue, rogue, q, lda )
189 IF( n.LT.m .AND. n.GT.0 )
190 $
CALL clacpy(
'Full', m-n, n, af, lda, q( 1, m-n+1 ), lda )
192 $
CALL clacpy(
'Upper', n-1, n-1, af( m-n+1, 2 ), lda,
193 $ q( m-n+1, m-n+2 ), lda )
196 $
CALL clacpy(
'Upper', m-1, m-1, af( 1, n-m+2 ), lda,
203 CALL cungql( m, m, minmn, q, lda, tau, work, lwork, info )
207 CALL claset(
'Full', m, n, cmplx( zero ), cmplx( zero ), l, lda )
210 $
CALL clacpy(
'Lower', n, n, af( m-n+1, 1 ), lda,
211 $ l( m-n+1, 1 ), lda )
213 IF( n.GT.m .AND. m.GT.0 )
214 $
CALL clacpy(
'Full', m, n-m, af, lda, l, lda )
216 $
CALL clacpy(
'Lower', m, m, af( 1, n-m+1 ), lda,
217 $ l( 1, n-m+1 ), lda )
222 CALL cgemm(
'Conjugate transpose',
'No transpose', m, n, m,
223 $ cmplx( -one ), q, lda, a, lda, cmplx( one ), l, lda )
227 anorm = clange(
'1', m, n, a, lda, rwork )
228 resid = clange(
'1', m, n, l, lda, rwork )
229 IF( anorm.GT.zero )
THEN
230 result( 1 ) = ( ( resid /
REAL( MAX( 1, M ) ) ) / anorm ) / eps
237 CALL claset(
'Full', m, m, cmplx( zero ), cmplx( one ), l, lda )
238 CALL cherk(
'Upper',
'Conjugate transpose', m, m, -one, q, lda,
243 resid = clansy(
'1',
'Upper', m, l, lda, rwork )
245 result( 2 ) = ( resid /
REAL( MAX( 1, M ) ) ) / eps
subroutine cungql(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
CUNGQL
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 cqlt01(M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK, RWORK, RESULT)
CQLT01
subroutine cgeqlf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
CGEQLF
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