121 SUBROUTINE dsytrs( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
130 INTEGER info, lda, ldb, n, nrhs
134 DOUBLE PRECISION a( lda, * ),
b( ldb, * )
141 parameter( one = 1.0d+0 )
146 DOUBLE PRECISION ak, akm1, akm1k, bk, bkm1, denom
161 upper =
lsame( uplo,
'U' )
162 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
164 ELSE IF( n.LT.0 )
THEN
166 ELSE IF( nrhs.LT.0 )
THEN
168 ELSE IF( lda.LT.max( 1, n ) )
THEN
170 ELSE IF( ldb.LT.max( 1, n ) )
THEN
174 CALL
xerbla(
'DSYTRS', -info )
180 IF( n.EQ.0 .OR. nrhs.EQ.0 )
200 IF( ipiv( k ).GT.0 )
THEN
208 $ CALL
dswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
213 CALL
dger( k-1, nrhs, -one, a( 1, k ), 1,
b( k, 1 ), ldb,
218 CALL
dscal( nrhs, one / a( k, k ),
b( k, 1 ), ldb )
228 $ CALL
dswap( nrhs,
b( k-1, 1 ), ldb,
b( kp, 1 ), ldb )
233 CALL
dger( k-2, nrhs, -one, a( 1, k ), 1,
b( k, 1 ), ldb,
235 CALL
dger( k-2, nrhs, -one, a( 1, k-1 ), 1,
b( k-1, 1 ),
236 $ ldb,
b( 1, 1 ), ldb )
241 akm1 = a( k-1, k-1 ) / akm1k
242 ak = a( k, k ) / akm1k
243 denom = akm1*ak - one
245 bkm1 =
b( k-1,
j ) / akm1k
246 bk =
b( k,
j ) / akm1k
247 b( k-1,
j ) = ( ak*bkm1-bk ) / denom
248 b( k,
j ) = ( akm1*bk-bkm1 ) / denom
269 IF( ipiv( k ).GT.0 )
THEN
276 CALL
dgemv(
'Transpose', k-1, nrhs, -one,
b, ldb, a( 1, k ),
277 $ 1, one,
b( k, 1 ), ldb )
283 $ CALL
dswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
292 CALL
dgemv(
'Transpose', k-1, nrhs, -one,
b, ldb, a( 1, k ),
293 $ 1, one,
b( k, 1 ), ldb )
294 CALL
dgemv(
'Transpose', k-1, nrhs, -one,
b, ldb,
295 $ a( 1, k+1 ), 1, one,
b( k+1, 1 ), ldb )
301 $ CALL
dswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
325 IF( ipiv( k ).GT.0 )
THEN
333 $ CALL
dswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
339 $ CALL
dger( n-k, nrhs, -one, a( k+1, k ), 1,
b( k, 1 ),
340 $ ldb,
b( k+1, 1 ), ldb )
344 CALL
dscal( nrhs, one / a( k, k ),
b( k, 1 ), ldb )
354 $ CALL
dswap( nrhs,
b( k+1, 1 ), ldb,
b( kp, 1 ), ldb )
360 CALL
dger( n-k-1, nrhs, -one, a( k+2, k ), 1,
b( k, 1 ),
361 $ ldb,
b( k+2, 1 ), ldb )
362 CALL
dger( n-k-1, nrhs, -one, a( k+2, k+1 ), 1,
363 $
b( k+1, 1 ), ldb,
b( k+2, 1 ), ldb )
369 akm1 = a( k, k ) / akm1k
370 ak = a( k+1, k+1 ) / akm1k
371 denom = akm1*ak - one
373 bkm1 =
b( k,
j ) / akm1k
374 bk =
b( k+1,
j ) / akm1k
375 b( k,
j ) = ( ak*bkm1-bk ) / denom
376 b( k+1,
j ) = ( akm1*bk-bkm1 ) / denom
397 IF( ipiv( k ).GT.0 )
THEN
405 $ CALL
dgemv(
'Transpose', n-k, nrhs, -one,
b( k+1, 1 ),
406 $ ldb, a( k+1, k ), 1, one,
b( k, 1 ), ldb )
412 $ CALL
dswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
422 CALL
dgemv(
'Transpose', n-k, nrhs, -one,
b( k+1, 1 ),
423 $ ldb, a( k+1, k ), 1, one,
b( k, 1 ), ldb )
424 CALL
dgemv(
'Transpose', n-k, nrhs, -one,
b( k+1, 1 ),
425 $ ldb, a( k+1, k-1 ), 1, one,
b( k-1, 1 ),
433 $ CALL
dswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
subroutine dger(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
DGER
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
logical function lsame(CA, CB)
LSAME
subroutine dscal(N, DA, DX, INCX)
DSCAL
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine dsytrs(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
DSYTRS
subroutine dswap(N, DX, INCX, DY, INCY)
DSWAP
subroutine dgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
DGEMV