116 DOUBLE PRECISION FUNCTION dqrt14( TRANS, M, N, NRHS, A, LDA, X,
126 INTEGER LDA, LDX, LWORK, M, N, NRHS
129 DOUBLE PRECISION A( lda, * ), WORK( lwork ), X( ldx, * )
135 DOUBLE PRECISION ZERO, ONE
136 parameter ( zero = 0.0d0, one = 1.0d0 )
140 INTEGER I, INFO, J, LDWORK
141 DOUBLE PRECISION ANRM, ERR, XNRM
144 DOUBLE PRECISION RWORK( 1 )
148 DOUBLE PRECISION DLAMCH, DLANGE
149 EXTERNAL lsame, dlamch, dlange
155 INTRINSIC abs, dble, max, min
160 IF( lsame( trans,
'N' ) )
THEN
163 IF( lwork.LT.( m+nrhs )*( n+2 ) )
THEN
164 CALL xerbla(
'DQRT14', 10 )
166 ELSE IF( n.LE.0 .OR. nrhs.LE.0 )
THEN
169 ELSE IF( lsame( trans,
'T' ) )
THEN
172 IF( lwork.LT.( n+nrhs )*( m+2 ) )
THEN
173 CALL xerbla(
'DQRT14', 10 )
175 ELSE IF( m.LE.0 .OR. nrhs.LE.0 )
THEN
179 CALL xerbla(
'DQRT14', 1 )
185 CALL dlacpy(
'All', m, n, a, lda, work, ldwork )
186 anrm = dlange(
'M', m, n, work, ldwork, rwork )
188 $
CALL dlascl(
'G', 0, 0, anrm, one, m, n, work, ldwork, info )
196 CALL dlacpy(
'All', m, nrhs, x, ldx, work( n*ldwork+1 ),
198 xnrm = dlange(
'M', m, nrhs, work( n*ldwork+1 ), ldwork,
201 $
CALL dlascl(
'G', 0, 0, xnrm, one, m, nrhs,
202 $ work( n*ldwork+1 ), ldwork, info )
203 anrm = dlange(
'One-norm', m, n+nrhs, work, ldwork, rwork )
207 CALL dgeqr2( m, n+nrhs, work, ldwork,
208 $ work( ldwork*( n+nrhs )+1 ),
209 $ work( ldwork*( n+nrhs )+min( m, n+nrhs )+1 ),
216 DO 20 j = n + 1, n + nrhs
217 DO 10 i = n + 1, min( m, j )
218 err = max( err, abs( work( i+( j-1 )*m ) ) )
228 work( m+j+( i-1 )*ldwork ) = x( i, j )
232 xnrm = dlange(
'M', nrhs, n, work( m+1 ), ldwork, rwork )
234 $
CALL dlascl(
'G', 0, 0, xnrm, one, nrhs, n, work( m+1 ),
239 CALL dgelq2( ldwork, n, work, ldwork, work( ldwork*n+1 ),
240 $ work( ldwork*( n+1 )+1 ), info )
248 err = max( err, abs( work( i+( j-1 )*ldwork ) ) )
254 dqrt14 = err / ( dble( max( m, n, nrhs ) )*dlamch(
'Epsilon' ) )
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 dgeqr2(M, N, A, LDA, TAU, WORK, INFO)
DGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm...
subroutine dgelq2(M, N, A, LDA, TAU, WORK, INFO)
DGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm...
subroutine xerbla(SRNAME, INFO)
XERBLA
double precision function dqrt14(TRANS, M, N, NRHS, A, LDA, X, LDX, WORK, LWORK)
DQRT14