127 SUBROUTINE zsytrs2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
137 INTEGER info, lda, ldb, n, nrhs
141 COMPLEX*16 a( lda, * ),
b( ldb, * ), work( * )
148 parameter( one = (1.0d+0,0.0d+0) )
152 INTEGER i, iinfo,
j, k, kp
153 COMPLEX*16 ak, akm1, akm1k, bk, bkm1, denom
168 upper =
lsame( uplo,
'U' )
169 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
171 ELSE IF( n.LT.0 )
THEN
173 ELSE IF( nrhs.LT.0 )
THEN
175 ELSE IF( lda.LT.max( 1, n ) )
THEN
177 ELSE IF( ldb.LT.max( 1, n ) )
THEN
181 CALL
xerbla(
'ZSYTRS2', -info )
187 IF( n.EQ.0 .OR. nrhs.EQ.0 )
192 CALL
zsyconv( uplo,
'C', n, a, lda, ipiv, work, iinfo )
200 DO WHILE ( k .GE. 1 )
201 IF( ipiv( k ).GT.0 )
THEN
206 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
212 IF( kp.EQ.-ipiv( k-1 ) )
213 $ CALL
zswap( nrhs,
b( k-1, 1 ), ldb,
b( kp, 1 ), ldb )
220 CALL
ztrsm(
'L',
'U',
'N',
'U',n,nrhs,one,a,lda,
b,ldb)
225 DO WHILE ( i .GE. 1 )
226 IF( ipiv(i) .GT. 0 )
THEN
227 CALL
zscal( nrhs, one / a( i, i ),
b( i, 1 ), ldb )
228 ELSEIF ( i .GT. 1)
THEN
229 IF ( ipiv(i-1) .EQ. ipiv(i) )
THEN
231 akm1 = a( i-1, i-1 ) / akm1k
232 ak = a( i, i ) / akm1k
233 denom = akm1*ak - one
235 bkm1 =
b( i-1,
j ) / akm1k
236 bk =
b( i,
j ) / akm1k
237 b( i-1,
j ) = ( ak*bkm1-bk ) / denom
238 b( i,
j ) = ( akm1*bk-bkm1 ) / denom
248 CALL
ztrsm(
'L',
'U',
'T',
'U',n,nrhs,one,a,lda,
b,ldb)
253 DO WHILE ( k .LE. n )
254 IF( ipiv( k ).GT.0 )
THEN
259 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
265 IF( k .LT. n .AND. kp.EQ.-ipiv( k+1 ) )
266 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
277 DO WHILE ( k .LE. n )
278 IF( ipiv( k ).GT.0 )
THEN
283 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
289 IF( kp.EQ.-ipiv( k ) )
290 $ CALL
zswap( nrhs,
b( k+1, 1 ), ldb,
b( kp, 1 ), ldb )
297 CALL
ztrsm(
'L',
'L',
'N',
'U',n,nrhs,one,a,lda,
b,ldb)
302 DO WHILE ( i .LE. n )
303 IF( ipiv(i) .GT. 0 )
THEN
304 CALL
zscal( nrhs, one / a( i, i ),
b( i, 1 ), ldb )
307 akm1 = a( i, i ) / akm1k
308 ak = a( i+1, i+1 ) / akm1k
309 denom = akm1*ak - one
311 bkm1 =
b( i,
j ) / akm1k
312 bk =
b( i+1,
j ) / akm1k
313 b( i,
j ) = ( ak*bkm1-bk ) / denom
314 b( i+1,
j ) = ( akm1*bk-bkm1 ) / denom
323 CALL
ztrsm(
'L',
'L',
'T',
'U',n,nrhs,one,a,lda,
b,ldb)
328 DO WHILE ( k .GE. 1 )
329 IF( ipiv( k ).GT.0 )
THEN
334 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
340 IF( k.GT.1 .AND. kp.EQ.-ipiv( k-1 ) )
341 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
350 CALL
zsyconv( uplo,
'R', n, a, lda, ipiv, work, iinfo )
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
LOGICAL function lsame(CA, CB)
LSAME
subroutine ztrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
ZTRSM
subroutine zsytrs2(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO)
ZSYTRS2
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine zsyconv(UPLO, WAY, N, A, LDA, IPIV, WORK, INFO)
ZSYCONV
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine zscal(N, ZA, ZX, INCX)
ZSCAL