143 SUBROUTINE dgeqpf( M, N, A, LDA, JPVT, TAU, WORK, INFO )
151 INTEGER info, lda, m, n
155 DOUBLE PRECISION a( lda, * ), tau( * ), work( * )
161 DOUBLE PRECISION zero, one
162 parameter( zero = 0.0d+0, one = 1.0d+0 )
165 INTEGER i, itemp,
j, ma, mn, pvt
166 DOUBLE PRECISION aii, temp, temp2, tol3z
172 INTRINSIC abs, max, min, sqrt
186 ELSE IF( n.LT.0 )
THEN
188 ELSE IF( lda.LT.max( 1, m ) )
THEN
192 CALL
xerbla(
'DGEQPF', -info )
197 tol3z = sqrt(
dlamch(
'Epsilon'))
203 IF( jpvt( i ).NE.0 )
THEN
204 IF( i.NE.itemp )
THEN
205 CALL
dswap( m, a( 1, i ), 1, a( 1, itemp ), 1 )
206 jpvt( i ) = jpvt( itemp )
220 IF( itemp.GT.0 )
THEN
222 CALL
dgeqr2( m, ma, a, lda, tau, work, info )
224 CALL
dorm2r(
'Left',
'Transpose', m, n-ma, ma, a, lda, tau,
225 $ a( 1, ma+1 ), lda, work, info )
229 IF( itemp.LT.mn )
THEN
234 DO 20 i = itemp + 1, n
235 work( i ) =
dnrm2( m-itemp, a( itemp+1, i ), 1 )
236 work( n+i ) = work( i )
241 DO 40 i = itemp + 1, mn
245 pvt = ( i-1 ) +
idamax( n-i+1, work( i ), 1 )
248 CALL
dswap( m, a( 1, pvt ), 1, a( 1, i ), 1 )
250 jpvt( pvt ) = jpvt( i )
252 work( pvt ) = work( i )
253 work( n+pvt ) = work( n+i )
259 CALL
dlarfg( m-i+1, a( i, i ), a( i+1, i ), 1, tau( i ) )
261 CALL
dlarfg( 1, a( m, m ), a( m, m ), 1, tau( m ) )
270 CALL
dlarf(
'LEFT', m-i+1, n-i, a( i, i ), 1, tau( i ),
271 $ a( i, i+1 ), lda, work( 2*n+1 ) )
278 IF( work(
j ).NE.zero )
THEN
283 temp = abs( a( i,
j ) ) / work(
j )
284 temp = max( zero, ( one+temp )*( one-temp ) )
285 temp2 = temp*( work(
j ) / work( n+
j ) )**2
286 IF( temp2 .LE. tol3z )
THEN
288 work(
j ) =
dnrm2( m-i, a( i+1,
j ), 1 )
289 work( n+
j ) = work(
j )
295 work(
j ) = work(
j )*sqrt( temp )
subroutine dlarfg(N, ALPHA, X, INCX, TAU)
DLARFG generates an elementary reflector (Householder matrix).
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dlarf(SIDE, M, N, V, INCV, TAU, C, LDC, WORK)
DLARF applies an elementary reflector to a general rectangular matrix.
subroutine dgeqpf(M, N, A, LDA, JPVT, TAU, WORK, INFO)
DGEQPF
double precision function dlamch(CMACH)
DLAMCH
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine dgeqr2(M, N, A, LDA, TAU, WORK, INFO)
DGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm...
integer function idamax(N, DX, INCX)
IDAMAX
double precision function dnrm2(N, X, INCX)
DNRM2
subroutine dswap(N, DX, INCX, DY, INCY)
DSWAP
subroutine dorm2r(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO)
DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sge...