149 SUBROUTINE zlaqp2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
158 INTEGER lda, m, n, offset
162 DOUBLE PRECISION vn1( * ), vn2( * )
163 COMPLEX*16 a( lda, * ), tau( * ), work( * )
169 DOUBLE PRECISION zero, one
171 parameter( zero = 0.0d+0, one = 1.0d+0,
172 $ cone = ( 1.0d+0, 0.0d+0 ) )
175 INTEGER i, itemp,
j, mn, offpi, pvt
176 DOUBLE PRECISION temp, temp2, tol3z
183 INTRINSIC abs, dconjg, max, min, sqrt
192 mn = min( m-offset, n )
193 tol3z = sqrt(
dlamch(
'Epsilon'))
203 pvt = ( i-1 ) +
idamax( n-i+1, vn1( i ), 1 )
206 CALL
zswap( m, a( 1, pvt ), 1, a( 1, i ), 1 )
208 jpvt( pvt ) = jpvt( i )
210 vn1( pvt ) = vn1( i )
211 vn2( pvt ) = vn2( i )
216 IF( offpi.LT.m )
THEN
217 CALL
zlarfg( m-offpi+1, a( offpi, i ), a( offpi+1, i ), 1,
220 CALL
zlarfg( 1, a( m, i ), a( m, i ), 1, tau( i ) )
229 CALL
zlarf(
'Left', m-offpi+1, n-i, a( offpi, i ), 1,
230 $ dconjg( tau( i ) ), a( offpi, i+1 ), lda,
238 IF( vn1(
j ).NE.zero )
THEN
243 temp = one - ( abs( a( offpi,
j ) ) / vn1(
j ) )**2
244 temp = max( temp, zero )
245 temp2 = temp*( vn1(
j ) / vn2(
j ) )**2
246 IF( temp2 .LE. tol3z )
THEN
247 IF( offpi.LT.m )
THEN
248 vn1(
j ) =
dznrm2( m-offpi, a( offpi+1,
j ), 1 )
255 vn1(
j ) = vn1(
j )*sqrt( temp )
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
subroutine zlarf(SIDE, M, N, V, INCV, TAU, C, LDC, WORK)
ZLARF applies an elementary reflector to a general rectangular matrix.
DOUBLE PRECISION function dznrm2(N, X, INCX)
DZNRM2
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
subroutine zlarfg(N, ALPHA, X, INCX, TAU)
ZLARFG generates an elementary reflector (Householder matrix).
subroutine zlaqp2(M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, WORK)
ZLAQP2 computes a QR factorization with column pivoting of the matrix block.
INTEGER function idamax(N, DX, INCX)
IDAMAX