126 SUBROUTINE srqt01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK,
135 INTEGER LDA, LWORK, M, N
138 REAL A( lda, * ), AF( lda, * ), Q( lda, * ),
139 $ r( 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 sgerqf( m, n, af, lda, tau, work, lwork, info )
187 CALL slaset(
'Full', n, n, rogue, rogue, q, lda )
189 IF( m.GT.0 .AND. m.LT.n )
190 $
CALL slacpy(
'Full', m, n-m, af, lda, q( n-m+1, 1 ), lda )
192 $
CALL slacpy(
'Lower', m-1, m-1, af( 2, n-m+1 ), lda,
193 $ q( n-m+2, n-m+1 ), lda )
196 $
CALL slacpy(
'Lower', n-1, n-1, af( m-n+2, 1 ), lda,
203 CALL sorgrq( n, n, minmn, q, lda, tau, work, lwork, info )
207 CALL slaset(
'Full', m, n, zero, zero, r, lda )
210 $
CALL slacpy(
'Upper', m, m, af( 1, n-m+1 ), lda,
211 $ r( 1, n-m+1 ), lda )
213 IF( m.GT.n .AND. n.GT.0 )
214 $
CALL slacpy(
'Full', m-n, n, af, lda, r, lda )
216 $
CALL slacpy(
'Upper', n, n, af( m-n+1, 1 ), lda,
217 $ r( m-n+1, 1 ), lda )
222 CALL sgemm(
'No transpose',
'Transpose', m, n, n, -one, a, lda, q,
227 anorm = slange(
'1', m, n, a, lda, rwork )
228 resid = slange(
'1', m, n, r, lda, rwork )
229 IF( anorm.GT.zero )
THEN
230 result( 1 ) = ( ( resid /
REAL( MAX( 1, N ) ) ) / anorm ) / eps
237 CALL slaset(
'Full', n, n, zero, one, r, lda )
238 CALL ssyrk(
'Upper',
'No transpose', n, n, -one, q, lda, one, r,
243 resid = slansy(
'1',
'Upper', n, r, lda, rwork )
245 result( 2 ) = ( resid /
REAL( MAX( 1, N ) ) ) / eps
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 srqt01(M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, RWORK, RESULT)
SRQT01
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 sgerqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGERQF
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