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, SMLNUM
183 EXTERNAL lsame, clange, slamch
189 INTRINSIC cmplx, max, real
195 IF( lsame( trans,
'N' ) )
THEN
198 ELSE IF( lsame( trans,
'C' ) )
THEN
202 CALL xerbla(
'CQRT17', 1 )
206 IF( lwork.LT.ncols*nrhs )
THEN
207 CALL xerbla(
'CQRT17', 13 )
211 IF( m.LE.0 .OR. n.LE.0 .OR. nrhs.LE.0 )
214 norma = clange(
'One-norm', m, n, a, lda, rwork )
215 smlnum = slamch(
'Safe minimum' ) / slamch(
'Precision' )
216 bignum = one / smlnum
221 CALL clacpy(
'All', nrows, nrhs, b, ldb, c, ldb )
222 CALL cgemm( trans,
'No transpose', nrows, nrhs, ncols,
223 $ cmplx( -one ), a, lda, x, ldx, cmplx( one ), c, ldb )
224 normrs = clange(
'Max', nrows, nrhs, c, ldb, rwork )
225 IF( normrs.GT.smlnum )
THEN
227 CALL clascl(
'General', 0, 0, normrs, one, nrows, nrhs, c, ldb,
233 CALL cgemm(
'Conjugate transpose', trans, nrhs, ncols, nrows,
234 $ cmplx( one ), c, ldb, a, lda, cmplx( zero ), work,
239 err = clange(
'One-norm', nrhs, ncols, work, nrhs, rwork )
246 IF( iresid.EQ.1 )
THEN
247 normb = clange(
'One-norm', nrows, nrhs, b, ldb, rwork )
255 cqrt17 = err / ( slamch(
'Epsilon' )*
REAL( MAX( M, N, NRHS ) ) )
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 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 cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM