c \BeginDoc
c
c \Name: cnband
c
c \Description:
c  This subroutine returns the converged approximations to eigenvalues 
c  of A*z = lambda*B*z and (optionally): 
c 
c      (1) The corresponding approximate eigenvectors; 
c 
c      (2) An orthonormal basis for the associated approximate 
c          invariant subspace; 
c 
c      (3) Both.  
c
c  Matrices A and B are stored in LAPACK-style banded form.
c
c  There is negligible additional cost to obtain eigenvectors.  An orthonormal 
c  basis is always computed.  There is an additional storage cost of n*nev
c  if both are requested (in this case a separate array Z must be supplied). 
c
c  The approximate eigenvalues and eigenvectors of  A*z = lambda*B*z
c  are commonly called Ritz values and Ritz vectors respectively.  They are 
c  referred to as such in the comments that follow.  The computed orthonormal 
c  basis for the invariant subspace corresponding to these Ritz values is 
c  referred to as a Schur basis. 
c
c  cnband can be called with one of the following modes:
c
c  Mode 1:  A*z = lambda*z.
c           ===> OP = A  and  B = I.
c
c  Mode 2:  A*z = lambda*M*z, M symmetric positive definite
c           ===> OP = inv[M]*A  and  B = M.
c
c  Mode 3:  A*z = lambda*M*z, M symmetric semi-definite
c           ===> OP = inv[A - sigma*M]*M   and  B = M.
c           ===> shift-and-invert mode.
c
c  Choice of different modes can be specified in IPARAM(7) defined below.
c
c \Usage
c   call cnband
c      ( RVEC, HOWMNY, SELECT, D , Z, LDZ, SIGMA, WORKEV, N, AB, 
c        MB, LDA, FAC, KL, KU, WHICH, BMAT, NEV, TOL, RESID, NCV, 
c        V, LDV, IPARAM, WORKD, WORKL, LWORKL, RWORK, IWORK, INFO )
c
c \Arguments
c  RVEC    LOGICAL  (INPUT) 
c          Specifies whether a basis for the invariant subspace corresponding
c          to the converged Ritz value approximations for the eigenproblem 
c          A*z = lambda*B*z is computed.
c
c             RVEC = .FALSE.     Compute Ritz values only.
c
c             RVEC = .TRUE.      Compute Ritz vectors or Schur vectors.
c                                See Remarks below.
c
c  HOWMNY  Character*1  (INPUT) 
c          Specifies the form of the invariant subspace to be computed 
c          corresponding to the converged Ritz values.
c          = 'A': Compute NEV Ritz vectors;
c          = 'P': Compute NEV Schur vectors;
c          = 'S': compute some of the Ritz vectors, specified
c                 by the logical array SELECT.
c
c  SELECT  Logical array of dimension NCV.  (INPUT)
c          If HOWMNY = 'S', SELECT specifies the Ritz vectors to be
c          computed. To select the real Ritz vector corresponding to a
c          Ritz value D(j), SELECT(j) must be set to .TRUE.. 
c          If HOWMNY = 'A' or 'P', SELECT need not be initialized
c          but it is used as internal workspace.
c
c  D       Complex  array of dimension NEV+1.  (OUTPUT)
c          On exit, D contains the  Ritz  approximations
c          to the eigenvalues lambda for A*z = lambda*B*z.
c
c  Z       Complex  N by NEV array     (OUTPUT)
c          On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of 
c          Z represents approximate eigenvectors (Ritz vectors) corresponding 
c          to the NCONV=IPARAM(5) Ritz values for eigensystem
c          A*z = lambda*B*z.
c
c          If RVEC = .FALSE. or HOWMNY = 'P', then Z is NOT REFERENCED.
c
c          NOTE: If if RVEC = .TRUE. and a Schur basis is not required, 
c          the array Z may be set equal to first NEV columns of the 
c          array V.  
c
c  LDZ     Integer.  (INPUT)
c          The leading dimension of the array Z.  If Ritz vectors are
c          desired, then  LDZ .ge.  max( 1, N ) is required.
c          In any case,  LDZ .ge. 1 is required.
c
c  SIGMA   Complex   (INPUT)
c          If IPARAM(7) = 3 then SIGMA represents the shift.
c          Not referenced if IPARAM(7) = 1 or 2.
c
c  WORKEV  Complex  work array of dimension NCV.  (WORKSPACE)
c 
c  N       Integer.  (INPUT)
c          Dimension of the eigenproblem.
c
c  AB      Complex  array of dimension LDA by N. (INPUT)
c          The matrix A in band storage, in rows KL+1 to
c          2*KL+KU+1; rows 1 to KL of the array need not be set.
c          The j-th column of A is stored in the j-th column of the
c          array AB as follows:
c          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
c
c  MB      Complex  array of dimension LDA by N. (INPUT)
c          The matrix M in band storage, in rows KL+1 to
c          2*KL+KU+1; rows 1 to KL of the array need not be set. 
c          The j-th column of M is stored in the j-th column of the
c          array MB as follows:
c          MB(kl+ku+1+i-j,j) = M(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
c          Not referenced if IPARAM(7)=1.
c
c  LDA     Integer. (INPUT)
c          Leading dimension of AB, MB, FAC.
c
c  FAC     Complex  array of LDA by N. (WORKSPACE/OUTPUT)
c          FAC is used to store the LU factors of MB when mode 2
c          is invoked.  It is used to store the LU factors of
c          (A-sigma*M) when mode 3 is invoked.
c          It is not referenced when IPARAM(7)=1.
c
c  KL      Integer. (INPUT)
c          Max(number of subdiagonals of A, number of subdiagonals of M)
c
c  KU      Integer. (OUTPUT)
c          Max(number of superdiagonals of A, number of superdiagonals of M)
c
c  WHICH   Character*2.  (INPUT)
c          When mode 1,2 are used, WHICH can be set to any one of
c          the following.
c  
c            'LM' -> want the NEV eigenvalues of largest magnitude.
c            'SM' -> want the NEV eigenvalues of smallest magnitude.
c            'LR' -> want the NEV eigenvalues of largest real part.
c            'SR' -> want the NEV eigenvalues of smallest real part.
c            'LI' -> want the NEV eigenvalues of largest imaginary part.
c            'SI' -> want the NEV eigenvalues of smallest imaginary part.
c
c          When mode 3 is used, WHICH should be set to 'LM' only. 
c          
c  BMAT    Character*1.  (INPUT)
c          BMAT specifies the type of the matrix B that defines the
c          semi-inner product for the operator OP.
c          BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x
c          BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*M*x

c  NEV     Integer. (INPUT)
c          Number of eigenvalues of to be computed.
c   
c  TOL     Real  scalar.  (INPUT)
c          Stopping criteria: the relative accuracy of the Ritz value
c          is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I))
c          where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex.
c          DEFAULT = slamch('EPS')  (machine precision as computed
c                    by the LAPACK auxilliary subroutine slamch).
c
c  RESID   Complex  array of length N.  (INPUT/OUTPUT)
c          On INPUT:
c          If INFO .EQ. 0, a random initial residual vector is used.
c          If INFO .NE. 0, RESID contains the initial residual vector,
c                          possibly from a previous run.
c          On OUTPUT:
c          RESID contains the final residual vector.
c
c  NCV     Integer.  (INPUT)
c          Number of columns of the matrix V. NCV must satisfy the two
c          inequalities 2 <= NCV-NEV and NCV <= N.
c          This will indicate how many Arnoldi vectors are generated 
c          at each iteration.  After the startup phase in which NEV 
c          Arnoldi vectors are generated, the algorithm generates 
c          approximately NCV-NEV Arnoldi vectors at each subsequent update 
c          iteration. Most of the cost in generating each Arnoldi vector is 
c          in the matrix-vector operation OP*x. 
c
c  V       Complex  array N by NCV.  (OUTPUT)
c          Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns
c                       contain approximate Schur vectors that span the
c                       desired invariant subspace.
c
c          NOTE: If the array Z has been set equal to first NEV+1 columns
c          of the array V and RVEC=.TRUE. and HOWMNY= 'A', then 
c          the first NCONV=IPARAM(5) columns of V will contain Ritz vectors 
c          of the eigensystem A*z = lambda*B*z.
c
c  LDV     Integer.  (INPUT)
c          Leading dimension of V exactly as declared in the calling
c          program.  LDV must be great than or equal to N.
c
c  IPARAM  Integer array of length 11.  (INPUT/OUTPUT)
c          IPARAM(1) = ISHIFT: 
c          The shifts selected at each iteration are used to restart
c          the Arnoldi iteration in an implicit fashion.
c          It is set to 1 in this subroutine.  The user do not need
c          to set this parameter.
c           ----------------------------------------------------------
c          ISHIFT = 1: exact shift with respect to the current
c                      Hessenberg matrix H.  This is equivalent to
c                      restarting the iteration from the beginning
c                      after updating the starting vector with a linear
c                      combination of Ritz vectors associated with the
c                      "wanted" eigenvalues.
c          -------------------------------------------------------------
c
c          IPARAM(2) = Not referenced.
c
c          IPARAM(3) = MXITER
c          On INPUT:  max number of Arnoldi update iterations allowed.
c          On OUTPUT: actual number of Arnoldi update iterations taken.
c
c          IPARAM(4) = NB: blocksize to be used in the recurrence.
c          The code currently works only for NB = 1.
c
c          IPARAM(5) = NCONV: number of "converged" eigenvalues.
c
c          IPARAM(6) = IUPD
c          Not referenced. Implicit restarting is ALWAYS used.
c
c          IPARAM(7) = MODE
c          On INPUT determines what type of eigenproblem is being solved.
c          Must be 1,2 or 3; See under \Description of cnband for the 
c          three modes available.
c
c WORKD    Complex  work array of length at least 3*n. (WORKSPACE)
c
c WORKL    Complex  work array of length LWORKL. (WORKSPACE) 
c
c LWORKL   Integer.  (INPUT)
c          LWORKL must be at least 3*NCV**2 + 5*NCV.
c
c RWORK    Real  array of length N (WORKSPACE)
c          Workspace used in cnaupd.
c
c IWORK    Integer array of dimension at least N. (WORKSPACE)
c          Used to mode 2,3. Store the pivot information in the 
c          factorization of M or (A-SIGMA*M).
c            
c INFO     Integer.  (INPUT/OUTPUT)
c          Error flag on output.
c          =  0: Normal exit.
c          = -1: N must be positive.
c          = -2: NEV must be positive.
c          = -3: NCV-NEV >= 2 and less than or equal to N.
c          = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI'
c          = -6: BMAT must be one of 'I' or 'G'.
c          = -7: Length of private work WORKL array is not sufficient.
c          = -8: Error return from LAPACK eigenvalue calculation.
c                This should never happened.
c          = -10: IPARAM(7) must be 1,2,3.
c          = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible.
c          = -12: HOWMNY = 'S' not yet implemented
c          = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true.
c          = -14: CNAUPD did not find any eigenvalues to sufficient
c                 accuracy.
c
c \EndDoc
c
c------------------------------------------------------------------------
c
c\BeginLib
c
c\Routines called
c     cnaupd  ARPACK reverse communication interface routine.
c     cneupd  ARPACK routine that returns Ritz values and (optionally)
c             Ritz vectors.
c     cgbtrf  LAPACK band matrix factorization routine.
c     cgbtrs  LAPACK band linear system solve routine.
c     clacpy  LAPACK matrix copy routine.
c     ccopy   Level 1 BLAS that copies one vector to another.
c     scnrm2  Level 1 BLAS that computes the norm of a vector.
c     cgbmv   Level 2 BLAS that computes the band matrix vector product.
c
c\References:
c  1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c     a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c     pp 357-385.
c  2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c     Restarted Arnoldi Iteration", Ph.D thesis, TR95-13, Rice Univ,
c     May 1995.
c
c\Author
c     Richard Lehoucq
c     Danny Sorensen
c     Chao Yang
c     Dept. of Computational &
c     Applied Mathematics
c     Rice University
c     Houston, Texas
c
c\SCCS Information: @(#)
c FILE: nband.F   SID: 2.3   DATE OF SID: 10/17/00   RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
c
      subroutine cnband(rvec, howmny, select, d , z, ldz, sigma,
     &                 workev, n, ab, mb, lda, fac, kl, ku, which, 
     &                 bmat, nev, tol, resid, ncv, v, ldv, iparam, 
     &                 workd, workl, lworkl, rwork, iwork, info )
c
c     %------------------%
c     | Scalar Arguments |
c     %------------------%
c 
      Character        which*2, bmat, howmny
      Logical          rvec
      Integer          n, lda, kl, ku, nev, ncv, ldv,
     &                 ldz, lworkl, info  
      Complex          
     &                 sigma 
      Real 
     &                 tol
c
c     %-----------------%
c     | Array Arguments |
c     %-----------------%
c
      Integer          iparam(*), iwork(*)
      Logical          select(*)
      Complex          
     &                 d(*), resid(*), v(ldv,*), z(ldz,*),
     &                 ab(lda,*), mb(lda,*), fac(lda,*), 
     &                 workd(*), workl(*), workev(*)
      Real 
     &                 rwork(*)
c
c     %--------------%
c     | Local Arrays |
c     %--------------%
c
      integer          ipntr(14)
c
c     %---------------%
c     | Local Scalars |
c     %---------------%
c
      integer          ido, i, j, mode, ierr, itop, imid, ibot
c
c     %------------%
c     | Parameters |
c     %------------%
c
      Complex          
     &                  one, zero
      parameter        (one  = (1.0E+0, 0.0E+0) ,
     &                  zero = (0.0E+0, 0.0E+0) )
c
c     %-----------------------------%
c     | LAPACK & BLAS routines used |
c     %-----------------------------%
c
      Real 
     &                 scnrm2
      external         ccopy, cgbmv, cgbtrf, cgbtrs, scnrm2, clacpy
c
c     %-----------------------%
c     | Executable Statements |
c     %-----------------------%
c     
      mode = iparam(7)
c
c     %------------------------%
c     | Initialize the reverse |
c     | communication flag.    |
c     %------------------------%
c
      ido   = 0
c
c     %----------------%
c     | Exact shift is |
c     | used.          |
c     %----------------%
c
      iparam(1) = 1
c
c     %-----------------------------------%
c     | Both matrices A and M are stored  |
c     | between rows itop and ibot.  Imid |
c     | is the index of the row that      |
c     | stores the diagonal elements.     |
c     %-----------------------------------%
c
      itop = kl + 1
      imid = kl + ku + 1
      ibot = 2*kl + ku + 1
c
      if ( mode .eq. 2 ) then
c
c         %-----------------------------------------------%
c         | Copy M to fac and Call LAPACK routine cgbtrf  |
c         | to factor M.                                  |
c         %-----------------------------------------------%
c
          call clacpy ('A', ibot, n, mb, lda, fac, lda )
          call cgbtrf(n, n, kl, ku, fac, lda, iwork, ierr) 
          if (ierr .ne. 0) then
              print*, ' ' 
              print*,'_band:  error in _gbtrf'
              print*, ' '
              go to 9000
          end if
c
      else if ( mode .eq. 3 ) then
c
          if (bmat .eq. 'I') then
c
c            %-------------------------%
c            | Construct (A - sigma*I) |
c            %-------------------------%
c
             call clacpy ('A', ibot, n, ab, lda, fac, lda )
             do 10 j = 1,n
                fac(imid,j) = ab(imid,j) - sigma
  10         continue
c
          else
c
c            %---------------------------%
c            | Construct (A - sigma*M)   |
c            %---------------------------%
c
             do 30 j = 1,n
                do 20 i = itop, ibot 
                   fac(i,j) = ab(i,j) - sigma*mb(i,j)
  20            continue
  30         continue
c
          end if
c
c         %------------------------%
c         | Factor (A - sigma*M)   |
c         %------------------------%
c
          call cgbtrf(n, n, kl, ku, fac, lda, iwork, ierr)
          if ( ierr .ne. 0 )  then
              print*, ' '
              print*, '_band: error in _gbtrf.'
              print*, ' '
              go to 9000
          end if
c
      end if
c
c     %--------------------------------------------%
c     |  M A I N   L O O P (reverse communication) |
c     %--------------------------------------------%
c
  40  continue 
c
      call cnaupd ( ido, bmat, n, which, nev, tol, resid, ncv,
     &              v, ldv, iparam, ipntr, workd, workl, lworkl,
     &              rwork,info )

c
      if (ido .eq. -1) then
c
         if ( mode .eq. 1) then
c
c           %----------------------------%
c           | Perform  y <--- OP*x = A*x |
c           %----------------------------%
c
            call cgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), 
     &                 lda, workd(ipntr(1)), 1, zero, 
     &                 workd(ipntr(2)), 1)
