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
175 DOUBLE PRECISION DLAMCH
176 LOGICAL LSAME, DISNAN
177 EXTERNAL dlamch, lsame, disnan
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 )
304 CALL zlacgv( j-1, a( 1, j ), 1 )
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 )
307 CALL zlacgv( j-1, a( 1, j ), 1 )
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 )
376 CALL zlacgv( j-1, a( j, 1 ), lda )
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 )
379 CALL zlacgv( j-1, a( j, 1 ), lda )
380 CALL zdscal( n-j, one / ajj, a( j+1, j ), 1 )
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
subroutine zgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZGEMV
subroutine zpstf2(UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO)
ZPSTF2 computes the Cholesky factorization with complete pivoting of a real symmetric or complex Herm...
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zlacgv(N, X, INCX)
ZLACGV conjugates a complex vector.