146 INTEGER info, lda, ldb, n, nrhs
150 COMPLEX*16 a( lda, * ),
b( ldb, * )
157 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
162 COMPLEX*16 ak, akm1, akm1k, bk, bkm1, denom
177 upper =
lsame( uplo,
'U' )
178 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
180 ELSE IF( n.LT.0 )
THEN
182 ELSE IF( nrhs.LT.0 )
THEN
184 ELSE IF( lda.LT.max( 1, n ) )
THEN
186 ELSE IF( ldb.LT.max( 1, n ) )
THEN
190 CALL
xerbla(
'ZSYTRS_ROOK', -info )
196 IF( n.EQ.0 .OR. nrhs.EQ.0 )
216 IF( ipiv( k ).GT.0 )
THEN
224 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
229 CALL
zgeru( k-1, nrhs, -cone, a( 1, k ), 1,
b( k, 1 ), ldb,
234 CALL
zscal( nrhs, cone / a( k, k ),
b( k, 1 ), ldb )
244 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
248 $ CALL
zswap( nrhs,
b( k-1, 1 ), ldb,
b( kp, 1 ), ldb )
254 CALL
zgeru( k-2, nrhs,-cone, a( 1, k ), 1,
b( k, 1 ),
255 $ ldb,
b( 1, 1 ), ldb )
256 CALL
zgeru( k-2, nrhs,-cone, a( 1, k-1 ), 1,
b( k-1, 1 ),
257 $ ldb,
b( 1, 1 ), ldb )
263 akm1 = a( k-1, k-1 ) / akm1k
264 ak = a( k, k ) / akm1k
265 denom = akm1*ak - cone
267 bkm1 =
b( k-1,
j ) / akm1k
268 bk =
b( k,
j ) / akm1k
269 b( k-1,
j ) = ( ak*bkm1-bk ) / denom
270 b( k,
j ) = ( akm1*bk-bkm1 ) / denom
291 IF( ipiv( k ).GT.0 )
THEN
299 $ CALL
zgemv(
'Transpose', k-1, nrhs, -cone,
b,
300 $ ldb, a( 1, k ), 1, cone,
b( k, 1 ), ldb )
306 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
316 CALL
zgemv(
'Transpose', k-1, nrhs, -cone,
b,
317 $ ldb, a( 1, k ), 1, cone,
b( k, 1 ), ldb )
318 CALL
zgemv(
'Transpose', k-1, nrhs, -cone,
b,
319 $ ldb, a( 1, k+1 ), 1, cone,
b( k+1, 1 ), ldb )
326 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
330 $ CALL
zswap( nrhs,
b( k+1, 1 ), ldb,
b( kp, 1 ), ldb )
355 IF( ipiv( k ).GT.0 )
THEN
363 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
369 $ CALL
zgeru( n-k, nrhs, -cone, a( k+1, k ), 1,
b( k, 1 ),
370 $ ldb,
b( k+1, 1 ), ldb )
374 CALL
zscal( nrhs, cone / a( k, k ),
b( k, 1 ), ldb )
384 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
388 $ CALL
zswap( nrhs,
b( k+1, 1 ), ldb,
b( kp, 1 ), ldb )
394 CALL
zgeru( n-k-1, nrhs,-cone, a( k+2, k ), 1,
b( k, 1 ),
395 $ ldb,
b( k+2, 1 ), ldb )
396 CALL
zgeru( n-k-1, nrhs,-cone, a( k+2, k+1 ), 1,
397 $
b( k+1, 1 ), ldb,
b( k+2, 1 ), ldb )
403 akm1 = a( k, k ) / akm1k
404 ak = a( k+1, k+1 ) / akm1k
405 denom = akm1*ak - cone
407 bkm1 =
b( k,
j ) / akm1k
408 bk =
b( k+1,
j ) / akm1k
409 b( k,
j ) = ( ak*bkm1-bk ) / denom
410 b( k+1,
j ) = ( akm1*bk-bkm1 ) / denom
431 IF( ipiv( k ).GT.0 )
THEN
439 $ CALL
zgemv(
'Transpose', n-k, nrhs, -cone,
b( k+1, 1 ),
440 $ ldb, a( k+1, k ), 1, cone,
b( k, 1 ), ldb )
446 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
456 CALL
zgemv(
'Transpose', n-k, nrhs, -cone,
b( k+1, 1 ),
457 $ ldb, a( k+1, k ), 1, cone,
b( k, 1 ), ldb )
458 CALL
zgemv(
'Transpose', n-k, nrhs, -cone,
b( k+1, 1 ),
459 $ ldb, a( k+1, k-1 ), 1, cone,
b( k-1, 1 ),
467 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
471 $ CALL
zswap( nrhs,
b( k-1, 1 ), ldb,
b( kp, 1 ), ldb )
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
subroutine zgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZGEMV
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 zsytrs_rook(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
ZSYTRS_ROOK
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine zscal(N, ZA, ZX, INCX)
ZSCAL
subroutine zgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
ZGERU