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
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 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 dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dqrt01(M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, RWORK, RESULT)
DQRT01
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 dgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGEQRF