116 SUBROUTINE ssptrs( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
125 INTEGER INFO, LDB, N, NRHS
129 REAL AP( * ), B( ldb, * )
136 parameter ( one = 1.0e+0 )
141 REAL AK, AKM1, AKM1K, BK, BKM1, DENOM
156 upper = lsame( uplo,
'U' )
157 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
159 ELSE IF( n.LT.0 )
THEN
161 ELSE IF( nrhs.LT.0 )
THEN
163 ELSE IF( ldb.LT.max( 1, n ) )
THEN
167 CALL xerbla(
'SSPTRS', -info )
173 IF( n.EQ.0 .OR. nrhs.EQ.0 )
186 kc = n*( n+1 ) / 2 + 1
195 IF( ipiv( k ).GT.0 )
THEN
203 $
CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
208 CALL sger( k-1, nrhs, -one, ap( kc ), 1, b( k, 1 ), ldb,
213 CALL sscal( nrhs, one / ap( kc+k-1 ), b( k, 1 ), ldb )
223 $
CALL sswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
228 CALL sger( k-2, nrhs, -one, ap( kc ), 1, b( k, 1 ), ldb,
230 CALL sger( k-2, nrhs, -one, ap( kc-( k-1 ) ), 1,
231 $ b( k-1, 1 ), ldb, b( 1, 1 ), ldb )
236 akm1 = ap( kc-1 ) / akm1k
237 ak = ap( kc+k-1 ) / akm1k
238 denom = akm1*ak - one
240 bkm1 = b( k-1, j ) / akm1k
241 bk = b( k, j ) / akm1k
242 b( k-1, j ) = ( ak*bkm1-bk ) / denom
243 b( k, j ) = ( akm1*bk-bkm1 ) / denom
266 IF( ipiv( k ).GT.0 )
THEN
273 CALL sgemv(
'Transpose', k-1, nrhs, -one, b, ldb, ap( kc ),
274 $ 1, one, b( k, 1 ), ldb )
280 $
CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
290 CALL sgemv(
'Transpose', k-1, nrhs, -one, b, ldb, ap( kc ),
291 $ 1, one, b( k, 1 ), ldb )
292 CALL sgemv(
'Transpose', k-1, nrhs, -one, b, ldb,
293 $ ap( kc+k ), 1, one, b( k+1, 1 ), ldb )
299 $
CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
325 IF( ipiv( k ).GT.0 )
THEN
333 $
CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
339 $
CALL sger( n-k, nrhs, -one, ap( kc+1 ), 1, b( k, 1 ),
340 $ ldb, b( k+1, 1 ), ldb )
344 CALL sscal( nrhs, one / ap( kc ), b( k, 1 ), ldb )
355 $
CALL sswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
361 CALL sger( n-k-1, nrhs, -one, ap( kc+2 ), 1, b( k, 1 ),
362 $ ldb, b( k+2, 1 ), ldb )
363 CALL sger( n-k-1, nrhs, -one, ap( kc+n-k+2 ), 1,
364 $ b( k+1, 1 ), ldb, b( k+2, 1 ), ldb )
370 akm1 = ap( kc ) / akm1k
371 ak = ap( kc+n-k+1 ) / akm1k
372 denom = akm1*ak - one
374 bkm1 = b( k, j ) / akm1k
375 bk = b( k+1, j ) / akm1k
376 b( k, j ) = ( ak*bkm1-bk ) / denom
377 b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
379 kc = kc + 2*( n-k ) + 1
392 kc = n*( n+1 ) / 2 + 1
401 IF( ipiv( k ).GT.0 )
THEN
409 $
CALL sgemv(
'Transpose', n-k, nrhs, -one, b( k+1, 1 ),
410 $ ldb, ap( kc+1 ), 1, one, b( k, 1 ), ldb )
416 $
CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
426 CALL sgemv(
'Transpose', n-k, nrhs, -one, b( k+1, 1 ),
427 $ ldb, ap( kc+1 ), 1, one, b( k, 1 ), ldb )
428 CALL sgemv(
'Transpose', n-k, nrhs, -one, b( k+1, 1 ),
429 $ ldb, ap( kc-( n-k ) ), 1, one, b( k-1, 1 ),
437 $
CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
subroutine sger(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
SGER
subroutine sgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
SGEMV
subroutine ssptrs(UPLO, N, NRHS, AP, IPIV, B, LDB, INFO)
SSPTRS
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine sscal(N, SA, SX, INCX)
SSCAL
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP