150 REAL FUNCTION cqrt17( TRANS, IRESID, M, N, NRHS, A,
151 $ lda,
x, ldx,
b, ldb, c, work, lwork )
160 INTEGER iresid, lda, ldb, ldx, lwork, m, n, nrhs
163 COMPLEX a( lda, * ),
b( ldb, * ), c( ldb, * ),
164 $ work( lwork ),
x( ldx, * )
171 parameter( zero = 0.0e0, one = 1.0e0 )
174 INTEGER info, iscl, ncols, nrows
175 REAL bignum, err, norma, normb, normrs, normx,
190 INTRINSIC cmplx, max, real
196 IF(
lsame( trans,
'N' ) )
THEN
199 ELSE IF(
lsame( trans,
'C' ) )
THEN
203 CALL
xerbla(
'CQRT17', 1 )
207 IF( lwork.LT.ncols*nrhs )
THEN
208 CALL
xerbla(
'CQRT17', 13 )
212 IF( m.LE.0 .OR. n.LE.0 .OR. nrhs.LE.0 )
215 norma =
clange(
'One-norm', m, n, a, lda, rwork )
216 smlnum =
slamch(
'Safe minimum' ) /
slamch(
'Precision' )
217 bignum = one / smlnum
222 CALL
clacpy(
'All', nrows, nrhs,
b, ldb, c, ldb )
223 CALL
cgemm( trans,
'No transpose', nrows, nrhs, ncols,
224 $ cmplx( -one ), a, lda,
x, ldx, cmplx( one ), c, ldb )
225 normrs =
clange(
'Max', nrows, nrhs, c, ldb, rwork )
226 IF( normrs.GT.smlnum )
THEN
228 CALL
clascl(
'General', 0, 0, normrs, one, nrows, nrhs, c, ldb,
234 CALL
cgemm(
'Conjugate transpose', trans, nrhs, ncols, nrows,
235 $ cmplx( one ), c, ldb, a, lda, cmplx( zero ), work,
240 err =
clange(
'One-norm', nrhs, ncols, work, nrhs, rwork )
247 IF( iresid.EQ.1 )
THEN
248 normb =
clange(
'One-norm', nrows, nrhs,
b, ldb, rwork )
252 normx =
clange(
'One-norm', ncols, nrhs,
x, ldx, rwork )
257 cqrt17 = err / (
slamch(
'Epsilon' )*
REAL( MAX( M, N, NRHS ) ) )
LOGICAL function lsame(CA, CB)
LSAME
REAL function slamch(CMACH)
SLAMCH
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
REAL function cqrt17(TRANS, IRESID, M, N, NRHS, A, LDA, X, LDX, B, LDB, C, WORK, LWORK)
CQRT17
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 ...
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
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.
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM