126 SUBROUTINE sqrt01p( 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
sgeqrfp( m, n, af, lda, tau, work, lwork, info )
187 CALL
slaset(
'Full', m, m, rogue, rogue, q, lda )
188 CALL
slacpy(
'Lower', m-1, n, af( 2, 1 ), lda, q( 2, 1 ), lda )
193 CALL
sorgqr( m, m, minmn, q, lda, tau, work, lwork, info )
197 CALL
slaset(
'Full', m, n, zero, zero, r, lda )
198 CALL
slacpy(
'Upper', m, n, af, lda, r, lda )
202 CALL
sgemm(
'Transpose',
'No transpose', m, n, m, -one, q, lda, a,
207 anorm = slange(
'1', m, n, a, lda, rwork )
208 resid = slange(
'1', m, n, r, lda, rwork )
209 IF( anorm.GT.zero )
THEN
210 result( 1 ) = ( ( resid /
REAL( MAX( 1, M ) ) ) / anorm ) / eps
217 CALL
slaset(
'Full', m, m, zero, one, r, lda )
218 CALL
ssyrk(
'Upper',
'Transpose', m, m, -one, q, lda, one, r,
223 resid = slansy(
'1',
'Upper', m, r, lda, rwork )
225 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 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 sgeqrfp(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQRFP
subroutine sqrt01p(M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, RWORK, RESULT)
SQRT01P
subroutine sorgqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
SORGQR