127 SUBROUTINE zhetrs2( 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
154 COMPLEX*16 ak, akm1, akm1k, bk, bkm1, denom
164 INTRINSIC dble, dconjg, max
169 upper =
lsame( uplo,
'U' )
170 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
172 ELSE IF( n.LT.0 )
THEN
174 ELSE IF( nrhs.LT.0 )
THEN
176 ELSE IF( lda.LT.max( 1, n ) )
THEN
178 ELSE IF( ldb.LT.max( 1, n ) )
THEN
182 CALL
xerbla(
'ZHETRS2', -info )
188 IF( n.EQ.0 .OR. nrhs.EQ.0 )
193 CALL
zsyconv( uplo,
'C', n, a, lda, ipiv, work, iinfo )
201 DO WHILE ( k .GE. 1 )
202 IF( ipiv( k ).GT.0 )
THEN
207 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
213 IF( kp.EQ.-ipiv( k-1 ) )
214 $ CALL
zswap( nrhs,
b( k-1, 1 ), ldb,
b( kp, 1 ), ldb )
221 CALL
ztrsm(
'L',
'U',
'N',
'U',n,nrhs,one,a,lda,
b,ldb)
226 DO WHILE ( i .GE. 1 )
227 IF( ipiv(i) .GT. 0 )
THEN
228 s = dble( one ) / dble( a( i, i ) )
229 CALL
zdscal( nrhs, s,
b( i, 1 ), ldb )
230 ELSEIF ( i .GT. 1)
THEN
231 IF ( ipiv(i-1) .EQ. ipiv(i) )
THEN
233 akm1 = a( i-1, i-1 ) / akm1k
234 ak = a( i, i ) / dconjg( akm1k )
235 denom = akm1*ak - one
237 bkm1 =
b( i-1,
j ) / akm1k
238 bk =
b( i,
j ) / dconjg( akm1k )
239 b( i-1,
j ) = ( ak*bkm1-bk ) / denom
240 b( i,
j ) = ( akm1*bk-bkm1 ) / denom
250 CALL
ztrsm(
'L',
'U',
'C',
'U',n,nrhs,one,a,lda,
b,ldb)
255 DO WHILE ( k .LE. n )
256 IF( ipiv( k ).GT.0 )
THEN
261 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
267 IF( k .LT. n .AND. kp.EQ.-ipiv( k+1 ) )
268 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
279 DO WHILE ( k .LE. n )
280 IF( ipiv( k ).GT.0 )
THEN
285 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
291 IF( kp.EQ.-ipiv( k ) )
292 $ CALL
zswap( nrhs,
b( k+1, 1 ), ldb,
b( kp, 1 ), ldb )
299 CALL
ztrsm(
'L',
'L',
'N',
'U',n,nrhs,one,a,lda,
b,ldb)
304 DO WHILE ( i .LE. n )
305 IF( ipiv(i) .GT. 0 )
THEN
306 s = dble( one ) / dble( a( i, i ) )
307 CALL
zdscal( nrhs, s,
b( i, 1 ), ldb )
310 akm1 = a( i, i ) / dconjg( akm1k )
311 ak = a( i+1, i+1 ) / akm1k
312 denom = akm1*ak - one
314 bkm1 =
b( i,
j ) / dconjg( akm1k )
315 bk =
b( i+1,
j ) / akm1k
316 b( i,
j ) = ( ak*bkm1-bk ) / denom
317 b( i+1,
j ) = ( akm1*bk-bkm1 ) / denom
326 CALL
ztrsm(
'L',
'L',
'C',
'U',n,nrhs,one,a,lda,
b,ldb)
331 DO WHILE ( k .GE. 1 )
332 IF( ipiv( k ).GT.0 )
THEN
337 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
343 IF( k.GT.1 .AND. kp.EQ.-ipiv( k-1 ) )
344 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
353 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 zdscal(N, DA, ZX, INCX)
ZDSCAL
subroutine zhetrs2(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO)
ZHETRS2
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine zlacgv(N, X, INCX)
ZLACGV conjugates a complex vector.
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