150 DOUBLE PRECISION FUNCTION dqrt17( 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 DOUBLE PRECISION 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, SMLNUM
178 DOUBLE PRECISION RWORK( 1 )
182 DOUBLE PRECISION DLAMCH, DLANGE
183 EXTERNAL lsame, dlamch, dlange
195 IF( lsame( trans,
'N' ) )
THEN
198 ELSE IF( lsame( trans,
'T' ) )
THEN
202 CALL xerbla(
'DQRT17', 1 )
206 IF( lwork.LT.ncols*nrhs )
THEN
207 CALL xerbla(
'DQRT17', 13 )
211 IF( m.LE.0 .OR. n.LE.0 .OR. nrhs.LE.0 )
THEN
215 norma = dlange(
'One-norm', m, n, a, lda, rwork )
216 smlnum = dlamch(
'Safe minimum' ) / dlamch(
'Precision' )
217 bignum = one / smlnum
222 CALL dlacpy(
'All', nrows, nrhs, b, ldb, c, ldb )
223 CALL dgemm( trans,
'No transpose', nrows, nrhs, ncols, -one, a,
224 $ lda, x, ldx, one, c, ldb )
225 normrs = dlange(
'Max', nrows, nrhs, c, ldb, rwork )
226 IF( normrs.GT.smlnum )
THEN
228 CALL dlascl(
'General', 0, 0, normrs, one, nrows, nrhs, c, ldb,
234 CALL dgemm(
'Transpose', trans, nrhs, ncols, nrows, one, c, ldb,
235 $ a, lda, zero, work, nrhs )
239 err = dlange(
'One-norm', nrhs, ncols, work, nrhs, rwork )
246 IF( iresid.EQ.1 )
THEN
247 normb = dlange(
'One-norm', nrows, nrhs, b, ldb, rwork )
255 dqrt17 = err / ( dlamch(
'Epsilon' )*dble( max( m, n, nrhs ) ) )
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dlascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DGEMM
subroutine xerbla(SRNAME, INFO)
XERBLA
double precision function dqrt17(TRANS, IRESID, M, N, NRHS, A, LDA, X, LDX, B, LDB, C, WORK, LWORK)
DQRT17