116 SUBROUTINE zhptrs( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
125 INTEGER info, ldb, n, nrhs
129 COMPLEX*16 ap( * ),
b( ldb, * )
136 parameter( one = ( 1.0d+0, 0.0d+0 ) )
142 COMPLEX*16 ak, akm1, akm1k, bk, bkm1, denom
152 INTRINSIC dble, dconjg, max
157 upper =
lsame( uplo,
'U' )
158 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
160 ELSE IF( n.LT.0 )
THEN
162 ELSE IF( nrhs.LT.0 )
THEN
164 ELSE IF( ldb.LT.max( 1, n ) )
THEN
168 CALL
xerbla(
'ZHPTRS', -info )
174 IF( n.EQ.0 .OR. nrhs.EQ.0 )
187 kc = n*( n+1 ) / 2 + 1
196 IF( ipiv( k ).GT.0 )
THEN
204 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
209 CALL
zgeru( k-1, nrhs, -one, ap( kc ), 1,
b( k, 1 ), ldb,
214 s = dble( one ) / dble( ap( kc+k-1 ) )
215 CALL
zdscal( nrhs, s,
b( k, 1 ), ldb )
225 $ CALL
zswap( nrhs,
b( k-1, 1 ), ldb,
b( kp, 1 ), ldb )
230 CALL
zgeru( k-2, nrhs, -one, ap( kc ), 1,
b( k, 1 ), ldb,
232 CALL
zgeru( k-2, nrhs, -one, ap( kc-( k-1 ) ), 1,
233 $
b( k-1, 1 ), ldb,
b( 1, 1 ), ldb )
238 akm1 = ap( kc-1 ) / akm1k
239 ak = ap( kc+k-1 ) / dconjg( akm1k )
240 denom = akm1*ak - one
242 bkm1 =
b( k-1,
j ) / akm1k
243 bk =
b( k,
j ) / dconjg( akm1k )
244 b( k-1,
j ) = ( ak*bkm1-bk ) / denom
245 b( k,
j ) = ( akm1*bk-bkm1 ) / denom
268 IF( ipiv( k ).GT.0 )
THEN
276 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
277 CALL
zgemv(
'Conjugate transpose', k-1, nrhs, -one,
b,
278 $ ldb, ap( kc ), 1, one,
b( k, 1 ), ldb )
279 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
286 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
297 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
298 CALL
zgemv(
'Conjugate transpose', k-1, nrhs, -one,
b,
299 $ ldb, ap( kc ), 1, one,
b( k, 1 ), ldb )
300 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
302 CALL
zlacgv( nrhs,
b( k+1, 1 ), ldb )
303 CALL
zgemv(
'Conjugate transpose', k-1, nrhs, -one,
b,
304 $ ldb, ap( kc+k ), 1, one,
b( k+1, 1 ), ldb )
305 CALL
zlacgv( nrhs,
b( k+1, 1 ), ldb )
312 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
338 IF( ipiv( k ).GT.0 )
THEN
346 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
352 $ CALL
zgeru( n-k, nrhs, -one, ap( kc+1 ), 1,
b( k, 1 ),
353 $ ldb,
b( k+1, 1 ), ldb )
357 s = dble( one ) / dble( ap( kc ) )
358 CALL
zdscal( nrhs, s,
b( k, 1 ), ldb )
369 $ CALL
zswap( nrhs,
b( k+1, 1 ), ldb,
b( kp, 1 ), ldb )
375 CALL
zgeru( n-k-1, nrhs, -one, ap( kc+2 ), 1,
b( k, 1 ),
376 $ ldb,
b( k+2, 1 ), ldb )
377 CALL
zgeru( n-k-1, nrhs, -one, ap( kc+n-k+2 ), 1,
378 $
b( k+1, 1 ), ldb,
b( k+2, 1 ), ldb )
384 akm1 = ap( kc ) / dconjg( akm1k )
385 ak = ap( kc+n-k+1 ) / akm1k
386 denom = akm1*ak - one
388 bkm1 =
b( k,
j ) / dconjg( akm1k )
389 bk =
b( k+1,
j ) / akm1k
390 b( k,
j ) = ( ak*bkm1-bk ) / denom
391 b( k+1,
j ) = ( akm1*bk-bkm1 ) / denom
393 kc = kc + 2*( n-k ) + 1
406 kc = n*( n+1 ) / 2 + 1
415 IF( ipiv( k ).GT.0 )
THEN
423 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
424 CALL
zgemv(
'Conjugate transpose', n-k, nrhs, -one,
425 $
b( k+1, 1 ), ldb, ap( kc+1 ), 1, one,
427 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
434 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
444 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
445 CALL
zgemv(
'Conjugate transpose', n-k, nrhs, -one,
446 $
b( k+1, 1 ), ldb, ap( kc+1 ), 1, one,
448 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
450 CALL
zlacgv( nrhs,
b( k-1, 1 ), ldb )
451 CALL
zgemv(
'Conjugate transpose', n-k, nrhs, -one,
452 $
b( k+1, 1 ), ldb, ap( kc-( n-k ) ), 1, one,
454 CALL
zlacgv( nrhs,
b( k-1, 1 ), ldb )
461 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
LOGICAL function lsame(CA, CB)
LSAME
subroutine zgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZGEMV
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
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.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine zhptrs(UPLO, N, NRHS, AP, IPIV, B, LDB, INFO)
ZHPTRS
subroutine zgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
ZGERU