141 SUBROUTINE spstf2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )
150 INTEGER info, lda, n, rank
154 REAL a( lda, * ), work( 2*n )
162 parameter( one = 1.0e+0, zero = 0.0e+0 )
165 REAL ajj, sstop, stemp
166 INTEGER i, itemp,
j, pvt
178 INTRINSIC max, sqrt, maxloc
185 upper =
lsame( uplo,
'U' )
186 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
188 ELSE IF( n.LT.0 )
THEN
190 ELSE IF( lda.LT.max( 1, n ) )
THEN
194 CALL
xerbla(
'SPSTF2', -info )
214 IF( a( i, i ).GT.ajj )
THEN
219 IF( ajj.EQ.zero.OR.
sisnan( ajj ) )
THEN
227 IF( tol.LT.zero )
THEN
228 sstop = n *
slamch(
'Epsilon' ) * ajj
252 work( i ) = work( i ) + a(
j-1, i )**2
254 work( n+i ) = a( i, i ) - work( i )
259 itemp = maxloc( work( (n+
j):(2*n) ), 1 )
262 IF( ajj.LE.sstop.OR.
sisnan( ajj ) )
THEN
272 a( pvt, pvt ) = a(
j,
j )
273 CALL
sswap(
j-1, a( 1,
j ), 1, a( 1, pvt ), 1 )
275 $ CALL
sswap( n-pvt, a(
j, pvt+1 ), lda,
276 $ a( pvt, pvt+1 ), lda )
277 CALL
sswap( pvt-
j-1, a(
j,
j+1 ), lda, a(
j+1, pvt ), 1 )
282 work(
j ) = work( pvt )
285 piv( pvt ) = piv(
j )
295 CALL
sgemv(
'Trans',
j-1, n-
j, -one, a( 1,
j+1 ), lda,
296 $ a( 1,
j ), 1, one, a(
j,
j+1 ), lda )
297 CALL
sscal( n-
j, one / ajj, a(
j,
j+1 ), lda )
315 work( i ) = work( i ) + a( i,
j-1 )**2
317 work( n+i ) = a( i, i ) - work( i )
322 itemp = maxloc( work( (n+
j):(2*n) ), 1 )
325 IF( ajj.LE.sstop.OR.
sisnan( ajj ) )
THEN
335 a( pvt, pvt ) = a(
j,
j )
336 CALL
sswap(
j-1, a(
j, 1 ), lda, a( pvt, 1 ), lda )
338 $ CALL
sswap( n-pvt, a( pvt+1,
j ), 1, a( pvt+1, pvt ),
340 CALL
sswap( pvt-
j-1, a(
j+1,
j ), 1, a( pvt,
j+1 ), lda )
345 work(
j ) = work( pvt )
348 piv( pvt ) = piv(
j )
358 CALL
sgemv(
'No Trans', n-
j,
j-1, -one, a(
j+1, 1 ), lda,
359 $ a(
j, 1 ), lda, one, a(
j+1,
j ), 1 )
360 CALL
sscal( n-
j, one / ajj, a(
j+1,
j ), 1 )
subroutine spstf2(UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO)
SPSTF2 computes the Cholesky factorization with complete pivoting of a real symmetric or complex Herm...
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
subroutine xerbla(SRNAME, INFO)
XERBLA
logical function lsame(CA, CB)
LSAME
subroutine sgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
SGEMV
real function slamch(CMACH)
SLAMCH
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
logical function sisnan(SIN)
SISNAN tests input for NaN.
subroutine sscal(N, SA, SX, INCX)
SSCAL