131 SUBROUTINE clavhp( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB,
140 CHARACTER DIAG, TRANS, UPLO
141 INTEGER INFO, LDB, N, NRHS
145 COMPLEX A( * ), B( ldb, * )
152 parameter( one = ( 1.0e+0, 0.0e+0 ) )
156 INTEGER J, K, KC, KCNEXT, KP
157 COMPLEX D11, D12, D21, D22, T1, T2
167 INTRINSIC abs, conjg, 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(
'CLAVHP ', -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
cscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
233 CALL
cgeru( k-1, nrhs, one, a( kc ), 1, b( k, 1 ),
234 $ ldb, b( 1, 1 ), ldb )
240 $ CALL cswap( 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
cgeru( k-1, nrhs, one, a( kc ), 1, b( k, 1 ),
272 $ ldb, b( 1, 1 ), ldb )
273 CALL
cgeru( k-1, nrhs, one, a( kcnext ), 1,
274 $ b( k+1, 1 ), ldb, b( 1, 1 ), ldb )
278 kp = abs( ipiv( k ) )
280 $ CALL cswap( 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
cscal( nrhs, a( kc ), b( k, 1 ), ldb )
321 CALL
cgeru( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
322 $ ldb, b( k+1, 1 ), ldb )
328 $ CALL cswap( 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
cgeru( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
360 $ ldb, b( k+1, 1 ), ldb )
361 CALL
cgeru( 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 cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
388 IF( lsame( uplo,
'U' ) )
THEN
393 kc = n*( n+1 ) / 2 + 1
400 IF( ipiv( k ).GT.0 )
THEN
407 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
413 CALL
clacgv( nrhs, b( k, 1 ), ldb )
414 CALL
cgemv(
'Conjugate', k-1, nrhs, one, b, ldb,
415 $ a( kc ), 1, one, b( k, 1 ), ldb )
416 CALL
clacgv( nrhs, b( k, 1 ), ldb )
419 $ CALL
cscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
425 kcnext = kc - ( k-1 )
430 kp = abs( ipiv( k ) )
432 $ CALL cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
437 CALL
clacgv( nrhs, b( k, 1 ), ldb )
438 CALL
cgemv(
'Conjugate', k-2, nrhs, one, b, ldb,
439 $ a( kc ), 1, one, b( k, 1 ), ldb )
440 CALL
clacgv( nrhs, b( k, 1 ), ldb )
442 CALL
clacgv( nrhs, b( k-1, 1 ), ldb )
443 CALL
cgemv(
'Conjugate', k-2, nrhs, one, b, ldb,
444 $ a( kcnext ), 1, one, b( k-1, 1 ), ldb )
445 CALL
clacgv( nrhs, b( k-1, 1 ), ldb )
458 b( k-1, j ) = d11*t1 + d12*t2
459 b( k, j ) = d21*t1 + d22*t2
484 IF( ipiv( k ).GT.0 )
THEN
491 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
495 CALL
clacgv( nrhs, b( k, 1 ), ldb )
496 CALL
cgemv(
'Conjugate', n-k, nrhs, one, b( k+1, 1 ),
497 $ ldb, a( kc+1 ), 1, one, b( k, 1 ), ldb )
498 CALL
clacgv( nrhs, b( k, 1 ), ldb )
501 $ CALL
cscal( nrhs, a( kc ), b( k, 1 ), ldb )
508 kcnext = kc + n - k + 1
513 kp = abs( ipiv( k ) )
515 $ CALL cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
520 CALL
clacgv( nrhs, b( k+1, 1 ), ldb )
521 CALL
cgemv(
'Conjugate', n-k-1, nrhs, one,
522 $ b( k+2, 1 ), ldb, a( kcnext+1 ), 1, one,
524 CALL
clacgv( nrhs, b( k+1, 1 ), ldb )
526 CALL
clacgv( nrhs, b( k, 1 ), ldb )
527 CALL
cgemv(
'Conjugate', n-k-1, nrhs, one,
528 $ b( k+2, 1 ), ldb, a( kc+2 ), 1, one,
530 CALL
clacgv( nrhs, b( k, 1 ), ldb )
543 b( k, j ) = d11*t1 + d12*t2
544 b( k+1, j ) = d21*t1 + d22*t2
547 kc = kcnext + ( n-k )
subroutine cscal(N, CA, CX, INCX)
CSCAL
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine clacgv(N, X, INCX)
CLACGV conjugates a complex vector.
subroutine cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
subroutine clavhp(UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB, INFO)
CLAVHP
subroutine cgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CGERU