150 DOUBLE PRECISION FUNCTION zqrt17( 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*16 A( lda, * ), B( ldb, * ), C( ldb, * ),
164 $ work( lwork ), x( ldx, * )
170 DOUBLE PRECISION ZERO, ONE
171 parameter( zero = 0.0d0, one = 1.0d0 )
174 INTEGER INFO, ISCL, NCOLS, NROWS
175 DOUBLE PRECISION BIGNUM, ERR, NORMA, NORMB, NORMRS, NORMX,
179 DOUBLE PRECISION RWORK( 1 )
183 DOUBLE PRECISION DLAMCH, ZLANGE
184 EXTERNAL lsame, dlamch, zlange
190 INTRINSIC dble, dcmplx, max
196 IF( lsame( trans,
'N' ) )
THEN
199 ELSE IF( lsame( trans,
'C' ) )
THEN
203 CALL
xerbla(
'ZQRT17', 1 )
207 IF( lwork.LT.ncols*nrhs )
THEN
208 CALL
xerbla(
'ZQRT17', 13 )
212 IF( m.LE.0 .OR. n.LE.0 .OR. nrhs.LE.0 )
215 norma = zlange(
'One-norm', m, n, a, lda, rwork )
216 smlnum = dlamch(
'Safe minimum' ) / dlamch(
'Precision' )
217 bignum = one / smlnum
222 CALL
zlacpy(
'All', nrows, nrhs, b, ldb, c, ldb )
223 CALL
zgemm( trans,
'No transpose', nrows, nrhs, ncols,
224 $ dcmplx( -one ), a, lda, x, ldx, dcmplx( one ), c,
226 normrs = zlange(
'Max', nrows, nrhs, c, ldb, rwork )
227 IF( normrs.GT.smlnum )
THEN
229 CALL
zlascl(
'General', 0, 0, normrs, one, nrows, nrhs, c, ldb,
235 CALL
zgemm(
'Conjugate transpose', trans, nrhs, ncols, nrows,
236 $ dcmplx( one ), c, ldb, a, lda, dcmplx( zero ), work,
241 err = zlange(
'One-norm', nrhs, ncols, work, nrhs, rwork )
248 IF( iresid.EQ.1 )
THEN
249 normb = zlange(
'One-norm', nrows, nrhs, b, ldb, rwork )
253 normx = zlange(
'One-norm', ncols, nrhs, x, ldx, rwork )
258 zqrt17 = err / ( dlamch(
'Epsilon' )*dble( max( m, n, nrhs ) ) )
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZGEMM
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zlascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.