143 INTEGER INFO, LDA, LDB, N, NRHS
147 REAL A( LDA, * ), B( LDB, * )
154 parameter( one = 1.0e+0 )
159 REAL AK, AKM1, AKM1K, BK, BKM1, DENOM
174 upper = lsame( uplo,
'U' )
175 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
177 ELSE IF( n.LT.0 )
THEN
179 ELSE IF( nrhs.LT.0 )
THEN
181 ELSE IF( lda.LT.max( 1, n ) )
THEN
183 ELSE IF( ldb.LT.max( 1, n ) )
THEN
187 CALL xerbla(
'SSYTRS_ROOK', -info )
193 IF( n.EQ.0 .OR. nrhs.EQ.0 )
213 IF( ipiv( k ).GT.0 )
THEN
221 $
CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
226 CALL sger( k-1, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb,
231 CALL sscal( nrhs, one / a( k, k ), b( k, 1 ), ldb )
241 $
CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
245 $
CALL sswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
251 CALL sger( k-2, nrhs, -one, a( 1, k ), 1, b( k, 1 ),
252 $ ldb, b( 1, 1 ), ldb )
253 CALL sger( k-2, nrhs, -one, a( 1, k-1 ), 1, b( k-1, 1 ),
254 $ ldb, b( 1, 1 ), ldb )
260 akm1 = a( k-1, k-1 ) / akm1k
261 ak = a( k, k ) / akm1k
262 denom = akm1*ak - one
264 bkm1 = b( k-1, j ) / akm1k
265 bk = b( k, j ) / akm1k
266 b( k-1, j ) = ( ak*bkm1-bk ) / denom
267 b( k, j ) = ( akm1*bk-bkm1 ) / denom
288 IF( ipiv( k ).GT.0 )
THEN
296 $
CALL sgemv(
'Transpose', k-1, nrhs, -one, b,
297 $ ldb, a( 1, k ), 1, one, b( k, 1 ), ldb )
303 $
CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
313 CALL sgemv(
'Transpose', k-1, nrhs, -one, b,
314 $ ldb, a( 1, k ), 1, one, b( k, 1 ), ldb )
315 CALL sgemv(
'Transpose', k-1, nrhs, -one, b,
316 $ ldb, a( 1, k+1 ), 1, one, b( k+1, 1 ), ldb )
323 $
CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
327 $
CALL sswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
352 IF( ipiv( k ).GT.0 )
THEN
360 $
CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
366 $
CALL sger( n-k, nrhs, -one, a( k+1, k ), 1, b( k, 1 ),
367 $ ldb, b( k+1, 1 ), ldb )
371 CALL sscal( nrhs, one / a( k, k ), b( k, 1 ), ldb )
381 $
CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
385 $
CALL sswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
391 CALL sger( n-k-1, nrhs, -one, a( k+2, k ), 1, b( k, 1 ),
392 $ ldb, b( k+2, 1 ), ldb )
393 CALL sger( n-k-1, nrhs, -one, a( k+2, k+1 ), 1,
394 $ b( k+1, 1 ), ldb, b( k+2, 1 ), ldb )
400 akm1 = a( k, k ) / akm1k
401 ak = a( k+1, k+1 ) / akm1k
402 denom = akm1*ak - one
404 bkm1 = b( k, j ) / akm1k
405 bk = b( k+1, j ) / akm1k
406 b( k, j ) = ( ak*bkm1-bk ) / denom
407 b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
428 IF( ipiv( k ).GT.0 )
THEN
436 $
CALL sgemv(
'Transpose', n-k, nrhs, -one, b( k+1, 1 ),
437 $ ldb, a( k+1, k ), 1, one, b( k, 1 ), ldb )
443 $
CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
453 CALL sgemv(
'Transpose', n-k, nrhs, -one, b( k+1, 1 ),
454 $ ldb, a( k+1, k ), 1, one, b( k, 1 ), ldb )
455 CALL sgemv(
'Transpose', n-k, nrhs, -one, b( k+1, 1 ),
456 $ ldb, a( k+1, k-1 ), 1, one, b( k-1, 1 ),
464 $
CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
468 $
CALL sswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
subroutine xerbla(srname, info)
subroutine sgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
SGEMV
subroutine sger(m, n, alpha, x, incx, y, incy, a, lda)
SGER
subroutine ssytrs_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
SSYTRS_ROOK
subroutine sscal(n, sa, sx, incx)
SSCAL
subroutine sswap(n, sx, incx, sy, incy)
SSWAP