114 DOUBLE PRECISION FUNCTION zqrt14( TRANS, M, N, NRHS, A, LDA, X,
123 INTEGER lda, ldx, lwork, m, n, nrhs
126 COMPLEX*16 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, dconjg, max, min
157 IF(
lsame( trans,
'N' ) )
THEN
160 IF( lwork.LT.( m+nrhs )*( n+2 ) )
THEN
161 CALL xerbla(
'ZQRT14', 10 )
163 ELSE IF( n.LE.0 .OR. nrhs.LE.0 )
THEN
166 ELSE IF(
lsame( trans,
'C' ) )
THEN
169 IF( lwork.LT.( n+nrhs )*( m+2 ) )
THEN
170 CALL xerbla(
'ZQRT14', 10 )
172 ELSE IF( m.LE.0 .OR. nrhs.LE.0 )
THEN
176 CALL xerbla(
'ZQRT14', 1 )
182 CALL zlacpy(
'All', m, n, a, lda, work, ldwork )
183 anrm =
zlange(
'M', m, n, work, ldwork, rwork )
185 $
CALL zlascl(
'G', 0, 0, anrm, one, m, n, work, ldwork, info )
193 CALL zlacpy(
'All', m, nrhs, x, ldx, work( n*ldwork+1 ),
195 xnrm =
zlange(
'M', m, nrhs, work( n*ldwork+1 ), ldwork,
198 $
CALL zlascl(
'G', 0, 0, xnrm, one, m, nrhs,
199 $ work( n*ldwork+1 ), ldwork, info )
203 CALL zgeqr2( 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 ) = dconjg( x( i, j ) )
228 xnrm =
zlange(
'M', nrhs, n, work( m+1 ), ldwork, rwork )
230 $
CALL zlascl(
'G', 0, 0, xnrm, one, nrhs, n, work( m+1 ),
235 CALL zgelq2( 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 zqrt14 = err / ( dble( max( m, n, nrhs ) )*
dlamch(
'Epsilon' ) )
double precision function dlamch(CMACH)
DLAMCH
subroutine xerbla(SRNAME, INFO)
XERBLA
logical function lsame(CA, CB)
LSAME
double precision function zqrt14(TRANS, M, N, NRHS, A, LDA, X, LDX, WORK, LWORK)
ZQRT14
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 ...
subroutine zgelq2(M, N, A, LDA, TAU, WORK, INFO)
ZGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm.
subroutine zgeqr2(M, N, A, LDA, TAU, WORK, INFO)
ZGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
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.
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.