131 SUBROUTINE zlavhp( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB,
140 CHARACTER diag, trans, uplo
141 INTEGER info, ldb, n, nrhs
145 COMPLEX*16 a( * ),
b( ldb, * )
152 parameter( one = ( 1.0d+0, 0.0d+0 ) )
156 INTEGER j, k, kc, kcnext, kp
157 COMPLEX*16 d11, d12, d21, d22, t1, t2
167 INTRINSIC abs, dconjg, max
174 IF( .NOT.
lsame( uplo,
'U' ) .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
176 ELSE IF( .NOT.
lsame( trans,
'N' ) .AND. .NOT.
lsame( trans,
'C' ) )
179 ELSE IF( .NOT.
lsame( diag,
'U' ) .AND. .NOT.
lsame( diag,
'N' ) )
182 ELSE IF( n.LT.0 )
THEN
184 ELSE IF( ldb.LT.max( 1, n ) )
THEN
188 CALL
xerbla(
'ZLAVHP ', -info )
197 nounit =
lsame( diag,
'N' )
203 IF(
lsame( trans,
'N' ) )
THEN
208 IF(
lsame( uplo,
'U' ) )
THEN
220 IF( ipiv( k ).GT.0 )
THEN
225 $ CALL
zscal( nrhs, a( kc+k-1 ),
b( k, 1 ), ldb )
233 CALL
zgeru( k-1, nrhs, one, a( kc ), 1,
b( k, 1 ),
234 $ ldb,
b( 1, 1 ), ldb )
240 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
255 d12 = a( kcnext+k-1 )
260 b( k,
j ) = d11*t1 + d12*t2
261 b( k+1,
j ) = d21*t1 + d22*t2
271 CALL
zgeru( k-1, nrhs, one, a( kc ), 1,
b( k, 1 ),
272 $ ldb,
b( 1, 1 ), ldb )
273 CALL
zgeru( k-1, nrhs, one, a( kcnext ), 1,
274 $
b( k+1, 1 ), ldb,
b( 1, 1 ), ldb )
278 kp = abs( ipiv( k ) )
280 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
296 kc = n*( n+1 ) / 2 + 1
305 IF( ipiv( k ).GT.0 )
THEN
312 $ CALL
zscal( nrhs, a( kc ),
b( k, 1 ), ldb )
321 CALL
zgeru( n-k, nrhs, one, a( kc+1 ), 1,
b( k, 1 ),
322 $ ldb,
b( k+1, 1 ), ldb )
328 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
336 kcnext = kc - ( n-k+2 )
348 b( k-1,
j ) = d11*t1 + d12*t2
349 b( k,
j ) = d21*t1 + d22*t2
359 CALL
zgeru( n-k, nrhs, one, a( kc+1 ), 1,
b( k, 1 ),
360 $ ldb,
b( k+1, 1 ), ldb )
361 CALL
zgeru( n-k, nrhs, one, a( kcnext+2 ), 1,
362 $
b( k-1, 1 ), ldb,
b( k+1, 1 ), ldb )
367 kp = abs( ipiv( k ) )
369 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
388 IF(
lsame( uplo,
'U' ) )
THEN
393 kc = n*( n+1 ) / 2 + 1
401 IF( ipiv( k ).GT.0 )
THEN
408 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
414 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
415 CALL
zgemv(
'Conjugate', k-1, nrhs, one,
b, ldb,
416 $ a( kc ), 1, one,
b( k, 1 ), ldb )
417 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
420 $ CALL
zscal( nrhs, a( kc+k-1 ),
b( k, 1 ), ldb )
426 kcnext = kc - ( k-1 )
431 kp = abs( ipiv( k ) )
433 $ CALL
zswap( nrhs,
b( k-1, 1 ), ldb,
b( kp, 1 ),
438 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
439 CALL
zgemv(
'Conjugate', k-2, nrhs, one,
b, ldb,
440 $ a( kc ), 1, one,
b( k, 1 ), ldb )
441 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
443 CALL
zlacgv( nrhs,
b( k-1, 1 ), ldb )
444 CALL
zgemv(
'Conjugate', k-2, nrhs, one,
b, ldb,
445 $ a( kcnext ), 1, one,
b( k-1, 1 ), ldb )
446 CALL
zlacgv( nrhs,
b( k-1, 1 ), ldb )
459 b( k-1,
j ) = d11*t1 + d12*t2
460 b( k,
j ) = d21*t1 + d22*t2
485 IF( ipiv( k ).GT.0 )
THEN
492 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
496 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
497 CALL
zgemv(
'Conjugate', n-k, nrhs, one,
b( k+1, 1 ),
498 $ ldb, a( kc+1 ), 1, one,
b( k, 1 ), ldb )
499 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
502 $ CALL
zscal( nrhs, a( kc ),
b( k, 1 ), ldb )
509 kcnext = kc + n - k + 1
514 kp = abs( ipiv( k ) )
516 $ CALL
zswap( nrhs,
b( k+1, 1 ), ldb,
b( kp, 1 ),
521 CALL
zlacgv( nrhs,
b( k+1, 1 ), ldb )
522 CALL
zgemv(
'Conjugate', n-k-1, nrhs, one,
523 $
b( k+2, 1 ), ldb, a( kcnext+1 ), 1, one,
525 CALL
zlacgv( nrhs,
b( k+1, 1 ), ldb )
527 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
528 CALL
zgemv(
'Conjugate', n-k-1, nrhs, one,
529 $
b( k+2, 1 ), ldb, a( kc+2 ), 1, one,
531 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
544 b( k,
j ) = d11*t1 + d12*t2
545 b( k+1,
j ) = d21*t1 + d22*t2
548 kc = kcnext + ( n-k )
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 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 zlavhp(UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB, INFO)
ZLAVHP
subroutine zscal(N, ZA, ZX, INCX)
ZSCAL
subroutine zgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
ZGERU