c
         else if ( mode .eq. 2 ) then
c
c           %-----------------------------------%
c           | Perform  y <--- OP*x = inv[M]*A*x |
c           %-----------------------------------%
c
            call cgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), 
     &                  lda, workd(ipntr(1)), 1, zero, 
     &                  workd(ipntr(2)), 1)
c
            call cgbtrs ('Notranspose', n, kl, ku, 1, fac, lda, 
     &                    iwork, workd(ipntr(2)), n, ierr)
            if (ierr .ne. 0) then
               print*, ' '
               print*, '_band: error in sbgtrs.'
               print*, ' '
               go to 9000
            end if
c
         else if ( mode .eq. 3 ) then
c
c           %-----------------------------------------%
c           | Perform y <-- OP*x                      |
c           |           = inv[A-SIGMA*M]*M* x 
c           | to force the starting vector into the   |
c           | range of OP.                            |
c           %-----------------------------------------%
c
            call cgbmv('Notranspose', n, n, kl, ku, one, mb(itop,1), 
     &                 lda, workd(ipntr(1)), 1, zero, 
     &                 workd(ipntr(2)), 1)
c
            call cgbtrs ('Notranspose', n, kl, ku, 1, fac, lda, 
     &                   iwork, workd(ipntr(2)), n, ierr)
            if (ierr .ne. 0) then
               print*, ' ' 
               print*, '_band: error in _gbtrs.'
               print*, ' ' 
               go to 9000
            end if
