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,
184 EXTERNAL lsame, clange, slamch
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 ) ) )
subroutine xerbla(SRNAME, INFO)
XERBLA
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