116 DOUBLE PRECISION FUNCTION zqrt14( TRANS, M, N, NRHS, A, LDA, X,
126 INTEGER lda, ldx, lwork, m, n, nrhs
129 COMPLEX*16 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, dconjg, max, min
160 IF(
lsame( trans,
'N' ) )
THEN
163 IF( lwork.LT.( m+nrhs )*( n+2 ) )
THEN
164 CALL
xerbla(
'ZQRT14', 10 )
166 ELSE IF( n.LE.0 .OR. nrhs.LE.0 )
THEN
169 ELSE IF(
lsame( trans,
'C' ) )
THEN
172 IF( lwork.LT.( n+nrhs )*( m+2 ) )
THEN
173 CALL
xerbla(
'ZQRT14', 10 )
175 ELSE IF( m.LE.0 .OR. nrhs.LE.0 )
THEN
179 CALL
xerbla(
'ZQRT14', 1 )
185 CALL
zlacpy(
'All', m, n, a, lda, work, ldwork )
186 anrm =
zlange(
'M', m, n, work, ldwork, rwork )
188 $ CALL
zlascl(
'G', 0, 0, anrm, one, m, n, work, ldwork, info )
196 CALL
zlacpy(
'All', m, nrhs, x, ldx, work( n*ldwork+1 ),
198 xnrm =
zlange(
'M', m, nrhs, work( n*ldwork+1 ), ldwork,
201 $ CALL
zlascl(
'G', 0, 0, xnrm, one, m, nrhs,
202 $ work( n*ldwork+1 ), ldwork, info )
203 anrm =
zlange(
'One-norm', m, n+nrhs, work, ldwork, rwork )
207 CALL
zgeqr2( 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 ) = dconjg( x( i,
j ) )
232 xnrm =
zlange(
'M', nrhs, n, work( m+1 ), ldwork, rwork )
234 $ CALL
zlascl(
'G', 0, 0, xnrm, one, nrhs, n, work( m+1 ),
239 CALL
zgelq2( 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 zqrt14 = err / ( dble( max( m, n, nrhs ) )*
dlamch(
'Epsilon' ) )
subroutine zgeqr2(M, N, A, LDA, TAU, WORK, INFO)
ZGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm...
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
double precision function zqrt14(TRANS, M, N, NRHS, A, LDA, X, LDX, WORK, LWORK)
ZQRT14
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zlascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
logical function lsame(CA, CB)
LSAME
subroutine zgelq2(M, N, A, LDA, TAU, WORK, INFO)
ZGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm...
double precision function zlange(NORM, M, N, A, LDA, WORK)
ZLANGE 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