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.
real function cqrt17(TRANS, IRESID, M, N, NRHS, A, LDA, X, LDX, B, LDB, C, WORK, LWORK)
CQRT17
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM