110 SUBROUTINE ssptri( UPLO, N, AP, IPIV, WORK, INFO )
123 REAL AP( * ), WORK( * )
130 parameter( one = 1.0e+0, zero = 0.0e+0 )
134 INTEGER J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
135 REAL AK, AKKP1, AKP1, D, T, TEMP
153 upper = lsame( uplo,
'U' )
154 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
156 ELSE IF( n.LT.0 )
THEN
160 CALL
xerbla(
'SSPTRI', -info )
176 DO 10 info = n, 1, -1
177 IF( ipiv( info ).GT.0 .AND. ap( kp ).EQ.zero )
187 IF( ipiv( info ).GT.0 .AND. ap( kp ).EQ.zero )
189 kp = kp + n - info + 1
211 IF( ipiv( k ).GT.0 )
THEN
217 ap( kc+k-1 ) = one / ap( kc+k-1 )
222 CALL
scopy( k-1, ap( kc ), 1, work, 1 )
223 CALL
sspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),
225 ap( kc+k-1 ) = ap( kc+k-1 ) -
226 $ sdot( k-1, work, 1, ap( kc ), 1 )
235 t = abs( ap( kcnext+k-1 ) )
236 ak = ap( kc+k-1 ) / t
237 akp1 = ap( kcnext+k ) / t
238 akkp1 = ap( kcnext+k-1 ) / t
239 d = t*( ak*akp1-one )
240 ap( kc+k-1 ) = akp1 / d
241 ap( kcnext+k ) = ak / d
242 ap( kcnext+k-1 ) = -akkp1 / d
247 CALL
scopy( k-1, ap( kc ), 1, work, 1 )
248 CALL
sspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),
250 ap( kc+k-1 ) = ap( kc+k-1 ) -
251 $ sdot( k-1, work, 1, ap( kc ), 1 )
252 ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -
253 $ sdot( k-1, ap( kc ), 1, ap( kcnext ),
255 CALL
scopy( k-1, ap( kcnext ), 1, work, 1 )
256 CALL
sspmv( uplo, k-1, -one, ap, work, 1, zero,
258 ap( kcnext+k ) = ap( kcnext+k ) -
259 $ sdot( k-1, work, 1, ap( kcnext ), 1 )
262 kcnext = kcnext + k + 1
265 kp = abs( ipiv( k ) )
271 kpc = ( kp-1 )*kp / 2 + 1
272 CALL
sswap( kp-1, ap( kc ), 1, ap( kpc ), 1 )
274 DO 40 j = kp + 1, k - 1
277 ap( kc+j-1 ) = ap( kx )
281 ap( kc+k-1 ) = ap( kpc+kp-1 )
282 ap( kpc+kp-1 ) = temp
283 IF( kstep.EQ.2 )
THEN
284 temp = ap( kc+k+k-1 )
285 ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
286 ap( kc+k+kp-1 ) = temp
312 kcnext = kc - ( n-k+2 )
313 IF( ipiv( k ).GT.0 )
THEN
319 ap( kc ) = one / ap( kc )
324 CALL
scopy( n-k, ap( kc+1 ), 1, work, 1 )
325 CALL
sspmv( uplo, n-k, -one, ap( kc+n-k+1 ), work, 1,
326 $ zero, ap( kc+1 ), 1 )
327 ap( kc ) = ap( kc ) - sdot( n-k, work, 1, ap( kc+1 ), 1 )
336 t = abs( ap( kcnext+1 ) )
337 ak = ap( kcnext ) / t
339 akkp1 = ap( kcnext+1 ) / t
340 d = t*( ak*akp1-one )
341 ap( kcnext ) = akp1 / d
343 ap( kcnext+1 ) = -akkp1 / d
348 CALL
scopy( n-k, ap( kc+1 ), 1, work, 1 )
349 CALL
sspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1,
350 $ zero, ap( kc+1 ), 1 )
351 ap( kc ) = ap( kc ) - sdot( n-k, work, 1, ap( kc+1 ), 1 )
352 ap( kcnext+1 ) = ap( kcnext+1 ) -
353 $ sdot( n-k, ap( kc+1 ), 1,
354 $ ap( kcnext+2 ), 1 )
355 CALL
scopy( n-k, ap( kcnext+2 ), 1, work, 1 )
356 CALL
sspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1,
357 $ zero, ap( kcnext+2 ), 1 )
358 ap( kcnext ) = ap( kcnext ) -
359 $ sdot( n-k, work, 1, ap( kcnext+2 ), 1 )
362 kcnext = kcnext - ( n-k+3 )
365 kp = abs( ipiv( k ) )
371 kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2 + 1
373 $ CALL
sswap( n-kp, ap( kc+kp-k+1 ), 1, ap( kpc+1 ), 1 )
375 DO 70 j = k + 1, kp - 1
378 ap( kc+j-k ) = ap( kx )
384 IF( kstep.EQ.2 )
THEN
385 temp = ap( kc-n+k-1 )
386 ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
387 ap( kc-n+kp-1 ) = temp
subroutine sspmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
SSPMV
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
subroutine ssptri(UPLO, N, AP, IPIV, WORK, INFO)
SSPTRI
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY