135 SUBROUTINE dqrt02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK,
144 INTEGER K, LDA, LWORK, M, N
147 DOUBLE PRECISION A( lda, * ), AF( lda, * ), Q( lda, * ),
148 $ r( lda, * ), result( * ), rwork( * ), tau( * ),
155 DOUBLE PRECISION ZERO, ONE
156 parameter ( zero = 0.0d+0, one = 1.0d+0 )
157 DOUBLE PRECISION ROGUE
158 parameter ( rogue = -1.0d+10 )
162 DOUBLE PRECISION ANORM, EPS, RESID
165 DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
166 EXTERNAL dlamch, dlange, dlansy
178 COMMON / srnamc / srnamt
182 eps = dlamch(
'Epsilon' )
186 CALL dlaset(
'Full', m, n, rogue, rogue, q, lda )
187 CALL dlacpy(
'Lower', m-1, k, af( 2, 1 ), lda, q( 2, 1 ), lda )
192 CALL dorgqr( m, n, k, q, lda, tau, work, lwork, info )
196 CALL dlaset(
'Full', n, k, zero, zero, r, lda )
197 CALL dlacpy(
'Upper', n, k, af, lda, r, lda )
201 CALL dgemm(
'Transpose',
'No transpose', n, k, m, -one, q, lda, a,
206 anorm = dlange(
'1', m, k, a, lda, rwork )
207 resid = dlange(
'1', n, k, r, lda, rwork )
208 IF( anorm.GT.zero )
THEN
209 result( 1 ) = ( ( resid / dble( max( 1, m ) ) ) / anorm ) / eps
216 CALL dlaset(
'Full', n, n, zero, one, r, lda )
217 CALL dsyrk(
'Upper',
'Transpose', n, m, -one, q, lda, one, r,
222 resid = dlansy(
'1',
'Upper', n, r, lda, rwork )
224 result( 2 ) = ( resid / dble( max( 1, m ) ) ) / eps
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DGEMM
subroutine dsyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
DSYRK
subroutine dorgqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
DORGQR
subroutine dqrt02(M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, RWORK, RESULT)
DQRT02