136 SUBROUTINE srqt02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK,
145 INTEGER K, LDA, LWORK, M, N
148 REAL A( lda, * ), AF( lda, * ), Q( lda, * ),
149 $ r( lda, * ), result( * ), rwork( * ), tau( * ),
157 parameter ( zero = 0.0e+0, one = 1.0e+0 )
159 parameter ( rogue = -1.0e+10 )
163 REAL ANORM, EPS, RESID
166 REAL SLAMCH, SLANGE, SLANSY
167 EXTERNAL slamch, slange, slansy
179 COMMON / srnamc / srnamt
185 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 )
THEN
191 eps = slamch(
'Epsilon' )
195 CALL slaset(
'Full', m, n, rogue, rogue, q, lda )
197 $
CALL slacpy(
'Full', k, n-k, af( m-k+1, 1 ), lda,
198 $ q( m-k+1, 1 ), lda )
200 $
CALL slacpy(
'Lower', k-1, k-1, af( m-k+2, n-k+1 ), lda,
201 $ q( m-k+2, n-k+1 ), lda )
206 CALL sorgrq( m, n, k, q, lda, tau( m-k+1 ), work, lwork, info )
210 CALL slaset(
'Full', k, m, zero, zero, r( m-k+1, n-m+1 ), lda )
211 CALL slacpy(
'Upper', k, k, af( m-k+1, n-k+1 ), lda,
212 $ r( m-k+1, n-k+1 ), lda )
216 CALL sgemm(
'No transpose',
'Transpose', k, m, n, -one,
217 $ a( m-k+1, 1 ), lda, q, lda, one, r( m-k+1, n-m+1 ),
222 anorm = slange(
'1', k, n, a( m-k+1, 1 ), lda, rwork )
223 resid = slange(
'1', k, m, r( m-k+1, n-m+1 ), lda, rwork )
224 IF( anorm.GT.zero )
THEN
225 result( 1 ) = ( ( resid /
REAL( MAX( 1, N ) ) ) / anorm ) / eps
232 CALL slaset(
'Full', m, m, zero, one, r, lda )
233 CALL ssyrk(
'Upper',
'No transpose', m, n, -one, q, lda, one, r,
238 resid = slansy(
'1',
'Upper', m, r, lda, rwork )
240 result( 2 ) = ( resid /
REAL( MAX( 1, N ) ) ) / eps
subroutine srqt02(M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, RWORK, RESULT)
SRQT02
subroutine ssyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
SSYRK
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 sorgrq(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
SORGRQ