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
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 )
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 )
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 )
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 )
380 CALL
csscal( n-
j, one / ajj, a(
j+1,
j ), 1 )
LOGICAL function lsame(CA, CB)
LSAME
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...
REAL function slamch(CMACH)
SLAMCH
subroutine xerbla(SRNAME, INFO)
XERBLA
LOGICAL function sisnan(SIN)
SISNAN tests input for NaN.
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
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine csscal(N, SA, CX, INCX)
CSSCAL