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 )
INTEGER function isamax(N, SX, INCX)
ISAMAX
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
REAL function slamch(CMACH)
SLAMCH
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).
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
REAL function snrm2(N, X, INCX)
SNRM2
subroutine sgeqr2(M, N, A, LDA, TAU, WORK, INFO)
SGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm...