142 SUBROUTINE zpstf2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )
151 INTEGER info, lda, n, rank
155 COMPLEX*16 a( lda, * )
156 DOUBLE PRECISION work( 2*n )
163 DOUBLE PRECISION one, zero
164 parameter( one = 1.0d+0, zero = 0.0d+0 )
166 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
170 DOUBLE PRECISION ajj, dstop, dtemp
171 INTEGER i, itemp,
j, pvt
183 INTRINSIC dble, dconjg, max, sqrt
190 upper =
lsame( uplo,
'U' )
191 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
193 ELSE IF( n.LT.0 )
THEN
195 ELSE IF( lda.LT.max( 1, n ) )
THEN
199 CALL
xerbla(
'ZPSTF2', -info )
217 work( i ) = dble( a( i, i ) )
219 pvt = maxloc( work( 1:n ), 1 )
220 ajj = dble( a( pvt, pvt ) )
221 IF( ajj.EQ.zero.OR.
disnan( ajj ) )
THEN
229 IF( tol.LT.zero )
THEN
230 dstop = n *
dlamch(
'Epsilon' ) * ajj
254 work( i ) = work( i ) +
255 $ dble( dconjg( a(
j-1, i ) )*
258 work( n+i ) = dble( a( i, i ) ) - work( i )
263 itemp = maxloc( work( (n+
j):(2*n) ), 1 )
266 IF( ajj.LE.dstop.OR.
disnan( ajj ) )
THEN
276 a( pvt, pvt ) = a(
j,
j )
277 CALL
zswap(
j-1, a( 1,
j ), 1, a( 1, pvt ), 1 )
279 $ CALL
zswap( n-pvt, a(
j, pvt+1 ), lda,
280 $ a( pvt, pvt+1 ), lda )
281 DO 140 i =
j + 1, pvt - 1
282 ztemp = dconjg( a(
j, i ) )
283 a(
j, i ) = dconjg( a( i, pvt ) )
286 a(
j, pvt ) = dconjg( a(
j, pvt ) )
291 work(
j ) = work( pvt )
294 piv( pvt ) = piv(
j )
305 CALL
zgemv(
'Trans',
j-1, n-
j, -cone, a( 1,
j+1 ), lda,
306 $ a( 1,
j ), 1, cone, a(
j,
j+1 ), lda )
308 CALL
zdscal( n-
j, one / ajj, a(
j,
j+1 ), lda )
326 work( i ) = work( i ) +
327 $ dble( dconjg( a( i,
j-1 ) )*
330 work( n+i ) = dble( a( i, i ) ) - work( i )
335 itemp = maxloc( work( (n+
j):(2*n) ), 1 )
338 IF( ajj.LE.dstop.OR.
disnan( ajj ) )
THEN
348 a( pvt, pvt ) = a(
j,
j )
349 CALL
zswap(
j-1, a(
j, 1 ), lda, a( pvt, 1 ), lda )
351 $ CALL
zswap( n-pvt, a( pvt+1,
j ), 1, a( pvt+1, pvt ),
353 DO 170 i =
j + 1, pvt - 1
354 ztemp = dconjg( a( i,
j ) )
355 a( i,
j ) = dconjg( a( pvt, i ) )
358 a( pvt,
j ) = dconjg( a( pvt,
j ) )
363 work(
j ) = work( pvt )
366 piv( pvt ) = piv(
j )
377 CALL
zgemv(
'No Trans', n-
j,
j-1, -cone, a(
j+1, 1 ),
378 $ lda, a(
j, 1 ), lda, cone, a(
j+1,
j ), 1 )
380 CALL
zdscal( n-
j, one / ajj, a(
j+1,
j ), 1 )