114 DOUBLE PRECISION FUNCTION dqrt14( TRANS, M, N, NRHS, A, LDA, X,
123 INTEGER lda, ldx, lwork, m, n, nrhs
126 DOUBLE PRECISION a( lda, * ), work( lwork ), x( ldx, * )
132 DOUBLE PRECISION zero, one
133 parameter( zero = 0.0d0, one = 1.0d0 )
137 INTEGER i, info, j, ldwork
138 DOUBLE PRECISION anrm, err, xnrm
141 DOUBLE PRECISION rwork( 1 )
152 INTRINSIC abs, dble, max, min
157 IF(
lsame( trans,
'N' ) )
THEN
160 IF( lwork.LT.( m+nrhs )*( n+2 ) )
THEN
161 CALL xerbla(
'DQRT14', 10 )
163 ELSE IF( n.LE.0 .OR. nrhs.LE.0 )
THEN
166 ELSE IF(
lsame( trans,
'T' ) )
THEN
169 IF( lwork.LT.( n+nrhs )*( m+2 ) )
THEN
170 CALL xerbla(
'DQRT14', 10 )
172 ELSE IF( m.LE.0 .OR. nrhs.LE.0 )
THEN
176 CALL xerbla(
'DQRT14', 1 )
182 CALL dlacpy(
'All', m, n, a, lda, work, ldwork )
183 anrm =
dlange(
'M', m, n, work, ldwork, rwork )
185 $
CALL dlascl(
'G', 0, 0, anrm, one, m, n, work, ldwork, info )
193 CALL dlacpy(
'All', m, nrhs, x, ldx, work( n*ldwork+1 ),
195 xnrm =
dlange(
'M', m, nrhs, work( n*ldwork+1 ), ldwork,
198 $
CALL dlascl(
'G', 0, 0, xnrm, one, m, nrhs,
199 $ work( n*ldwork+1 ), ldwork, info )
203 CALL dgeqr2( m, n+nrhs, work, ldwork,
204 $ work( ldwork*( n+nrhs )+1 ),
205 $ work( ldwork*( n+nrhs )+min( m, n+nrhs )+1 ),
212 DO 20 j = n + 1, n + nrhs
213 DO 10 i = n + 1, min( m, j )
214 err = max( err, abs( work( i+( j-1 )*m ) ) )
224 work( m+j+( i-1 )*ldwork ) = x( i, j )
228 xnrm =
dlange(
'M', nrhs, n, work( m+1 ), ldwork, rwork )
230 $
CALL dlascl(
'G', 0, 0, xnrm, one, nrhs, n, work( m+1 ),
235 CALL dgelq2( ldwork, n, work, ldwork, work( ldwork*n+1 ),
236 $ work( ldwork*( n+1 )+1 ), info )
244 err = max( err, abs( work( i+( j-1 )*ldwork ) ) )
250 dqrt14 = err / ( dble( max( m, n, nrhs ) )*
dlamch(
'Epsilon' ) )
subroutine xerbla(srname, info)
double precision function dqrt14(trans, m, n, nrhs, a, lda, x, ldx, work, lwork)
DQRT14
subroutine dgelq2(m, n, a, lda, tau, work, info)
DGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm.
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
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 ...
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