126 SUBROUTINE slqt01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK,
135 INTEGER LDA, LWORK, M, N
138 REAL A( lda, * ), AF( lda, * ), L( lda, * ),
139 $ q( lda, * ), result( * ), rwork( * ), tau( * ),
147 parameter ( zero = 0.0e+0, one = 1.0e+0 )
149 parameter ( rogue = -1.0e+10 )
153 REAL ANORM, EPS, RESID
156 REAL SLAMCH, SLANGE, SLANSY
157 EXTERNAL slamch, slange, slansy
163 INTRINSIC max, min, real
169 COMMON / srnamc / srnamt
174 eps = slamch(
'Epsilon' )
178 CALL slacpy(
'Full', m, n, a, lda, af, lda )
183 CALL sgelqf( m, n, af, lda, tau, work, lwork, info )
187 CALL slaset(
'Full', n, n, rogue, rogue, q, lda )
189 $
CALL slacpy(
'Upper', m, n-1, af( 1, 2 ), lda, q( 1, 2 ), lda )
194 CALL sorglq( n, n, minmn, q, lda, tau, work, lwork, info )
198 CALL slaset(
'Full', m, n, zero, zero, l, lda )
199 CALL slacpy(
'Lower', m, n, af, lda, l, lda )
203 CALL sgemm(
'No transpose',
'Transpose', m, n, n, -one, a, lda, q,
208 anorm = slange(
'1', m, n, a, lda, rwork )
209 resid = slange(
'1', m, n, l, lda, rwork )
210 IF( anorm.GT.zero )
THEN
211 result( 1 ) = ( ( resid /
REAL( MAX( 1, N ) ) ) / anorm ) / eps
218 CALL slaset(
'Full', n, n, zero, one, l, lda )
219 CALL ssyrk(
'Upper',
'No transpose', n, n, -one, q, lda, one, l,
224 resid = slansy(
'1',
'Upper', n, l, lda, rwork )
226 result( 2 ) = ( resid /
REAL( MAX( 1, N ) ) ) / eps
subroutine slqt01(M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK, RWORK, RESULT)
SLQT01
subroutine ssyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
SSYRK
subroutine sorglq(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
SORGLQ
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine sgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGELQF