116 DOUBLE PRECISION FUNCTION dqrt14( TRANS, M, N, NRHS, A, LDA, X,
126 INTEGER lda, ldx, lwork, m, n, nrhs
129 DOUBLE PRECISION a( lda, * ), work( lwork ),
x( ldx, * )
135 DOUBLE PRECISION zero, one
136 parameter( zero = 0.0d0, one = 1.0d0 )
140 INTEGER i, info,
j, ldwork
141 DOUBLE PRECISION anrm, err, xnrm
144 DOUBLE PRECISION rwork( 1 )
155 INTRINSIC abs, dble, max, min
160 IF(
lsame( trans,
'N' ) )
THEN
163 IF( lwork.LT.( m+nrhs )*( n+2 ) )
THEN
164 CALL
xerbla(
'DQRT14', 10 )
166 ELSE IF( n.LE.0 .OR. nrhs.LE.0 )
THEN
169 ELSE IF(
lsame( trans,
'T' ) )
THEN
172 IF( lwork.LT.( n+nrhs )*( m+2 ) )
THEN
173 CALL
xerbla(
'DQRT14', 10 )
175 ELSE IF( m.LE.0 .OR. nrhs.LE.0 )
THEN
179 CALL
xerbla(
'DQRT14', 1 )
185 CALL
dlacpy(
'All', m, n, a, lda, work, ldwork )
186 anrm =
dlange(
'M', m, n, work, ldwork, rwork )
188 $ CALL
dlascl(
'G', 0, 0, anrm, one, m, n, work, ldwork, info )
196 CALL
dlacpy(
'All', m, nrhs,
x, ldx, work( n*ldwork+1 ),
198 xnrm =
dlange(
'M', m, nrhs, work( n*ldwork+1 ), ldwork,
201 $ CALL
dlascl(
'G', 0, 0, xnrm, one, m, nrhs,
202 $ work( n*ldwork+1 ), ldwork, info )
203 anrm =
dlange(
'One-norm', m, n+nrhs, work, ldwork, rwork )
207 CALL
dgeqr2( m, n+nrhs, work, ldwork,
208 $ work( ldwork*( n+nrhs )+1 ),
209 $ work( ldwork*( n+nrhs )+min( m, n+nrhs )+1 ),
216 DO 20
j = n + 1, n + nrhs
217 DO 10 i = n + 1, min( m,
j )
218 err = max( err, abs( work( i+(
j-1 )*m ) ) )
228 work( m+
j+( i-1 )*ldwork ) =
x( i,
j )
232 xnrm =
dlange(
'M', nrhs, n, work( m+1 ), ldwork, rwork )
234 $ CALL
dlascl(
'G', 0, 0, xnrm, one, nrhs, n, work( m+1 ),
239 CALL
dgelq2( ldwork, n, work, ldwork, work( ldwork*n+1 ),
240 $ work( ldwork*( n+1 )+1 ), info )
248 err = max( err, abs( work( i+(
j-1 )*ldwork ) ) )
254 dqrt14 = err / ( dble( max( m, n, nrhs ) )*
dlamch(
'Epsilon' ) )
LOGICAL function lsame(CA, CB)
LSAME
subroutine dgelq2(M, N, A, LDA, TAU, WORK, INFO)
DGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm...
DOUBLE PRECISION function dqrt14(TRANS, M, N, NRHS, A, LDA, X, LDX, WORK, LWORK)
DQRT14
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dlascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
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 dgeqr2(M, N, A, LDA, TAU, WORK, INFO)
DGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm...
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