c
         end if
c
      else if (ido .eq. 1) then
c
         if ( mode .eq. 1) then
c
c           %----------------------------%
c           | Perform  y <--- OP*x = A*x |
c           %----------------------------%
c
            call cgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), 
     &                 lda, workd(ipntr(1)), 1, zero, 
     &                 workd(ipntr(2)), 1)
c
         else if ( mode .eq. 2 ) then
c
c           %-----------------------------------%
c           | Perform  y <--- OP*x = inv[M]*A*x |
c           %-----------------------------------%
c
            call cgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), 
     &                  lda, workd(ipntr(1)), 1, zero, 
     &                  workd(ipntr(2)), 1)
c
            call cgbtrs ('Notranspose', n, kl, ku, 1, fac, lda, 
     &                    iwork, workd(ipntr(2)), ldv, ierr)
            if (ierr .ne. 0) then
               print*, ' '
               print*, '_band: error in sbgtrs.'
               print*, ' ' 
               go to 9000
            end if
c
         else if ( mode .eq. 3 ) then
c
            if ( bmat .eq. 'I' ) then
c
c              %----------------------------------%
c              | Perform  y <-- inv(A-sigma*I)*x. |
c              %----------------------------------%
c
               call ccopy(n, workd(ipntr(1)), 1, workd(ipntr(2)), 1)
               call cgbtrs ('Notranspose', n, kl, ku, 1, fac, lda,
     &                    iwork, workd(ipntr(2)), n, ierr)
               if (ierr .ne. 0) then
                  print*, ' '
                  print*, '_band: error in _gbtrs.'
                  print*, ' '
                  go to 9000
               end if
