143 SUBROUTINE cpstf2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )
152 INTEGER INFO, LDA, N, RANK
165 parameter ( one = 1.0e+0, zero = 0.0e+0 )
167 parameter ( cone = ( 1.0e+0, 0.0e+0 ) )
171 REAL AJJ, SSTOP, STEMP
172 INTEGER I, ITEMP, J, PVT
177 LOGICAL LSAME, SISNAN
178 EXTERNAL slamch, lsame, sisnan
184 INTRINSIC conjg, max,
REAL, SQRT
191 upper = lsame( uplo,
'U' )
192 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
194 ELSE IF( n.LT.0 )
THEN
196 ELSE IF( lda.LT.max( 1, n ) )
THEN
200 CALL xerbla(
'CPSTF2', -info )
218 work( i ) =
REAL( A( I, I ) )
220 pvt = maxloc( work( 1:n ), 1 )
221 ajj =
REAL ( A( PVT, PVT ) )
222 IF( ajj.LE.zero.OR.sisnan( ajj ) )
THEN
230 IF( tol.LT.zero )
THEN
231 sstop = n * slamch(
'Epsilon' ) * ajj
255 work( i ) = work( i ) +
256 $
REAL( CONJG( A( J-1, I ) )*
259 work( n+i ) =
REAL( A( I, I ) ) - WORK( i )
264 itemp = maxloc( work( (n+j):(2*n) ), 1 )
267 IF( ajj.LE.sstop.OR.sisnan( ajj ) )
THEN
277 a( pvt, pvt ) = a( j, j )
278 CALL cswap( j-1, a( 1, j ), 1, a( 1, pvt ), 1 )
280 $
CALL cswap( n-pvt, a( j, pvt+1 ), lda,
281 $ a( pvt, pvt+1 ), lda )
282 DO 140 i = j + 1, pvt - 1
283 ctemp = conjg( a( j, i ) )
284 a( j, i ) = conjg( a( i, pvt ) )
287 a( j, pvt ) = conjg( a( j, pvt ) )
292 work( j ) = work( pvt )
295 piv( pvt ) = piv( j )
305 CALL clacgv( j-1, a( 1, j ), 1 )
306 CALL cgemv(
'Trans', j-1, n-j, -cone, a( 1, j+1 ), lda,
307 $ a( 1, j ), 1, cone, a( j, j+1 ), lda )
308 CALL clacgv( j-1, a( 1, j ), 1 )
309 CALL csscal( n-j, one / ajj, a( j, j+1 ), lda )
327 work( i ) = work( i ) +
328 $
REAL( CONJG( A( I, J-1 ) )*
331 work( n+i ) =
REAL( A( I, I ) ) - WORK( i )
336 itemp = maxloc( work( (n+j):(2*n) ), 1 )
339 IF( ajj.LE.sstop.OR.sisnan( ajj ) )
THEN
349 a( pvt, pvt ) = a( j, j )
350 CALL cswap( j-1, a( j, 1 ), lda, a( pvt, 1 ), lda )
352 $
CALL cswap( n-pvt, a( pvt+1, j ), 1, a( pvt+1, pvt ),
354 DO 170 i = j + 1, pvt - 1
355 ctemp = conjg( a( i, j ) )
356 a( i, j ) = conjg( a( pvt, i ) )
359 a( pvt, j ) = conjg( a( pvt, j ) )
364 work( j ) = work( pvt )
367 piv( pvt ) = piv( j )
377 CALL clacgv( j-1, a( j, 1 ), lda )
378 CALL cgemv(
'No Trans', n-j, j-1, -cone, a( j+1, 1 ),
379 $ lda, a( j, 1 ), lda, cone, a( j+1, j ), 1 )
380 CALL clacgv( j-1, a( j, 1 ), lda )
381 CALL csscal( n-j, one / ajj, a( j+1, j ), 1 )
subroutine cpstf2(UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO)
CPSTF2 computes the Cholesky factorization with complete pivoting of complex Hermitian positive semid...
subroutine cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine clacgv(N, X, INCX)
CLACGV conjugates a complex vector.
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine csscal(N, SA, CX, INCX)
CSSCAL