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 zsyconv(UPLO, WAY, N, A, LDA, IPIV, E, INFO)
ZSYCONV
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
subroutine zhetrs2(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO)
ZHETRS2
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
subroutine ztrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
ZTRSM
subroutine zscal(N, ZA, ZX, INCX)
ZSCAL
subroutine zlacgv(N, X, INCX)
ZLACGV conjugates a complex vector.