149 SUBROUTINE cgeqpf( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO )
157 INTEGER info, lda, m, n
162 COMPLEX a( lda, * ), tau( * ), work( * )
169 parameter( zero = 0.0e+0, one = 1.0e+0 )
172 INTEGER i, itemp,
j, ma, mn, pvt
173 REAL temp, temp2, tol3z
180 INTRINSIC abs, cmplx, conjg, max, min, sqrt
194 ELSE IF( n.LT.0 )
THEN
196 ELSE IF( lda.LT.max( 1, m ) )
THEN
200 CALL
xerbla(
'CGEQPF', -info )
205 tol3z = sqrt(
slamch(
'Epsilon'))
211 IF( jpvt( i ).NE.0 )
THEN
212 IF( i.NE.itemp )
THEN
213 CALL
cswap( m, a( 1, i ), 1, a( 1, itemp ), 1 )
214 jpvt( i ) = jpvt( itemp )
228 IF( itemp.GT.0 )
THEN
230 CALL
cgeqr2( m, ma, a, lda, tau, work, info )
232 CALL
cunm2r(
'Left',
'Conjugate transpose', m, n-ma, ma, a,
233 $ lda, tau, a( 1, ma+1 ), lda, work, info )
237 IF( itemp.LT.mn )
THEN
242 DO 20 i = itemp + 1, n
243 rwork( i ) =
scnrm2( m-itemp, a( itemp+1, i ), 1 )
244 rwork( n+i ) = rwork( i )
249 DO 40 i = itemp + 1, mn
253 pvt = ( i-1 ) +
isamax( n-i+1, rwork( i ), 1 )
256 CALL
cswap( m, a( 1, pvt ), 1, a( 1, i ), 1 )
258 jpvt( pvt ) = jpvt( i )
260 rwork( pvt ) = rwork( i )
261 rwork( n+pvt ) = rwork( n+i )
267 CALL
clarfg( m-i+1, aii, a( min( i+1, m ), i ), 1,
276 a( i, i ) = cmplx( one )
277 CALL
clarf(
'Left', m-i+1, n-i, a( i, i ), 1,
278 $ conjg( tau( i ) ), a( i, i+1 ), lda, work )
285 IF( rwork(
j ).NE.zero )
THEN
290 temp = abs( a( i,
j ) ) / rwork(
j )
291 temp = max( zero, ( one+temp )*( one-temp ) )
292 temp2 = temp*( rwork(
j ) / rwork( n+
j ) )**2
293 IF( temp2 .LE. tol3z )
THEN
295 rwork(
j ) =
scnrm2( m-i, a( i+1,
j ), 1 )
296 rwork( n+
j ) = rwork(
j )
302 rwork(
j ) = rwork(
j )*sqrt( temp )
INTEGER function isamax(N, SX, INCX)
ISAMAX
REAL function slamch(CMACH)
SLAMCH
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cgeqr2(M, N, A, LDA, TAU, WORK, INFO)
CGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm...
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine clarfg(N, ALPHA, X, INCX, TAU)
CLARFG generates an elementary reflector (Householder matrix).
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine cgeqpf(M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO)
CGEQPF
REAL function scnrm2(N, X, INCX)
SCNRM2
subroutine clarf(SIDE, M, N, V, INCV, TAU, C, LDC, WORK)
CLARF applies an elementary reflector to a general rectangular matrix.
subroutine cunm2r(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO)
CUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf...