126 SUBROUTINE dqrt01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK,
135 INTEGER lda, lwork, m, n
138 DOUBLE PRECISION a( lda, * ), af( lda, * ), q( lda, * ),
139 $ r( lda, * ), result( * ), rwork( * ), tau( * ),
146 DOUBLE PRECISION zero, one
147 parameter( zero = 0.0d+0, one = 1.0d+0 )
148 DOUBLE PRECISION rogue
149 parameter( rogue = -1.0d+10 )
153 DOUBLE PRECISION anorm, eps, resid
163 INTRINSIC dble, max, min
169 COMMON / srnamc / srnamt
178 CALL
dlacpy(
'Full', m, n, a, lda, af, lda )
183 CALL
dgeqrf( m, n, af, lda, tau, work, lwork, info )
187 CALL
dlaset(
'Full', m, m, rogue, rogue, q, lda )
188 CALL
dlacpy(
'Lower', m-1, n, af( 2, 1 ), lda, q( 2, 1 ), lda )
193 CALL
dorgqr( m, m, minmn, q, lda, tau, work, lwork, info )
197 CALL
dlaset(
'Full', m, n, zero, zero, r, lda )
198 CALL
dlacpy(
'Upper', m, n, af, lda, r, lda )
202 CALL
dgemm(
'Transpose',
'No transpose', m, n, m, -one, q, lda, a,
207 anorm =
dlange(
'1', m, n, a, lda, rwork )
208 resid =
dlange(
'1', m, n, r, lda, rwork )
209 IF( anorm.GT.zero )
THEN
210 result( 1 ) = ( ( resid / dble( max( 1, m ) ) ) / anorm ) / eps
217 CALL
dlaset(
'Full', m, m, zero, one, r, lda )
218 CALL
dsyrk(
'Upper',
'Transpose', m, m, -one, q, lda, one, r,
223 resid =
dlansy(
'1',
'Upper', m, r, lda, rwork )
225 result( 2 ) = ( resid / dble( max( 1, m ) ) ) / eps
subroutine dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DGEMM
subroutine dgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGEQRF
subroutine dorgqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
DORGQR
double precision function dlange(NORM, M, N, A, LDA, WORK)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine dsyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
DSYRK
double precision function dlamch(CMACH)
DLAMCH
double precision function dlansy(NORM, UPLO, N, A, LDA, WORK)
DLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric matrix.
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 dqrt01(M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, RWORK, RESULT)
DQRT01