c
            else
c  
c              %--------------------------------------%
c              | Perform  y <-- inv(A-sigma*M)*(M*x). |
c              | (M*x) has been computed and stored   |
c              | in workd(ipntr(3)).                  |           
c              %--------------------------------------%
c
               call ccopy(n, workd(ipntr(3)), 1, workd(ipntr(2)), 1)
               call cgbtrs ('Notranspose', n, kl, ku, 1, fac, lda, 
     &                      iwork, workd(ipntr(2)), n, ierr)
               if (ierr .ne. 0) then 
                  print*, ' '
                  print*, '_band: error in _gbtrs.' 
                  print*, ' '
                  go to 9000
               end if
c
            end if
c
         endif
c
      else if (ido .eq. 2) then
c
c        %--------------------%
c        | Perform y <-- M*x  |
c        %--------------------%
c
          call cgbmv('Notranspose', n, n, kl, ku, one, mb(itop,1), 
     &                lda, workd(ipntr(1)), 1, zero, 
     &                workd(ipntr(2)), 1)
c
      else 
c
c        %-------------------------------------------%
c        |   Either we have convergence, or there is | 
c        |   error.                                  |
c        %-------------------------------------------%
c
         if ( info .ne. 0) then
c
c           %--------------------------%
c           | Error message, check the |
c           | documentation in dnaupd  |
c           %--------------------------%
c
            print *, ' '
            print *, ' Error with _naupd info = ',info
            print *, ' Check the documentation of _naupd '
            print *, ' '
c
         else 
c
            call cneupd (rvec, howmny , select, d, z, ldz, sigma,
     &                   workev, bmat, n, which, nev, tol,
     &                   resid, ncv, v, ldv, iparam, ipntr, workd,
     &                   workl, lworkl, rwork, info)
c
            if ( info .ne. 0) then
c 
c              %------------------------------------%
c              | Check the documentation of cneupd. |
c              %------------------------------------%
c
               print *, ' ' 
               print *, ' Error with _neupd = ', info
               print *, ' Check the documentation of _neupd '
               print *, ' ' 
c 
            endif 
c
         end if
c
         go to 9000
c
      end if
c
c     %----------------------------------------%
c     | L O O P  B A C K to call cnaupd again. |
c     %----------------------------------------%
c
      go to 40 
c
 9000 continue
c
      end
