143 SUBROUTINE sgeqpf( M, N, A, LDA, JPVT, TAU, WORK, INFO )
151 INTEGER info, lda, m, n
155 REAL a( lda, * ), tau( * ), work( * )
162 parameter( zero = 0.0e+0, one = 1.0e+0 )
165 INTEGER i, itemp,
j, ma, mn, pvt
166 REAL 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(
'SGEQPF', -info )
197 tol3z = sqrt(
slamch(
'Epsilon'))
203 IF( jpvt( i ).NE.0 )
THEN
204 IF( i.NE.itemp )
THEN
205 CALL
sswap( m, a( 1, i ), 1, a( 1, itemp ), 1 )
206 jpvt( i ) = jpvt( itemp )
220 IF( itemp.GT.0 )
THEN
222 CALL
sgeqr2( m, ma, a, lda, tau, work, info )
224 CALL
sorm2r(
'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 ) =
snrm2( m-itemp, a( itemp+1, i ), 1 )
236 work( n+i ) = work( i )
241 DO 40 i = itemp + 1, mn
245 pvt = ( i-1 ) +
isamax( n-i+1, work( i ), 1 )
248 CALL
sswap( 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
slarfg( m-i+1, a( i, i ), a( i+1, i ), 1, tau( i ) )
261 CALL
slarfg( 1, a( m, m ), a( m, m ), 1, tau( m ) )
270 CALL
slarf(
'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 ) =
snrm2( m-i, a( i+1,
j ), 1 )
289 work( n+
j ) = work(
j )
295 work(
j ) = work(
j )*sqrt( temp )
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
integer function isamax(N, SX, INCX)
ISAMAX
subroutine slarf(SIDE, M, N, V, INCV, TAU, C, LDC, WORK)
SLARF applies an elementary reflector to a general rectangular matrix.
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine sorm2r(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO)
SORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sge...
subroutine slarfg(N, ALPHA, X, INCX, TAU)
SLARFG generates an elementary reflector (Householder matrix).
real function slamch(CMACH)
SLAMCH
real function snrm2(N, X, INCX)
SNRM2
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine sgeqpf(M, N, A, LDA, JPVT, TAU, WORK, INFO)
SGEQPF
subroutine sgeqr2(M, N, A, LDA, TAU, WORK, INFO)
SGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm...