116 REAL FUNCTION cqrt14( TRANS, M, N, NRHS, A, LDA, X,
126 INTEGER lda, ldx, lwork, m, n, nrhs
129 COMPLEX a( lda, * ), work( lwork ), x( ldx, * )
136 parameter( zero = 0.0e0, one = 1.0e0 )
140 INTEGER i, info,
j, ldwork
155 INTRINSIC abs, conjg, max, min, real
160 IF(
lsame( trans,
'N' ) )
THEN
163 IF( lwork.LT.( m+nrhs )*( n+2 ) )
THEN
164 CALL
xerbla(
'CQRT14', 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(
'CQRT14', 10 )
175 ELSE IF( m.LE.0 .OR. nrhs.LE.0 )
THEN
179 CALL
xerbla(
'CQRT14', 1 )
185 CALL
clacpy(
'All', m, n, a, lda, work, ldwork )
186 anrm =
clange(
'M', m, n, work, ldwork, rwork )
188 $ CALL
clascl(
'G', 0, 0, anrm, one, m, n, work, ldwork, info )
196 CALL
clacpy(
'All', m, nrhs, x, ldx, work( n*ldwork+1 ),
198 xnrm =
clange(
'M', m, nrhs, work( n*ldwork+1 ), ldwork,
201 $ CALL
clascl(
'G', 0, 0, xnrm, one, m, nrhs,
202 $ work( n*ldwork+1 ), ldwork, info )
203 anrm =
clange(
'One-norm', m, n+nrhs, work, ldwork, rwork )
207 CALL
cgeqr2( 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 ) = conjg( x( i,
j ) )
232 xnrm =
clange(
'M', nrhs, n, work( m+1 ), ldwork, rwork )
234 $ CALL
clascl(
'G', 0, 0, xnrm, one, nrhs, n, work( m+1 ),
239 CALL
cgelq2( 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 cqrt14 = err / (
REAL( MAX( M, N, NRHS ) )*
slamch(
'Epsilon' ) )
real function clange(NORM, M, N, A, LDA, WORK)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
real function cqrt14(TRANS, M, N, NRHS, A, LDA, X, LDX, WORK, LWORK)
CQRT14
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cgeqr2(M, N, A, LDA, TAU, WORK, INFO)
CGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm...
logical function lsame(CA, CB)
LSAME
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
real function slamch(CMACH)
SLAMCH
subroutine clascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
CLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine cgelq2(M, N, A, LDA, TAU, WORK, INFO)
CGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm...