127 SUBROUTINE chetrs2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
137 INTEGER INFO, LDA, LDB, N, NRHS
141 COMPLEX A( lda, * ), B( ldb, * ), WORK( * )
148 parameter ( one = (1.0e+0,0.0e+0) )
152 INTEGER I, IINFO, J, K, KP
154 COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM
164 INTRINSIC conjg, max, real
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(
'CHETRS2', -info )
188 IF( n.EQ.0 .OR. nrhs.EQ.0 )
193 CALL csyconv( uplo,
'C', n, a, lda, ipiv, work, iinfo )
201 DO WHILE ( k .GE. 1 )
202 IF( ipiv( k ).GT.0 )
THEN
207 $
CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
213 IF( kp.EQ.-ipiv( k-1 ) )
214 $
CALL cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
221 CALL ctrsm(
'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 =
REAL( ONE ) /
REAL( A( I, I ) )
229 CALL csscal( 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 ) / conjg( akm1k )
235 denom = akm1*ak - one
237 bkm1 = b( i-1, j ) / akm1k
238 bk = b( i, j ) / conjg( akm1k )
239 b( i-1, j ) = ( ak*bkm1-bk ) / denom
240 b( i, j ) = ( akm1*bk-bkm1 ) / denom
250 CALL ctrsm(
'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 cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
267 IF( k .LT. n .AND. kp.EQ.-ipiv( k+1 ) )
268 $
CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
279 DO WHILE ( k .LE. n )
280 IF( ipiv( k ).GT.0 )
THEN
285 $
CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
291 IF( kp.EQ.-ipiv( k ) )
292 $
CALL cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
299 CALL ctrsm(
'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 =
REAL( ONE ) /
REAL( A( I, I ) )
307 CALL csscal( nrhs, s, b( i, 1 ), ldb )
310 akm1 = a( i, i ) / conjg( akm1k )
311 ak = a( i+1, i+1 ) / akm1k
312 denom = akm1*ak - one
314 bkm1 = b( i, j ) / conjg( 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 ctrsm(
'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 cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
343 IF( k.GT.1 .AND. kp.EQ.-ipiv( k-1 ) )
344 $
CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
353 CALL csyconv( uplo,
'R', n, a, lda, ipiv, work, iinfo )
subroutine ctrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
CTRSM
subroutine chetrs2(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO)
CHETRS2
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine csyconv(UPLO, WAY, N, A, LDA, IPIV, E, INFO)
CSYCONV
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine csscal(N, SA, CX, INCX)
CSSCAL