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' ) )
subroutine dgelq2(M, N, A, LDA, TAU, WORK, INFO)
DGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm...
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.
logical function lsame(CA, CB)
LSAME
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 ...
double precision function dlamch(CMACH)
DLAMCH
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 dqrt14(TRANS, M, N, NRHS, A, LDA, X, LDX, WORK, LWORK)
DQRT14