126 SUBROUTINE dqrt01p( 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
156 DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
157 EXTERNAL dlamch, dlange, dlansy
163 INTRINSIC dble, max, min
169 COMMON / srnamc / srnamt
174 eps = dlamch(
'Epsilon' )
178 CALL
dlacpy(
'Full', m, n, a, lda, af, lda )
183 CALL
dgeqrfp( 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 dqrt01p(M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, RWORK, RESULT)
DQRT01P
subroutine dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DGEMM
subroutine dorgqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
DORGQR
subroutine dsyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
DSYRK
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 dgeqrfp(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGEQRFP