136 SUBROUTINE dqlt03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK,
145 INTEGER k, lda, lwork, m, n
148 DOUBLE PRECISION af( lda, * ), c( lda, * ), cc( lda, * ),
149 $ q( lda, * ), result( * ), rwork( * ), tau( * ),
156 DOUBLE PRECISION zero, one
157 parameter( zero = 0.0d0, one = 1.0d0 )
158 DOUBLE PRECISION rogue
159 parameter( rogue = -1.0d+10 )
162 CHARACTER side, trans
163 INTEGER info, iside, itrans,
j, mc, minmn, nc
164 DOUBLE PRECISION cnorm, eps, resid
178 INTRINSIC dble, max, min
184 COMMON / srnamc / srnamt
187 DATA iseed / 1988, 1989, 1990, 1991 /
196 IF( minmn.EQ.0 )
THEN
206 CALL
dlaset(
'Full', m, m, rogue, rogue, q, lda )
207 IF( k.GT.0 .AND. m.GT.k )
208 $ CALL
dlacpy(
'Full', m-k, k, af( 1, n-k+1 ), lda,
209 $ q( 1, m-k+1 ), lda )
211 $ CALL
dlacpy(
'Upper', k-1, k-1, af( m-k+1, n-k+2 ), lda,
212 $ q( m-k+1, m-k+2 ), lda )
217 CALL
dorgql( m, m, k, q, lda, tau( minmn-k+1 ), work, lwork,
221 IF( iside.EQ.1 )
THEN
234 CALL
dlarnv( 2, iseed, mc, c( 1,
j ) )
236 cnorm =
dlange(
'1', mc, nc, c, lda, rwork )
241 IF( itrans.EQ.1 )
THEN
249 CALL
dlacpy(
'Full', mc, nc, c, lda, cc, lda )
255 $ CALL
dormql( side, trans, mc, nc, k, af( 1, n-k+1 ), lda,
256 $ tau( minmn-k+1 ), cc, lda, work, lwork,
261 IF(
lsame( side,
'L' ) )
THEN
262 CALL
dgemm( trans,
'No transpose', mc, nc, mc, -one, q,
263 $ lda, c, lda, one, cc, lda )
265 CALL
dgemm(
'No transpose', trans, mc, nc, nc, -one, c,
266 $ lda, q, lda, one, cc, lda )
271 resid =
dlange(
'1', mc, nc, cc, lda, rwork )
272 result( ( iside-1 )*2+itrans ) = resid /
273 $ ( dble( max( 1, m ) )*cnorm*eps )
LOGICAL function lsame(CA, CB)
LSAME
subroutine dormql(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
DORMQL
subroutine dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DGEMM
subroutine dlarnv(IDIST, ISEED, N, X)
DLARNV returns a vector of random numbers from a uniform or normal distribution.
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 ...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
subroutine dorgql(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
DORGQL
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 dqlt03(M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, RWORK, RESULT)
DQLT03