126 SUBROUTINE sqlt01( 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
sgeqlf( m, n, af, lda, tau, work, lwork, info )
187 CALL
slaset(
'Full', m, m, rogue, rogue, q, lda )
189 IF( n.LT.m .AND. n.GT.0 )
190 $ CALL
slacpy(
'Full', m-n, n, af, lda, q( 1, m-n+1 ), lda )
192 $ CALL
slacpy(
'Upper', n-1, n-1, af( m-n+1, 2 ), lda,
193 $ q( m-n+1, m-n+2 ), lda )
196 $ CALL
slacpy(
'Upper', m-1, m-1, af( 1, n-m+2 ), lda,
203 CALL
sorgql( m, m, minmn, q, lda, tau, work, lwork, info )
207 CALL
slaset(
'Full', m, n, zero, zero, l, lda )
210 $ CALL
slacpy(
'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
slacpy(
'Full', m, n-m, af, lda, l, lda )
216 $ CALL
slacpy(
'Lower', m, m, af( 1, n-m+1 ), lda,
217 $ l( 1, n-m+1 ), lda )
222 CALL
sgemm(
'Transpose',
'No transpose', m, n, m, -one, q, lda, a,
227 anorm = slange(
'1', m, n, a, lda, rwork )
228 resid = slange(
'1', m, n, l, lda, rwork )
229 IF( anorm.GT.zero )
THEN
230 result( 1 ) = ( ( resid /
REAL( MAX( 1, M ) ) ) / anorm ) / eps
237 CALL
slaset(
'Full', m, m, zero, one, l, lda )
238 CALL
ssyrk(
'Upper',
'Transpose', m, m, -one, q, lda, one, l,
243 resid = slansy(
'1',
'Upper', m, l, lda, rwork )
245 result( 2 ) = ( resid /
REAL( MAX( 1, M ) ) ) / eps
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 ssyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
SSYRK
subroutine sqlt01(M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK, RWORK, RESULT)
SQLT01
subroutine sgeqlf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQLF
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
subroutine sorgql(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
SORGQL