1467 lines
48 KiB
Fortran
1467 lines
48 KiB
Fortran
*> \brief \b CHBGST
|
|
*
|
|
* =========== DOCUMENTATION ===========
|
|
*
|
|
* Online html documentation available at
|
|
* http://www.netlib.org/lapack/explore-html/
|
|
*
|
|
*> \htmlonly
|
|
*> Download CHBGST + dependencies
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chbgst.f">
|
|
*> [TGZ]</a>
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chbgst.f">
|
|
*> [ZIP]</a>
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chbgst.f">
|
|
*> [TXT]</a>
|
|
*> \endhtmlonly
|
|
*
|
|
* Definition:
|
|
* ===========
|
|
*
|
|
* SUBROUTINE CHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X,
|
|
* LDX, WORK, RWORK, INFO )
|
|
*
|
|
* .. Scalar Arguments ..
|
|
* CHARACTER UPLO, VECT
|
|
* INTEGER INFO, KA, KB, LDAB, LDBB, LDX, N
|
|
* ..
|
|
* .. Array Arguments ..
|
|
* REAL RWORK( * )
|
|
* COMPLEX AB( LDAB, * ), BB( LDBB, * ), WORK( * ),
|
|
* $ X( LDX, * )
|
|
* ..
|
|
*
|
|
*
|
|
*> \par Purpose:
|
|
* =============
|
|
*>
|
|
*> \verbatim
|
|
*>
|
|
*> CHBGST reduces a complex Hermitian-definite banded generalized
|
|
*> eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,
|
|
*> such that C has the same bandwidth as A.
|
|
*>
|
|
*> B must have been previously factorized as S**H*S by CPBSTF, using a
|
|
*> split Cholesky factorization. A is overwritten by C = X**H*A*X, where
|
|
*> X = S**(-1)*Q and Q is a unitary matrix chosen to preserve the
|
|
*> bandwidth of A.
|
|
*> \endverbatim
|
|
*
|
|
* Arguments:
|
|
* ==========
|
|
*
|
|
*> \param[in] VECT
|
|
*> \verbatim
|
|
*> VECT is CHARACTER*1
|
|
*> = 'N': do not form the transformation matrix X;
|
|
*> = 'V': form X.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[in] UPLO
|
|
*> \verbatim
|
|
*> UPLO is CHARACTER*1
|
|
*> = 'U': Upper triangle of A is stored;
|
|
*> = 'L': Lower triangle of A is stored.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[in] N
|
|
*> \verbatim
|
|
*> N is INTEGER
|
|
*> The order of the matrices A and B. N >= 0.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[in] KA
|
|
*> \verbatim
|
|
*> KA is INTEGER
|
|
*> The number of superdiagonals of the matrix A if UPLO = 'U',
|
|
*> or the number of subdiagonals if UPLO = 'L'. KA >= 0.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[in] KB
|
|
*> \verbatim
|
|
*> KB is INTEGER
|
|
*> The number of superdiagonals of the matrix B if UPLO = 'U',
|
|
*> or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[in,out] AB
|
|
*> \verbatim
|
|
*> AB is COMPLEX array, dimension (LDAB,N)
|
|
*> On entry, the upper or lower triangle of the Hermitian band
|
|
*> matrix A, stored in the first ka+1 rows of the array. The
|
|
*> j-th column of A is stored in the j-th column of the array AB
|
|
*> as follows:
|
|
*> if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
|
|
*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
|
|
*>
|
|
*> On exit, the transformed matrix X**H*A*X, stored in the same
|
|
*> format as A.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[in] LDAB
|
|
*> \verbatim
|
|
*> LDAB is INTEGER
|
|
*> The leading dimension of the array AB. LDAB >= KA+1.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[in] BB
|
|
*> \verbatim
|
|
*> BB is COMPLEX array, dimension (LDBB,N)
|
|
*> The banded factor S from the split Cholesky factorization of
|
|
*> B, as returned by CPBSTF, stored in the first kb+1 rows of
|
|
*> the array.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[in] LDBB
|
|
*> \verbatim
|
|
*> LDBB is INTEGER
|
|
*> The leading dimension of the array BB. LDBB >= KB+1.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[out] X
|
|
*> \verbatim
|
|
*> X is COMPLEX array, dimension (LDX,N)
|
|
*> If VECT = 'V', the n-by-n matrix X.
|
|
*> If VECT = 'N', the array X is not referenced.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[in] LDX
|
|
*> \verbatim
|
|
*> LDX is INTEGER
|
|
*> The leading dimension of the array X.
|
|
*> LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[out] WORK
|
|
*> \verbatim
|
|
*> WORK is COMPLEX array, dimension (N)
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[out] RWORK
|
|
*> \verbatim
|
|
*> RWORK is REAL array, dimension (N)
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[out] INFO
|
|
*> \verbatim
|
|
*> INFO is INTEGER
|
|
*> = 0: successful exit
|
|
*> < 0: if INFO = -i, the i-th argument had an illegal value.
|
|
*> \endverbatim
|
|
*
|
|
* Authors:
|
|
* ========
|
|
*
|
|
*> \author Univ. of Tennessee
|
|
*> \author Univ. of California Berkeley
|
|
*> \author Univ. of Colorado Denver
|
|
*> \author NAG Ltd.
|
|
*
|
|
*> \ingroup complexOTHERcomputational
|
|
*
|
|
* =====================================================================
|
|
SUBROUTINE CHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X,
|
|
$ LDX, WORK, RWORK, INFO )
|
|
*
|
|
* -- LAPACK computational routine --
|
|
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
|
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
|
*
|
|
* .. Scalar Arguments ..
|
|
CHARACTER UPLO, VECT
|
|
INTEGER INFO, KA, KB, LDAB, LDBB, LDX, N
|
|
* ..
|
|
* .. Array Arguments ..
|
|
REAL RWORK( * )
|
|
COMPLEX AB( LDAB, * ), BB( LDBB, * ), WORK( * ),
|
|
$ X( LDX, * )
|
|
* ..
|
|
*
|
|
* =====================================================================
|
|
*
|
|
* .. Parameters ..
|
|
COMPLEX CZERO, CONE
|
|
REAL ONE
|
|
PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ),
|
|
$ CONE = ( 1.0E+0, 0.0E+0 ), ONE = 1.0E+0 )
|
|
* ..
|
|
* .. Local Scalars ..
|
|
LOGICAL UPDATE, UPPER, WANTX
|
|
INTEGER I, I0, I1, I2, INCA, J, J1, J1T, J2, J2T, K,
|
|
$ KA1, KB1, KBT, L, M, NR, NRT, NX
|
|
REAL BII
|
|
COMPLEX RA, RA1, T
|
|
* ..
|
|
* .. External Functions ..
|
|
LOGICAL LSAME
|
|
EXTERNAL LSAME
|
|
* ..
|
|
* .. External Subroutines ..
|
|
EXTERNAL CGERC, CGERU, CLACGV, CLAR2V, CLARGV, CLARTG,
|
|
$ CLARTV, CLASET, CROT, CSSCAL, XERBLA
|
|
* ..
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC CONJG, MAX, MIN, REAL
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Test the input parameters
|
|
*
|
|
WANTX = LSAME( VECT, 'V' )
|
|
UPPER = LSAME( UPLO, 'U' )
|
|
KA1 = KA + 1
|
|
KB1 = KB + 1
|
|
INFO = 0
|
|
IF( .NOT.WANTX .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
|
|
INFO = -1
|
|
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
|
|
INFO = -2
|
|
ELSE IF( N.LT.0 ) THEN
|
|
INFO = -3
|
|
ELSE IF( KA.LT.0 ) THEN
|
|
INFO = -4
|
|
ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
|
|
INFO = -5
|
|
ELSE IF( LDAB.LT.KA+1 ) THEN
|
|
INFO = -7
|
|
ELSE IF( LDBB.LT.KB+1 ) THEN
|
|
INFO = -9
|
|
ELSE IF( LDX.LT.1 .OR. WANTX .AND. LDX.LT.MAX( 1, N ) ) THEN
|
|
INFO = -11
|
|
END IF
|
|
IF( INFO.NE.0 ) THEN
|
|
CALL XERBLA( 'CHBGST', -INFO )
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Quick return if possible
|
|
*
|
|
IF( N.EQ.0 )
|
|
$ RETURN
|
|
*
|
|
INCA = LDAB*KA1
|
|
*
|
|
* Initialize X to the unit matrix, if needed
|
|
*
|
|
IF( WANTX )
|
|
$ CALL CLASET( 'Full', N, N, CZERO, CONE, X, LDX )
|
|
*
|
|
* Set M to the splitting point m. It must be the same value as is
|
|
* used in CPBSTF. The chosen value allows the arrays WORK and RWORK
|
|
* to be of dimension (N).
|
|
*
|
|
M = ( N+KB ) / 2
|
|
*
|
|
* The routine works in two phases, corresponding to the two halves
|
|
* of the split Cholesky factorization of B as S**H*S where
|
|
*
|
|
* S = ( U )
|
|
* ( M L )
|
|
*
|
|
* with U upper triangular of order m, and L lower triangular of
|
|
* order n-m. S has the same bandwidth as B.
|
|
*
|
|
* S is treated as a product of elementary matrices:
|
|
*
|
|
* S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n)
|
|
*
|
|
* where S(i) is determined by the i-th row of S.
|
|
*
|
|
* In phase 1, the index i takes the values n, n-1, ... , m+1;
|
|
* in phase 2, it takes the values 1, 2, ... , m.
|
|
*
|
|
* For each value of i, the current matrix A is updated by forming
|
|
* inv(S(i))**H*A*inv(S(i)). This creates a triangular bulge outside
|
|
* the band of A. The bulge is then pushed down toward the bottom of
|
|
* A in phase 1, and up toward the top of A in phase 2, by applying
|
|
* plane rotations.
|
|
*
|
|
* There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1
|
|
* of them are linearly independent, so annihilating a bulge requires
|
|
* only 2*kb-1 plane rotations. The rotations are divided into a 1st
|
|
* set of kb-1 rotations, and a 2nd set of kb rotations.
|
|
*
|
|
* Wherever possible, rotations are generated and applied in vector
|
|
* operations of length NR between the indices J1 and J2 (sometimes
|
|
* replaced by modified values NRT, J1T or J2T).
|
|
*
|
|
* The real cosines and complex sines of the rotations are stored in
|
|
* the arrays RWORK and WORK, those of the 1st set in elements
|
|
* 2:m-kb-1, and those of the 2nd set in elements m-kb+1:n.
|
|
*
|
|
* The bulges are not formed explicitly; nonzero elements outside the
|
|
* band are created only when they are required for generating new
|
|
* rotations; they are stored in the array WORK, in positions where
|
|
* they are later overwritten by the sines of the rotations which
|
|
* annihilate them.
|
|
*
|
|
* **************************** Phase 1 *****************************
|
|
*
|
|
* The logical structure of this phase is:
|
|
*
|
|
* UPDATE = .TRUE.
|
|
* DO I = N, M + 1, -1
|
|
* use S(i) to update A and create a new bulge
|
|
* apply rotations to push all bulges KA positions downward
|
|
* END DO
|
|
* UPDATE = .FALSE.
|
|
* DO I = M + KA + 1, N - 1
|
|
* apply rotations to push all bulges KA positions downward
|
|
* END DO
|
|
*
|
|
* To avoid duplicating code, the two loops are merged.
|
|
*
|
|
UPDATE = .TRUE.
|
|
I = N + 1
|
|
10 CONTINUE
|
|
IF( UPDATE ) THEN
|
|
I = I - 1
|
|
KBT = MIN( KB, I-1 )
|
|
I0 = I - 1
|
|
I1 = MIN( N, I+KA )
|
|
I2 = I - KBT + KA1
|
|
IF( I.LT.M+1 ) THEN
|
|
UPDATE = .FALSE.
|
|
I = I + 1
|
|
I0 = M
|
|
IF( KA.EQ.0 )
|
|
$ GO TO 480
|
|
GO TO 10
|
|
END IF
|
|
ELSE
|
|
I = I + KA
|
|
IF( I.GT.N-1 )
|
|
$ GO TO 480
|
|
END IF
|
|
*
|
|
IF( UPPER ) THEN
|
|
*
|
|
* Transform A, working with the upper triangle
|
|
*
|
|
IF( UPDATE ) THEN
|
|
*
|
|
* Form inv(S(i))**H * A * inv(S(i))
|
|
*
|
|
BII = REAL( BB( KB1, I ) )
|
|
AB( KA1, I ) = ( REAL( AB( KA1, I ) ) / BII ) / BII
|
|
DO 20 J = I + 1, I1
|
|
AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII
|
|
20 CONTINUE
|
|
DO 30 J = MAX( 1, I-KA ), I - 1
|
|
AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII
|
|
30 CONTINUE
|
|
DO 60 K = I - KBT, I - 1
|
|
DO 40 J = I - KBT, K
|
|
AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
|
|
$ BB( J-I+KB1, I )*
|
|
$ CONJG( AB( K-I+KA1, I ) ) -
|
|
$ CONJG( BB( K-I+KB1, I ) )*
|
|
$ AB( J-I+KA1, I ) +
|
|
$ REAL( AB( KA1, I ) )*
|
|
$ BB( J-I+KB1, I )*
|
|
$ CONJG( BB( K-I+KB1, I ) )
|
|
40 CONTINUE
|
|
DO 50 J = MAX( 1, I-KA ), I - KBT - 1
|
|
AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
|
|
$ CONJG( BB( K-I+KB1, I ) )*
|
|
$ AB( J-I+KA1, I )
|
|
50 CONTINUE
|
|
60 CONTINUE
|
|
DO 80 J = I, I1
|
|
DO 70 K = MAX( J-KA, I-KBT ), I - 1
|
|
AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
|
|
$ BB( K-I+KB1, I )*AB( I-J+KA1, J )
|
|
70 CONTINUE
|
|
80 CONTINUE
|
|
*
|
|
IF( WANTX ) THEN
|
|
*
|
|
* post-multiply X by inv(S(i))
|
|
*
|
|
CALL CSSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
|
|
IF( KBT.GT.0 )
|
|
$ CALL CGERC( N-M, KBT, -CONE, X( M+1, I ), 1,
|
|
$ BB( KB1-KBT, I ), 1, X( M+1, I-KBT ),
|
|
$ LDX )
|
|
END IF
|
|
*
|
|
* store a(i,i1) in RA1 for use in next loop over K
|
|
*
|
|
RA1 = AB( I-I1+KA1, I1 )
|
|
END IF
|
|
*
|
|
* Generate and apply vectors of rotations to chase all the
|
|
* existing bulges KA positions down toward the bottom of the
|
|
* band
|
|
*
|
|
DO 130 K = 1, KB - 1
|
|
IF( UPDATE ) THEN
|
|
*
|
|
* Determine the rotations which would annihilate the bulge
|
|
* which has in theory just been created
|
|
*
|
|
IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN
|
|
*
|
|
* generate rotation to annihilate a(i,i-k+ka+1)
|
|
*
|
|
CALL CLARTG( AB( K+1, I-K+KA ), RA1,
|
|
$ RWORK( I-K+KA-M ), WORK( I-K+KA-M ), RA )
|
|
*
|
|
* create nonzero element a(i-k,i-k+ka+1) outside the
|
|
* band and store it in WORK(i-k)
|
|
*
|
|
T = -BB( KB1-K, I )*RA1
|
|
WORK( I-K ) = RWORK( I-K+KA-M )*T -
|
|
$ CONJG( WORK( I-K+KA-M ) )*
|
|
$ AB( 1, I-K+KA )
|
|
AB( 1, I-K+KA ) = WORK( I-K+KA-M )*T +
|
|
$ RWORK( I-K+KA-M )*AB( 1, I-K+KA )
|
|
RA1 = RA
|
|
END IF
|
|
END IF
|
|
J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
|
|
NR = ( N-J2+KA ) / KA1
|
|
J1 = J2 + ( NR-1 )*KA1
|
|
IF( UPDATE ) THEN
|
|
J2T = MAX( J2, I+2*KA-K+1 )
|
|
ELSE
|
|
J2T = J2
|
|
END IF
|
|
NRT = ( N-J2T+KA ) / KA1
|
|
DO 90 J = J2T, J1, KA1
|
|
*
|
|
* create nonzero element a(j-ka,j+1) outside the band
|
|
* and store it in WORK(j-m)
|
|
*
|
|
WORK( J-M ) = WORK( J-M )*AB( 1, J+1 )
|
|
AB( 1, J+1 ) = RWORK( J-M )*AB( 1, J+1 )
|
|
90 CONTINUE
|
|
*
|
|
* generate rotations in 1st set to annihilate elements which
|
|
* have been created outside the band
|
|
*
|
|
IF( NRT.GT.0 )
|
|
$ CALL CLARGV( NRT, AB( 1, J2T ), INCA, WORK( J2T-M ), KA1,
|
|
$ RWORK( J2T-M ), KA1 )
|
|
IF( NR.GT.0 ) THEN
|
|
*
|
|
* apply rotations in 1st set from the right
|
|
*
|
|
DO 100 L = 1, KA - 1
|
|
CALL CLARTV( NR, AB( KA1-L, J2 ), INCA,
|
|
$ AB( KA-L, J2+1 ), INCA, RWORK( J2-M ),
|
|
$ WORK( J2-M ), KA1 )
|
|
100 CONTINUE
|
|
*
|
|
* apply rotations in 1st set from both sides to diagonal
|
|
* blocks
|
|
*
|
|
CALL CLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ),
|
|
$ AB( KA, J2+1 ), INCA, RWORK( J2-M ),
|
|
$ WORK( J2-M ), KA1 )
|
|
*
|
|
CALL CLACGV( NR, WORK( J2-M ), KA1 )
|
|
END IF
|
|
*
|
|
* start applying rotations in 1st set from the left
|
|
*
|
|
DO 110 L = KA - 1, KB - K + 1, -1
|
|
NRT = ( N-J2+L ) / KA1
|
|
IF( NRT.GT.0 )
|
|
$ CALL CLARTV( NRT, AB( L, J2+KA1-L ), INCA,
|
|
$ AB( L+1, J2+KA1-L ), INCA, RWORK( J2-M ),
|
|
$ WORK( J2-M ), KA1 )
|
|
110 CONTINUE
|
|
*
|
|
IF( WANTX ) THEN
|
|
*
|
|
* post-multiply X by product of rotations in 1st set
|
|
*
|
|
DO 120 J = J2, J1, KA1
|
|
CALL CROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
|
|
$ RWORK( J-M ), CONJG( WORK( J-M ) ) )
|
|
120 CONTINUE
|
|
END IF
|
|
130 CONTINUE
|
|
*
|
|
IF( UPDATE ) THEN
|
|
IF( I2.LE.N .AND. KBT.GT.0 ) THEN
|
|
*
|
|
* create nonzero element a(i-kbt,i-kbt+ka+1) outside the
|
|
* band and store it in WORK(i-kbt)
|
|
*
|
|
WORK( I-KBT ) = -BB( KB1-KBT, I )*RA1
|
|
END IF
|
|
END IF
|
|
*
|
|
DO 170 K = KB, 1, -1
|
|
IF( UPDATE ) THEN
|
|
J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1
|
|
ELSE
|
|
J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
|
|
END IF
|
|
*
|
|
* finish applying rotations in 2nd set from the left
|
|
*
|
|
DO 140 L = KB - K, 1, -1
|
|
NRT = ( N-J2+KA+L ) / KA1
|
|
IF( NRT.GT.0 )
|
|
$ CALL CLARTV( NRT, AB( L, J2-L+1 ), INCA,
|
|
$ AB( L+1, J2-L+1 ), INCA, RWORK( J2-KA ),
|
|
$ WORK( J2-KA ), KA1 )
|
|
140 CONTINUE
|
|
NR = ( N-J2+KA ) / KA1
|
|
J1 = J2 + ( NR-1 )*KA1
|
|
DO 150 J = J1, J2, -KA1
|
|
WORK( J ) = WORK( J-KA )
|
|
RWORK( J ) = RWORK( J-KA )
|
|
150 CONTINUE
|
|
DO 160 J = J2, J1, KA1
|
|
*
|
|
* create nonzero element a(j-ka,j+1) outside the band
|
|
* and store it in WORK(j)
|
|
*
|
|
WORK( J ) = WORK( J )*AB( 1, J+1 )
|
|
AB( 1, J+1 ) = RWORK( J )*AB( 1, J+1 )
|
|
160 CONTINUE
|
|
IF( UPDATE ) THEN
|
|
IF( I-K.LT.N-KA .AND. K.LE.KBT )
|
|
$ WORK( I-K+KA ) = WORK( I-K )
|
|
END IF
|
|
170 CONTINUE
|
|
*
|
|
DO 210 K = KB, 1, -1
|
|
J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
|
|
NR = ( N-J2+KA ) / KA1
|
|
J1 = J2 + ( NR-1 )*KA1
|
|
IF( NR.GT.0 ) THEN
|
|
*
|
|
* generate rotations in 2nd set to annihilate elements
|
|
* which have been created outside the band
|
|
*
|
|
CALL CLARGV( NR, AB( 1, J2 ), INCA, WORK( J2 ), KA1,
|
|
$ RWORK( J2 ), KA1 )
|
|
*
|
|
* apply rotations in 2nd set from the right
|
|
*
|
|
DO 180 L = 1, KA - 1
|
|
CALL CLARTV( NR, AB( KA1-L, J2 ), INCA,
|
|
$ AB( KA-L, J2+1 ), INCA, RWORK( J2 ),
|
|
$ WORK( J2 ), KA1 )
|
|
180 CONTINUE
|
|
*
|
|
* apply rotations in 2nd set from both sides to diagonal
|
|
* blocks
|
|
*
|
|
CALL CLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ),
|
|
$ AB( KA, J2+1 ), INCA, RWORK( J2 ),
|
|
$ WORK( J2 ), KA1 )
|
|
*
|
|
CALL CLACGV( NR, WORK( J2 ), KA1 )
|
|
END IF
|
|
*
|
|
* start applying rotations in 2nd set from the left
|
|
*
|
|
DO 190 L = KA - 1, KB - K + 1, -1
|
|
NRT = ( N-J2+L ) / KA1
|
|
IF( NRT.GT.0 )
|
|
$ CALL CLARTV( NRT, AB( L, J2+KA1-L ), INCA,
|
|
$ AB( L+1, J2+KA1-L ), INCA, RWORK( J2 ),
|
|
$ WORK( J2 ), KA1 )
|
|
190 CONTINUE
|
|
*
|
|
IF( WANTX ) THEN
|
|
*
|
|
* post-multiply X by product of rotations in 2nd set
|
|
*
|
|
DO 200 J = J2, J1, KA1
|
|
CALL CROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
|
|
$ RWORK( J ), CONJG( WORK( J ) ) )
|
|
200 CONTINUE
|
|
END IF
|
|
210 CONTINUE
|
|
*
|
|
DO 230 K = 1, KB - 1
|
|
J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
|
|
*
|
|
* finish applying rotations in 1st set from the left
|
|
*
|
|
DO 220 L = KB - K, 1, -1
|
|
NRT = ( N-J2+L ) / KA1
|
|
IF( NRT.GT.0 )
|
|
$ CALL CLARTV( NRT, AB( L, J2+KA1-L ), INCA,
|
|
$ AB( L+1, J2+KA1-L ), INCA, RWORK( J2-M ),
|
|
$ WORK( J2-M ), KA1 )
|
|
220 CONTINUE
|
|
230 CONTINUE
|
|
*
|
|
IF( KB.GT.1 ) THEN
|
|
DO 240 J = N - 1, J2 + KA, -1
|
|
RWORK( J-M ) = RWORK( J-KA-M )
|
|
WORK( J-M ) = WORK( J-KA-M )
|
|
240 CONTINUE
|
|
END IF
|
|
*
|
|
ELSE
|
|
*
|
|
* Transform A, working with the lower triangle
|
|
*
|
|
IF( UPDATE ) THEN
|
|
*
|
|
* Form inv(S(i))**H * A * inv(S(i))
|
|
*
|
|
BII = REAL( BB( 1, I ) )
|
|
AB( 1, I ) = ( REAL( AB( 1, I ) ) / BII ) / BII
|
|
DO 250 J = I + 1, I1
|
|
AB( J-I+1, I ) = AB( J-I+1, I ) / BII
|
|
250 CONTINUE
|
|
DO 260 J = MAX( 1, I-KA ), I - 1
|
|
AB( I-J+1, J ) = AB( I-J+1, J ) / BII
|
|
260 CONTINUE
|
|
DO 290 K = I - KBT, I - 1
|
|
DO 270 J = I - KBT, K
|
|
AB( K-J+1, J ) = AB( K-J+1, J ) -
|
|
$ BB( I-J+1, J )*CONJG( AB( I-K+1,
|
|
$ K ) ) - CONJG( BB( I-K+1, K ) )*
|
|
$ AB( I-J+1, J ) + REAL( AB( 1, I ) )*
|
|
$ BB( I-J+1, J )*CONJG( BB( I-K+1,
|
|
$ K ) )
|
|
270 CONTINUE
|
|
DO 280 J = MAX( 1, I-KA ), I - KBT - 1
|
|
AB( K-J+1, J ) = AB( K-J+1, J ) -
|
|
$ CONJG( BB( I-K+1, K ) )*
|
|
$ AB( I-J+1, J )
|
|
280 CONTINUE
|
|
290 CONTINUE
|
|
DO 310 J = I, I1
|
|
DO 300 K = MAX( J-KA, I-KBT ), I - 1
|
|
AB( J-K+1, K ) = AB( J-K+1, K ) -
|
|
$ BB( I-K+1, K )*AB( J-I+1, I )
|
|
300 CONTINUE
|
|
310 CONTINUE
|
|
*
|
|
IF( WANTX ) THEN
|
|
*
|
|
* post-multiply X by inv(S(i))
|
|
*
|
|
CALL CSSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
|
|
IF( KBT.GT.0 )
|
|
$ CALL CGERU( N-M, KBT, -CONE, X( M+1, I ), 1,
|
|
$ BB( KBT+1, I-KBT ), LDBB-1,
|
|
$ X( M+1, I-KBT ), LDX )
|
|
END IF
|
|
*
|
|
* store a(i1,i) in RA1 for use in next loop over K
|
|
*
|
|
RA1 = AB( I1-I+1, I )
|
|
END IF
|
|
*
|
|
* Generate and apply vectors of rotations to chase all the
|
|
* existing bulges KA positions down toward the bottom of the
|
|
* band
|
|
*
|
|
DO 360 K = 1, KB - 1
|
|
IF( UPDATE ) THEN
|
|
*
|
|
* Determine the rotations which would annihilate the bulge
|
|
* which has in theory just been created
|
|
*
|
|
IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN
|
|
*
|
|
* generate rotation to annihilate a(i-k+ka+1,i)
|
|
*
|
|
CALL CLARTG( AB( KA1-K, I ), RA1, RWORK( I-K+KA-M ),
|
|
$ WORK( I-K+KA-M ), RA )
|
|
*
|
|
* create nonzero element a(i-k+ka+1,i-k) outside the
|
|
* band and store it in WORK(i-k)
|
|
*
|
|
T = -BB( K+1, I-K )*RA1
|
|
WORK( I-K ) = RWORK( I-K+KA-M )*T -
|
|
$ CONJG( WORK( I-K+KA-M ) )*AB( KA1, I-K )
|
|
AB( KA1, I-K ) = WORK( I-K+KA-M )*T +
|
|
$ RWORK( I-K+KA-M )*AB( KA1, I-K )
|
|
RA1 = RA
|
|
END IF
|
|
END IF
|
|
J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
|
|
NR = ( N-J2+KA ) / KA1
|
|
J1 = J2 + ( NR-1 )*KA1
|
|
IF( UPDATE ) THEN
|
|
J2T = MAX( J2, I+2*KA-K+1 )
|
|
ELSE
|
|
J2T = J2
|
|
END IF
|
|
NRT = ( N-J2T+KA ) / KA1
|
|
DO 320 J = J2T, J1, KA1
|
|
*
|
|
* create nonzero element a(j+1,j-ka) outside the band
|
|
* and store it in WORK(j-m)
|
|
*
|
|
WORK( J-M ) = WORK( J-M )*AB( KA1, J-KA+1 )
|
|
AB( KA1, J-KA+1 ) = RWORK( J-M )*AB( KA1, J-KA+1 )
|
|
320 CONTINUE
|
|
*
|
|
* generate rotations in 1st set to annihilate elements which
|
|
* have been created outside the band
|
|
*
|
|
IF( NRT.GT.0 )
|
|
$ CALL CLARGV( NRT, AB( KA1, J2T-KA ), INCA, WORK( J2T-M ),
|
|
$ KA1, RWORK( J2T-M ), KA1 )
|
|
IF( NR.GT.0 ) THEN
|
|
*
|
|
* apply rotations in 1st set from the left
|
|
*
|
|
DO 330 L = 1, KA - 1
|
|
CALL CLARTV( NR, AB( L+1, J2-L ), INCA,
|
|
$ AB( L+2, J2-L ), INCA, RWORK( J2-M ),
|
|
$ WORK( J2-M ), KA1 )
|
|
330 CONTINUE
|
|
*
|
|
* apply rotations in 1st set from both sides to diagonal
|
|
* blocks
|
|
*
|
|
CALL CLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ),
|
|
$ INCA, RWORK( J2-M ), WORK( J2-M ), KA1 )
|
|
*
|
|
CALL CLACGV( NR, WORK( J2-M ), KA1 )
|
|
END IF
|
|
*
|
|
* start applying rotations in 1st set from the right
|
|
*
|
|
DO 340 L = KA - 1, KB - K + 1, -1
|
|
NRT = ( N-J2+L ) / KA1
|
|
IF( NRT.GT.0 )
|
|
$ CALL CLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
|
|
$ AB( KA1-L, J2+1 ), INCA, RWORK( J2-M ),
|
|
$ WORK( J2-M ), KA1 )
|
|
340 CONTINUE
|
|
*
|
|
IF( WANTX ) THEN
|
|
*
|
|
* post-multiply X by product of rotations in 1st set
|
|
*
|
|
DO 350 J = J2, J1, KA1
|
|
CALL CROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
|
|
$ RWORK( J-M ), WORK( J-M ) )
|
|
350 CONTINUE
|
|
END IF
|
|
360 CONTINUE
|
|
*
|
|
IF( UPDATE ) THEN
|
|
IF( I2.LE.N .AND. KBT.GT.0 ) THEN
|
|
*
|
|
* create nonzero element a(i-kbt+ka+1,i-kbt) outside the
|
|
* band and store it in WORK(i-kbt)
|
|
*
|
|
WORK( I-KBT ) = -BB( KBT+1, I-KBT )*RA1
|
|
END IF
|
|
END IF
|
|
*
|
|
DO 400 K = KB, 1, -1
|
|
IF( UPDATE ) THEN
|
|
J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1
|
|
ELSE
|
|
J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
|
|
END IF
|
|
*
|
|
* finish applying rotations in 2nd set from the right
|
|
*
|
|
DO 370 L = KB - K, 1, -1
|
|
NRT = ( N-J2+KA+L ) / KA1
|
|
IF( NRT.GT.0 )
|
|
$ CALL CLARTV( NRT, AB( KA1-L+1, J2-KA ), INCA,
|
|
$ AB( KA1-L, J2-KA+1 ), INCA,
|
|
$ RWORK( J2-KA ), WORK( J2-KA ), KA1 )
|
|
370 CONTINUE
|
|
NR = ( N-J2+KA ) / KA1
|
|
J1 = J2 + ( NR-1 )*KA1
|
|
DO 380 J = J1, J2, -KA1
|
|
WORK( J ) = WORK( J-KA )
|
|
RWORK( J ) = RWORK( J-KA )
|
|
380 CONTINUE
|
|
DO 390 J = J2, J1, KA1
|
|
*
|
|
* create nonzero element a(j+1,j-ka) outside the band
|
|
* and store it in WORK(j)
|
|
*
|
|
WORK( J ) = WORK( J )*AB( KA1, J-KA+1 )
|
|
AB( KA1, J-KA+1 ) = RWORK( J )*AB( KA1, J-KA+1 )
|
|
390 CONTINUE
|
|
IF( UPDATE ) THEN
|
|
IF( I-K.LT.N-KA .AND. K.LE.KBT )
|
|
$ WORK( I-K+KA ) = WORK( I-K )
|
|
END IF
|
|
400 CONTINUE
|
|
*
|
|
DO 440 K = KB, 1, -1
|
|
J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
|
|
NR = ( N-J2+KA ) / KA1
|
|
J1 = J2 + ( NR-1 )*KA1
|
|
IF( NR.GT.0 ) THEN
|
|
*
|
|
* generate rotations in 2nd set to annihilate elements
|
|
* which have been created outside the band
|
|
*
|
|
CALL CLARGV( NR, AB( KA1, J2-KA ), INCA, WORK( J2 ), KA1,
|
|
$ RWORK( J2 ), KA1 )
|
|
*
|
|
* apply rotations in 2nd set from the left
|
|
*
|
|
DO 410 L = 1, KA - 1
|
|
CALL CLARTV( NR, AB( L+1, J2-L ), INCA,
|
|
$ AB( L+2, J2-L ), INCA, RWORK( J2 ),
|
|
$ WORK( J2 ), KA1 )
|
|
410 CONTINUE
|
|
*
|
|
* apply rotations in 2nd set from both sides to diagonal
|
|
* blocks
|
|
*
|
|
CALL CLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ),
|
|
$ INCA, RWORK( J2 ), WORK( J2 ), KA1 )
|
|
*
|
|
CALL CLACGV( NR, WORK( J2 ), KA1 )
|
|
END IF
|
|
*
|
|
* start applying rotations in 2nd set from the right
|
|
*
|
|
DO 420 L = KA - 1, KB - K + 1, -1
|
|
NRT = ( N-J2+L ) / KA1
|
|
IF( NRT.GT.0 )
|
|
$ CALL CLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
|
|
$ AB( KA1-L, J2+1 ), INCA, RWORK( J2 ),
|
|
$ WORK( J2 ), KA1 )
|
|
420 CONTINUE
|
|
*
|
|
IF( WANTX ) THEN
|
|
*
|
|
* post-multiply X by product of rotations in 2nd set
|
|
*
|
|
DO 430 J = J2, J1, KA1
|
|
CALL CROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
|
|
$ RWORK( J ), WORK( J ) )
|
|
430 CONTINUE
|
|
END IF
|
|
440 CONTINUE
|
|
*
|
|
DO 460 K = 1, KB - 1
|
|
J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
|
|
*
|
|
* finish applying rotations in 1st set from the right
|
|
*
|
|
DO 450 L = KB - K, 1, -1
|
|
NRT = ( N-J2+L ) / KA1
|
|
IF( NRT.GT.0 )
|
|
$ CALL CLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
|
|
$ AB( KA1-L, J2+1 ), INCA, RWORK( J2-M ),
|
|
$ WORK( J2-M ), KA1 )
|
|
450 CONTINUE
|
|
460 CONTINUE
|
|
*
|
|
IF( KB.GT.1 ) THEN
|
|
DO 470 J = N - 1, J2 + KA, -1
|
|
RWORK( J-M ) = RWORK( J-KA-M )
|
|
WORK( J-M ) = WORK( J-KA-M )
|
|
470 CONTINUE
|
|
END IF
|
|
*
|
|
END IF
|
|
*
|
|
GO TO 10
|
|
*
|
|
480 CONTINUE
|
|
*
|
|
* **************************** Phase 2 *****************************
|
|
*
|
|
* The logical structure of this phase is:
|
|
*
|
|
* UPDATE = .TRUE.
|
|
* DO I = 1, M
|
|
* use S(i) to update A and create a new bulge
|
|
* apply rotations to push all bulges KA positions upward
|
|
* END DO
|
|
* UPDATE = .FALSE.
|
|
* DO I = M - KA - 1, 2, -1
|
|
* apply rotations to push all bulges KA positions upward
|
|
* END DO
|
|
*
|
|
* To avoid duplicating code, the two loops are merged.
|
|
*
|
|
UPDATE = .TRUE.
|
|
I = 0
|
|
490 CONTINUE
|
|
IF( UPDATE ) THEN
|
|
I = I + 1
|
|
KBT = MIN( KB, M-I )
|
|
I0 = I + 1
|
|
I1 = MAX( 1, I-KA )
|
|
I2 = I + KBT - KA1
|
|
IF( I.GT.M ) THEN
|
|
UPDATE = .FALSE.
|
|
I = I - 1
|
|
I0 = M + 1
|
|
IF( KA.EQ.0 )
|
|
$ RETURN
|
|
GO TO 490
|
|
END IF
|
|
ELSE
|
|
I = I - KA
|
|
IF( I.LT.2 )
|
|
$ RETURN
|
|
END IF
|
|
*
|
|
IF( I.LT.M-KBT ) THEN
|
|
NX = M
|
|
ELSE
|
|
NX = N
|
|
END IF
|
|
*
|
|
IF( UPPER ) THEN
|
|
*
|
|
* Transform A, working with the upper triangle
|
|
*
|
|
IF( UPDATE ) THEN
|
|
*
|
|
* Form inv(S(i))**H * A * inv(S(i))
|
|
*
|
|
BII = REAL( BB( KB1, I ) )
|
|
AB( KA1, I ) = ( REAL( AB( KA1, I ) ) / BII ) / BII
|
|
DO 500 J = I1, I - 1
|
|
AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII
|
|
500 CONTINUE
|
|
DO 510 J = I + 1, MIN( N, I+KA )
|
|
AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII
|
|
510 CONTINUE
|
|
DO 540 K = I + 1, I + KBT
|
|
DO 520 J = K, I + KBT
|
|
AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
|
|
$ BB( I-J+KB1, J )*
|
|
$ CONJG( AB( I-K+KA1, K ) ) -
|
|
$ CONJG( BB( I-K+KB1, K ) )*
|
|
$ AB( I-J+KA1, J ) +
|
|
$ REAL( AB( KA1, I ) )*
|
|
$ BB( I-J+KB1, J )*
|
|
$ CONJG( BB( I-K+KB1, K ) )
|
|
520 CONTINUE
|
|
DO 530 J = I + KBT + 1, MIN( N, I+KA )
|
|
AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
|
|
$ CONJG( BB( I-K+KB1, K ) )*
|
|
$ AB( I-J+KA1, J )
|
|
530 CONTINUE
|
|
540 CONTINUE
|
|
DO 560 J = I1, I
|
|
DO 550 K = I + 1, MIN( J+KA, I+KBT )
|
|
AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
|
|
$ BB( I-K+KB1, K )*AB( J-I+KA1, I )
|
|
550 CONTINUE
|
|
560 CONTINUE
|
|
*
|
|
IF( WANTX ) THEN
|
|
*
|
|
* post-multiply X by inv(S(i))
|
|
*
|
|
CALL CSSCAL( NX, ONE / BII, X( 1, I ), 1 )
|
|
IF( KBT.GT.0 )
|
|
$ CALL CGERU( NX, KBT, -CONE, X( 1, I ), 1,
|
|
$ BB( KB, I+1 ), LDBB-1, X( 1, I+1 ), LDX )
|
|
END IF
|
|
*
|
|
* store a(i1,i) in RA1 for use in next loop over K
|
|
*
|
|
RA1 = AB( I1-I+KA1, I )
|
|
END IF
|
|
*
|
|
* Generate and apply vectors of rotations to chase all the
|
|
* existing bulges KA positions up toward the top of the band
|
|
*
|
|
DO 610 K = 1, KB - 1
|
|
IF( UPDATE ) THEN
|
|
*
|
|
* Determine the rotations which would annihilate the bulge
|
|
* which has in theory just been created
|
|
*
|
|
IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN
|
|
*
|
|
* generate rotation to annihilate a(i+k-ka-1,i)
|
|
*
|
|
CALL CLARTG( AB( K+1, I ), RA1, RWORK( I+K-KA ),
|
|
$ WORK( I+K-KA ), RA )
|
|
*
|
|
* create nonzero element a(i+k-ka-1,i+k) outside the
|
|
* band and store it in WORK(m-kb+i+k)
|
|
*
|
|
T = -BB( KB1-K, I+K )*RA1
|
|
WORK( M-KB+I+K ) = RWORK( I+K-KA )*T -
|
|
$ CONJG( WORK( I+K-KA ) )*
|
|
$ AB( 1, I+K )
|
|
AB( 1, I+K ) = WORK( I+K-KA )*T +
|
|
$ RWORK( I+K-KA )*AB( 1, I+K )
|
|
RA1 = RA
|
|
END IF
|
|
END IF
|
|
J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
|
|
NR = ( J2+KA-1 ) / KA1
|
|
J1 = J2 - ( NR-1 )*KA1
|
|
IF( UPDATE ) THEN
|
|
J2T = MIN( J2, I-2*KA+K-1 )
|
|
ELSE
|
|
J2T = J2
|
|
END IF
|
|
NRT = ( J2T+KA-1 ) / KA1
|
|
DO 570 J = J1, J2T, KA1
|
|
*
|
|
* create nonzero element a(j-1,j+ka) outside the band
|
|
* and store it in WORK(j)
|
|
*
|
|
WORK( J ) = WORK( J )*AB( 1, J+KA-1 )
|
|
AB( 1, J+KA-1 ) = RWORK( J )*AB( 1, J+KA-1 )
|
|
570 CONTINUE
|
|
*
|
|
* generate rotations in 1st set to annihilate elements which
|
|
* have been created outside the band
|
|
*
|
|
IF( NRT.GT.0 )
|
|
$ CALL CLARGV( NRT, AB( 1, J1+KA ), INCA, WORK( J1 ), KA1,
|
|
$ RWORK( J1 ), KA1 )
|
|
IF( NR.GT.0 ) THEN
|
|
*
|
|
* apply rotations in 1st set from the left
|
|
*
|
|
DO 580 L = 1, KA - 1
|
|
CALL CLARTV( NR, AB( KA1-L, J1+L ), INCA,
|
|
$ AB( KA-L, J1+L ), INCA, RWORK( J1 ),
|
|
$ WORK( J1 ), KA1 )
|
|
580 CONTINUE
|
|
*
|
|
* apply rotations in 1st set from both sides to diagonal
|
|
* blocks
|
|
*
|
|
CALL CLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ),
|
|
$ AB( KA, J1 ), INCA, RWORK( J1 ), WORK( J1 ),
|
|
$ KA1 )
|
|
*
|
|
CALL CLACGV( NR, WORK( J1 ), KA1 )
|
|
END IF
|
|
*
|
|
* start applying rotations in 1st set from the right
|
|
*
|
|
DO 590 L = KA - 1, KB - K + 1, -1
|
|
NRT = ( J2+L-1 ) / KA1
|
|
J1T = J2 - ( NRT-1 )*KA1
|
|
IF( NRT.GT.0 )
|
|
$ CALL CLARTV( NRT, AB( L, J1T ), INCA,
|
|
$ AB( L+1, J1T-1 ), INCA, RWORK( J1T ),
|
|
$ WORK( J1T ), KA1 )
|
|
590 CONTINUE
|
|
*
|
|
IF( WANTX ) THEN
|
|
*
|
|
* post-multiply X by product of rotations in 1st set
|
|
*
|
|
DO 600 J = J1, J2, KA1
|
|
CALL CROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
|
|
$ RWORK( J ), WORK( J ) )
|
|
600 CONTINUE
|
|
END IF
|
|
610 CONTINUE
|
|
*
|
|
IF( UPDATE ) THEN
|
|
IF( I2.GT.0 .AND. KBT.GT.0 ) THEN
|
|
*
|
|
* create nonzero element a(i+kbt-ka-1,i+kbt) outside the
|
|
* band and store it in WORK(m-kb+i+kbt)
|
|
*
|
|
WORK( M-KB+I+KBT ) = -BB( KB1-KBT, I+KBT )*RA1
|
|
END IF
|
|
END IF
|
|
*
|
|
DO 650 K = KB, 1, -1
|
|
IF( UPDATE ) THEN
|
|
J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1
|
|
ELSE
|
|
J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
|
|
END IF
|
|
*
|
|
* finish applying rotations in 2nd set from the right
|
|
*
|
|
DO 620 L = KB - K, 1, -1
|
|
NRT = ( J2+KA+L-1 ) / KA1
|
|
J1T = J2 - ( NRT-1 )*KA1
|
|
IF( NRT.GT.0 )
|
|
$ CALL CLARTV( NRT, AB( L, J1T+KA ), INCA,
|
|
$ AB( L+1, J1T+KA-1 ), INCA,
|
|
$ RWORK( M-KB+J1T+KA ),
|
|
$ WORK( M-KB+J1T+KA ), KA1 )
|
|
620 CONTINUE
|
|
NR = ( J2+KA-1 ) / KA1
|
|
J1 = J2 - ( NR-1 )*KA1
|
|
DO 630 J = J1, J2, KA1
|
|
WORK( M-KB+J ) = WORK( M-KB+J+KA )
|
|
RWORK( M-KB+J ) = RWORK( M-KB+J+KA )
|
|
630 CONTINUE
|
|
DO 640 J = J1, J2, KA1
|
|
*
|
|
* create nonzero element a(j-1,j+ka) outside the band
|
|
* and store it in WORK(m-kb+j)
|
|
*
|
|
WORK( M-KB+J ) = WORK( M-KB+J )*AB( 1, J+KA-1 )
|
|
AB( 1, J+KA-1 ) = RWORK( M-KB+J )*AB( 1, J+KA-1 )
|
|
640 CONTINUE
|
|
IF( UPDATE ) THEN
|
|
IF( I+K.GT.KA1 .AND. K.LE.KBT )
|
|
$ WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K )
|
|
END IF
|
|
650 CONTINUE
|
|
*
|
|
DO 690 K = KB, 1, -1
|
|
J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
|
|
NR = ( J2+KA-1 ) / KA1
|
|
J1 = J2 - ( NR-1 )*KA1
|
|
IF( NR.GT.0 ) THEN
|
|
*
|
|
* generate rotations in 2nd set to annihilate elements
|
|
* which have been created outside the band
|
|
*
|
|
CALL CLARGV( NR, AB( 1, J1+KA ), INCA, WORK( M-KB+J1 ),
|
|
$ KA1, RWORK( M-KB+J1 ), KA1 )
|
|
*
|
|
* apply rotations in 2nd set from the left
|
|
*
|
|
DO 660 L = 1, KA - 1
|
|
CALL CLARTV( NR, AB( KA1-L, J1+L ), INCA,
|
|
$ AB( KA-L, J1+L ), INCA, RWORK( M-KB+J1 ),
|
|
$ WORK( M-KB+J1 ), KA1 )
|
|
660 CONTINUE
|
|
*
|
|
* apply rotations in 2nd set from both sides to diagonal
|
|
* blocks
|
|
*
|
|
CALL CLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ),
|
|
$ AB( KA, J1 ), INCA, RWORK( M-KB+J1 ),
|
|
$ WORK( M-KB+J1 ), KA1 )
|
|
*
|
|
CALL CLACGV( NR, WORK( M-KB+J1 ), KA1 )
|
|
END IF
|
|
*
|
|
* start applying rotations in 2nd set from the right
|
|
*
|
|
DO 670 L = KA - 1, KB - K + 1, -1
|
|
NRT = ( J2+L-1 ) / KA1
|
|
J1T = J2 - ( NRT-1 )*KA1
|
|
IF( NRT.GT.0 )
|
|
$ CALL CLARTV( NRT, AB( L, J1T ), INCA,
|
|
$ AB( L+1, J1T-1 ), INCA,
|
|
$ RWORK( M-KB+J1T ), WORK( M-KB+J1T ),
|
|
$ KA1 )
|
|
670 CONTINUE
|
|
*
|
|
IF( WANTX ) THEN
|
|
*
|
|
* post-multiply X by product of rotations in 2nd set
|
|
*
|
|
DO 680 J = J1, J2, KA1
|
|
CALL CROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
|
|
$ RWORK( M-KB+J ), WORK( M-KB+J ) )
|
|
680 CONTINUE
|
|
END IF
|
|
690 CONTINUE
|
|
*
|
|
DO 710 K = 1, KB - 1
|
|
J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
|
|
*
|
|
* finish applying rotations in 1st set from the right
|
|
*
|
|
DO 700 L = KB - K, 1, -1
|
|
NRT = ( J2+L-1 ) / KA1
|
|
J1T = J2 - ( NRT-1 )*KA1
|
|
IF( NRT.GT.0 )
|
|
$ CALL CLARTV( NRT, AB( L, J1T ), INCA,
|
|
$ AB( L+1, J1T-1 ), INCA, RWORK( J1T ),
|
|
$ WORK( J1T ), KA1 )
|
|
700 CONTINUE
|
|
710 CONTINUE
|
|
*
|
|
IF( KB.GT.1 ) THEN
|
|
DO 720 J = 2, I2 - KA
|
|
RWORK( J ) = RWORK( J+KA )
|
|
WORK( J ) = WORK( J+KA )
|
|
720 CONTINUE
|
|
END IF
|
|
*
|
|
ELSE
|
|
*
|
|
* Transform A, working with the lower triangle
|
|
*
|
|
IF( UPDATE ) THEN
|
|
*
|
|
* Form inv(S(i))**H * A * inv(S(i))
|
|
*
|
|
BII = REAL( BB( 1, I ) )
|
|
AB( 1, I ) = ( REAL( AB( 1, I ) ) / BII ) / BII
|
|
DO 730 J = I1, I - 1
|
|
AB( I-J+1, J ) = AB( I-J+1, J ) / BII
|
|
730 CONTINUE
|
|
DO 740 J = I + 1, MIN( N, I+KA )
|
|
AB( J-I+1, I ) = AB( J-I+1, I ) / BII
|
|
740 CONTINUE
|
|
DO 770 K = I + 1, I + KBT
|
|
DO 750 J = K, I + KBT
|
|
AB( J-K+1, K ) = AB( J-K+1, K ) -
|
|
$ BB( J-I+1, I )*CONJG( AB( K-I+1,
|
|
$ I ) ) - CONJG( BB( K-I+1, I ) )*
|
|
$ AB( J-I+1, I ) + REAL( AB( 1, I ) )*
|
|
$ BB( J-I+1, I )*CONJG( BB( K-I+1,
|
|
$ I ) )
|
|
750 CONTINUE
|
|
DO 760 J = I + KBT + 1, MIN( N, I+KA )
|
|
AB( J-K+1, K ) = AB( J-K+1, K ) -
|
|
$ CONJG( BB( K-I+1, I ) )*
|
|
$ AB( J-I+1, I )
|
|
760 CONTINUE
|
|
770 CONTINUE
|
|
DO 790 J = I1, I
|
|
DO 780 K = I + 1, MIN( J+KA, I+KBT )
|
|
AB( K-J+1, J ) = AB( K-J+1, J ) -
|
|
$ BB( K-I+1, I )*AB( I-J+1, J )
|
|
780 CONTINUE
|
|
790 CONTINUE
|
|
*
|
|
IF( WANTX ) THEN
|
|
*
|
|
* post-multiply X by inv(S(i))
|
|
*
|
|
CALL CSSCAL( NX, ONE / BII, X( 1, I ), 1 )
|
|
IF( KBT.GT.0 )
|
|
$ CALL CGERC( NX, KBT, -CONE, X( 1, I ), 1, BB( 2, I ),
|
|
$ 1, X( 1, I+1 ), LDX )
|
|
END IF
|
|
*
|
|
* store a(i,i1) in RA1 for use in next loop over K
|
|
*
|
|
RA1 = AB( I-I1+1, I1 )
|
|
END IF
|
|
*
|
|
* Generate and apply vectors of rotations to chase all the
|
|
* existing bulges KA positions up toward the top of the band
|
|
*
|
|
DO 840 K = 1, KB - 1
|
|
IF( UPDATE ) THEN
|
|
*
|
|
* Determine the rotations which would annihilate the bulge
|
|
* which has in theory just been created
|
|
*
|
|
IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN
|
|
*
|
|
* generate rotation to annihilate a(i,i+k-ka-1)
|
|
*
|
|
CALL CLARTG( AB( KA1-K, I+K-KA ), RA1,
|
|
$ RWORK( I+K-KA ), WORK( I+K-KA ), RA )
|
|
*
|
|
* create nonzero element a(i+k,i+k-ka-1) outside the
|
|
* band and store it in WORK(m-kb+i+k)
|
|
*
|
|
T = -BB( K+1, I )*RA1
|
|
WORK( M-KB+I+K ) = RWORK( I+K-KA )*T -
|
|
$ CONJG( WORK( I+K-KA ) )*
|
|
$ AB( KA1, I+K-KA )
|
|
AB( KA1, I+K-KA ) = WORK( I+K-KA )*T +
|
|
$ RWORK( I+K-KA )*AB( KA1, I+K-KA )
|
|
RA1 = RA
|
|
END IF
|
|
END IF
|
|
J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
|
|
NR = ( J2+KA-1 ) / KA1
|
|
J1 = J2 - ( NR-1 )*KA1
|
|
IF( UPDATE ) THEN
|
|
J2T = MIN( J2, I-2*KA+K-1 )
|
|
ELSE
|
|
J2T = J2
|
|
END IF
|
|
NRT = ( J2T+KA-1 ) / KA1
|
|
DO 800 J = J1, J2T, KA1
|
|
*
|
|
* create nonzero element a(j+ka,j-1) outside the band
|
|
* and store it in WORK(j)
|
|
*
|
|
WORK( J ) = WORK( J )*AB( KA1, J-1 )
|
|
AB( KA1, J-1 ) = RWORK( J )*AB( KA1, J-1 )
|
|
800 CONTINUE
|
|
*
|
|
* generate rotations in 1st set to annihilate elements which
|
|
* have been created outside the band
|
|
*
|
|
IF( NRT.GT.0 )
|
|
$ CALL CLARGV( NRT, AB( KA1, J1 ), INCA, WORK( J1 ), KA1,
|
|
$ RWORK( J1 ), KA1 )
|
|
IF( NR.GT.0 ) THEN
|
|
*
|
|
* apply rotations in 1st set from the right
|
|
*
|
|
DO 810 L = 1, KA - 1
|
|
CALL CLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ),
|
|
$ INCA, RWORK( J1 ), WORK( J1 ), KA1 )
|
|
810 CONTINUE
|
|
*
|
|
* apply rotations in 1st set from both sides to diagonal
|
|
* blocks
|
|
*
|
|
CALL CLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ),
|
|
$ AB( 2, J1-1 ), INCA, RWORK( J1 ),
|
|
$ WORK( J1 ), KA1 )
|
|
*
|
|
CALL CLACGV( NR, WORK( J1 ), KA1 )
|
|
END IF
|
|
*
|
|
* start applying rotations in 1st set from the left
|
|
*
|
|
DO 820 L = KA - 1, KB - K + 1, -1
|
|
NRT = ( J2+L-1 ) / KA1
|
|
J1T = J2 - ( NRT-1 )*KA1
|
|
IF( NRT.GT.0 )
|
|
$ CALL CLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
|
|
$ AB( KA1-L, J1T-KA1+L ), INCA,
|
|
$ RWORK( J1T ), WORK( J1T ), KA1 )
|
|
820 CONTINUE
|
|
*
|
|
IF( WANTX ) THEN
|
|
*
|
|
* post-multiply X by product of rotations in 1st set
|
|
*
|
|
DO 830 J = J1, J2, KA1
|
|
CALL CROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
|
|
$ RWORK( J ), CONJG( WORK( J ) ) )
|
|
830 CONTINUE
|
|
END IF
|
|
840 CONTINUE
|
|
*
|
|
IF( UPDATE ) THEN
|
|
IF( I2.GT.0 .AND. KBT.GT.0 ) THEN
|
|
*
|
|
* create nonzero element a(i+kbt,i+kbt-ka-1) outside the
|
|
* band and store it in WORK(m-kb+i+kbt)
|
|
*
|
|
WORK( M-KB+I+KBT ) = -BB( KBT+1, I )*RA1
|
|
END IF
|
|
END IF
|
|
*
|
|
DO 880 K = KB, 1, -1
|
|
IF( UPDATE ) THEN
|
|
J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1
|
|
ELSE
|
|
J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
|
|
END IF
|
|
*
|
|
* finish applying rotations in 2nd set from the left
|
|
*
|
|
DO 850 L = KB - K, 1, -1
|
|
NRT = ( J2+KA+L-1 ) / KA1
|
|
J1T = J2 - ( NRT-1 )*KA1
|
|
IF( NRT.GT.0 )
|
|
$ CALL CLARTV( NRT, AB( KA1-L+1, J1T+L-1 ), INCA,
|
|
$ AB( KA1-L, J1T+L-1 ), INCA,
|
|
$ RWORK( M-KB+J1T+KA ),
|
|
$ WORK( M-KB+J1T+KA ), KA1 )
|
|
850 CONTINUE
|
|
NR = ( J2+KA-1 ) / KA1
|
|
J1 = J2 - ( NR-1 )*KA1
|
|
DO 860 J = J1, J2, KA1
|
|
WORK( M-KB+J ) = WORK( M-KB+J+KA )
|
|
RWORK( M-KB+J ) = RWORK( M-KB+J+KA )
|
|
860 CONTINUE
|
|
DO 870 J = J1, J2, KA1
|
|
*
|
|
* create nonzero element a(j+ka,j-1) outside the band
|
|
* and store it in WORK(m-kb+j)
|
|
*
|
|
WORK( M-KB+J ) = WORK( M-KB+J )*AB( KA1, J-1 )
|
|
AB( KA1, J-1 ) = RWORK( M-KB+J )*AB( KA1, J-1 )
|
|
870 CONTINUE
|
|
IF( UPDATE ) THEN
|
|
IF( I+K.GT.KA1 .AND. K.LE.KBT )
|
|
$ WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K )
|
|
END IF
|
|
880 CONTINUE
|
|
*
|
|
DO 920 K = KB, 1, -1
|
|
J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
|
|
NR = ( J2+KA-1 ) / KA1
|
|
J1 = J2 - ( NR-1 )*KA1
|
|
IF( NR.GT.0 ) THEN
|
|
*
|
|
* generate rotations in 2nd set to annihilate elements
|
|
* which have been created outside the band
|
|
*
|
|
CALL CLARGV( NR, AB( KA1, J1 ), INCA, WORK( M-KB+J1 ),
|
|
$ KA1, RWORK( M-KB+J1 ), KA1 )
|
|
*
|
|
* apply rotations in 2nd set from the right
|
|
*
|
|
DO 890 L = 1, KA - 1
|
|
CALL CLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ),
|
|
$ INCA, RWORK( M-KB+J1 ), WORK( M-KB+J1 ),
|
|
$ KA1 )
|
|
890 CONTINUE
|
|
*
|
|
* apply rotations in 2nd set from both sides to diagonal
|
|
* blocks
|
|
*
|
|
CALL CLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ),
|
|
$ AB( 2, J1-1 ), INCA, RWORK( M-KB+J1 ),
|
|
$ WORK( M-KB+J1 ), KA1 )
|
|
*
|
|
CALL CLACGV( NR, WORK( M-KB+J1 ), KA1 )
|
|
END IF
|
|
*
|
|
* start applying rotations in 2nd set from the left
|
|
*
|
|
DO 900 L = KA - 1, KB - K + 1, -1
|
|
NRT = ( J2+L-1 ) / KA1
|
|
J1T = J2 - ( NRT-1 )*KA1
|
|
IF( NRT.GT.0 )
|
|
$ CALL CLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
|
|
$ AB( KA1-L, J1T-KA1+L ), INCA,
|
|
$ RWORK( M-KB+J1T ), WORK( M-KB+J1T ),
|
|
$ KA1 )
|
|
900 CONTINUE
|
|
*
|
|
IF( WANTX ) THEN
|
|
*
|
|
* post-multiply X by product of rotations in 2nd set
|
|
*
|
|
DO 910 J = J1, J2, KA1
|
|
CALL CROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
|
|
$ RWORK( M-KB+J ), CONJG( WORK( M-KB+J ) ) )
|
|
910 CONTINUE
|
|
END IF
|
|
920 CONTINUE
|
|
*
|
|
DO 940 K = 1, KB - 1
|
|
J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
|
|
*
|
|
* finish applying rotations in 1st set from the left
|
|
*
|
|
DO 930 L = KB - K, 1, -1
|
|
NRT = ( J2+L-1 ) / KA1
|
|
J1T = J2 - ( NRT-1 )*KA1
|
|
IF( NRT.GT.0 )
|
|
$ CALL CLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
|
|
$ AB( KA1-L, J1T-KA1+L ), INCA,
|
|
$ RWORK( J1T ), WORK( J1T ), KA1 )
|
|
930 CONTINUE
|
|
940 CONTINUE
|
|
*
|
|
IF( KB.GT.1 ) THEN
|
|
DO 950 J = 2, I2 - KA
|
|
RWORK( J ) = RWORK( J+KA )
|
|
WORK( J ) = WORK( J+KA )
|
|
950 CONTINUE
|
|
END IF
|
|
*
|
|
END IF
|
|
*
|
|
GO TO 490
|
|
*
|
|
* End of CHBGST
|
|
*
|
|
END
|