zhbgst.f

famous linear algebra library (LAPACK) ports to windows

      SUBROUTINE ZHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X,
     $                   LDX, WORK, RWORK, INFO )
*
*  -- LAPACK routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO, VECT
      INTEGER            INFO, KA, KB, LDAB, LDBB, LDX, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   RWORK( * )
      COMPLEX*16         AB( LDAB, * ), BB( LDBB, * ), WORK( * ),
     $                   X( LDX, * )
*     ..
*
*  Purpose
*  =======
*
*  ZHBGST 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 ZPBSTF, 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.
*
*  Arguments
*  =========
*
*  VECT    (input) CHARACTER*1
*          = 'N':  do not form the transformation matrix X;
*          = 'V':  form X.
*
*  UPLO    (input) CHARACTER*1
*          = 'U':  Upper triangle of A is stored;
*          = 'L':  Lower triangle of A is stored.
*
*  N       (input) INTEGER
*          The order of the matrices A and B.  N >= 0.
*
*  KA      (input) INTEGER
*          The number of superdiagonals of the matrix A if UPLO = 'U',
*          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.
*
*  KB      (input) INTEGER
*          The number of superdiagonals of the matrix B if UPLO = 'U',
*          or the number of subdiagonals if UPLO = 'L'.  KA >= KB >= 0.
*
*  AB      (input/output) COMPLEX*16 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.
*
*  LDAB    (input) INTEGER
*          The leading dimension of the array AB.  LDAB >= KA+1.
*
*  BB      (input) COMPLEX*16 array, dimension (LDBB,N)
*          The banded factor S from the split Cholesky factorization of
*          B, as returned by ZPBSTF, stored in the first kb+1 rows of
*          the array.
*
*  LDBB    (input) INTEGER
*          The leading dimension of the array BB.  LDBB >= KB+1.
*
*  X       (output) COMPLEX*16 array, dimension (LDX,N)
*          If VECT = 'V', the n-by-n matrix X.
*          If VECT = 'N', the array X is not referenced.
*
*  LDX     (input) INTEGER
*          The leading dimension of the array X.
*          LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.
*
*  WORK    (workspace) COMPLEX*16 array, dimension (N)
*
*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value.
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX*16         CZERO, CONE
      DOUBLE PRECISION   ONE
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
     $                   CONE = ( 1.0D+0, 0.0D+0 ), ONE = 1.0D+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
      DOUBLE PRECISION   BII
      COMPLEX*16         RA, RA1, T
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ZDSCAL, ZGERC, ZGERU, ZLACGV, ZLAR2V,
     $                   ZLARGV, ZLARTG, ZLARTV, ZLASET, ZROT
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DCONJG, MAX, MIN
*     ..
*     .. 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( 'ZHBGST', -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 ZLASET( 'Full', N, N, CZERO, CONE, X, LDX )
*
*     Set M to the splitting point m. It must be the same value as is
*     used in ZPBSTF. 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 = DBLE( BB( KB1, I ) )
            AB( KA1, I ) = ( DBLE( 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 )*
     $                               DCONJG( AB( K-I+KA1, I ) ) -
     $                               DCONJG( BB( K-I+KB1, I ) )*
     $                               AB( J-I+KA1, I ) +
     $                               DBLE( AB( KA1, I ) )*
     $                               BB( J-I+KB1, I )*
     $                               DCONJG( 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 ) -
     $                               DCONJG( 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 ZDSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
               IF( KBT.GT.0 )
     $            CALL ZGERC( 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 ZLARTG( 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 -
     $                          DCONJG( 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)
*