142 SUBROUTINE cpstf2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )
151 INTEGER INFO, LDA, N, RANK
164 parameter( one = 1.0e+0, zero = 0.0e+0 )
166 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
170 REAL AJJ, SSTOP, STEMP
171 INTEGER I, ITEMP, J, PVT
176 LOGICAL LSAME, SISNAN
177 EXTERNAL slamch, lsame, sisnan
183 INTRINSIC conjg, max,
REAL, 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(
'CPSTF2', -info )
217 work( i ) =
REAL( A( I, I ) )
219 pvt = maxloc( work( 1:n ), 1 )
220 ajj =
REAL ( A( PVT, PVT ) )
221 IF( ajj.EQ.zero.OR.sisnan( ajj ) )
THEN
229 IF( tol.LT.zero )
THEN
230 sstop = n * slamch(
'Epsilon' ) * ajj
254 work( i ) = work( i ) +
255 $
REAL( CONJG( A( J-1, I ) )*
258 work( n+i ) =
REAL( A( I, I ) ) - WORK( i )
263 itemp = maxloc( work( (n+j):(2*n) ), 1 )
266 IF( ajj.LE.sstop.OR.sisnan( ajj ) )
THEN
276 a( pvt, pvt ) = a( j, j )
277 CALL cswap( j-1, a( 1, j ), 1, a( 1, pvt ), 1 )
279 $
CALL cswap( n-pvt, a( j, pvt+1 ), lda,
280 $ a( pvt, pvt+1 ), lda )
281 DO 140 i = j + 1, pvt - 1
282 ctemp = conjg( a( j, i ) )
283 a( j, i ) = conjg( a( i, pvt ) )
286 a( j, pvt ) = conjg( a( j, pvt ) )
291 work( j ) = work( pvt )
294 piv( pvt ) = piv( j )
304 CALL clacgv( j-1, a( 1, j ), 1 )
305 CALL cgemv(
'Trans', j-1, n-j, -cone, a( 1, j+1 ), lda,
306 $ a( 1, j ), 1, cone, a( j, j+1 ), lda )
307 CALL clacgv( j-1, a( 1, j ), 1 )
308 CALL csscal( n-j, one / ajj, a( j, j+1 ), lda )
326 work( i ) = work( i ) +
327 $
REAL( CONJG( A( I, J-1 ) )*
330 work( n+i ) =
REAL( A( I, I ) ) - WORK( i )
335 itemp = maxloc( work( (n+j):(2*n) ), 1 )
338 IF( ajj.LE.sstop.OR.sisnan( ajj ) )
THEN
348 a( pvt, pvt ) = a( j, j )
349 CALL cswap( j-1, a( j, 1 ), lda, a( pvt, 1 ), lda )
351 $
CALL cswap( n-pvt, a( pvt+1, j ), 1, a( pvt+1, pvt ),
353 DO 170 i = j + 1, pvt - 1
354 ctemp = conjg( a( i, j ) )
355 a( i, j ) = conjg( a( pvt, i ) )
358 a( pvt, j ) = conjg( a( pvt, j ) )
363 work( j ) = work( pvt )
366 piv( pvt ) = piv( j )
376 CALL clacgv( j-1, a( j, 1 ), lda )
377 CALL cgemv(
'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 clacgv( j-1, a( j, 1 ), lda )
380 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 a real symmetric or complex Herm...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine clacgv(N, X, INCX)
CLACGV conjugates a complex vector.
subroutine cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
subroutine csscal(N, SA, CX, INCX)
CSSCAL