sggbal.f

Go to the documentation of this file.

*> \brief \b SGGBAL
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SGGBAL + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sggbal.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sggbal.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sggbal.f">
*> [TXT]</a>
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE,
*                          RSCALE, WORK, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          JOB
*       INTEGER            IHI, ILO, INFO, LDA, LDB, N
*       ..
*       .. Array Arguments ..
*       REAL               A( LDA, * ), B( LDB, * ), LSCALE( * ),
*      $                   RSCALE( * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SGGBAL balances a pair of general real matrices (A,B).  This
*> involves, first, permuting A and B by similarity transformations to
*> isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N
*> elements on the diagonal; and second, applying a diagonal similarity
*> transformation to rows and columns ILO to IHI to make the rows
*> and columns as close in norm as possible. Both steps are optional.
*>
*> Balancing may reduce the 1-norm of the matrices, and improve the
*> accuracy of the computed eigenvalues and/or eigenvectors in the
*> generalized eigenvalue problem A*x = lambda*B*x.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] JOB
*> \verbatim
*>          JOB is CHARACTER*1
*>          Specifies the operations to be performed on A and B:
*>          = 'N':  none:  simply set ILO = 1, IHI = N, LSCALE(I) = 1.0
*>                  and RSCALE(I) = 1.0 for i = 1,...,N.
*>          = 'P':  permute only;
*>          = 'S':  scale only;
*>          = 'B':  both permute and scale.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrices A and B.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          On entry, the input matrix A.
*>          On exit,  A is overwritten by the balanced matrix.
*>          If JOB = 'N', A is not referenced.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is REAL array, dimension (LDB,N)
*>          On entry, the input matrix B.
*>          On exit,  B is overwritten by the balanced matrix.
*>          If JOB = 'N', B is not referenced.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] ILO
*> \verbatim
*>          ILO is INTEGER
*> \endverbatim
*>
*> \param[out] IHI
*> \verbatim
*>          IHI is INTEGER
*>          ILO and IHI are set to integers such that on exit
*>          A(i,j) = 0 and B(i,j) = 0 if i > j and
*>          j = 1,...,ILO-1 or i = IHI+1,...,N.
*>          If JOB = 'N' or 'S', ILO = 1 and IHI = N.
*> \endverbatim
*>
*> \param[out] LSCALE
*> \verbatim
*>          LSCALE is REAL array, dimension (N)
*>          Details of the permutations and scaling factors applied
*>          to the left side of A and B.  If P(j) is the index of the
*>          row interchanged with row j, and D(j)
*>          is the scaling factor applied to row j, then
*>            LSCALE(j) = P(j)    for J = 1,...,ILO-1
*>                      = D(j)    for J = ILO,...,IHI
*>                      = P(j)    for J = IHI+1,...,N.
*>          The order in which the interchanges are made is N to IHI+1,
*>          then 1 to ILO-1.
*> \endverbatim
*>
*> \param[out] RSCALE
*> \verbatim
*>          RSCALE is REAL array, dimension (N)
*>          Details of the permutations and scaling factors applied
*>          to the right side of A and B.  If P(j) is the index of the
*>          column interchanged with column j, and D(j)
*>          is the scaling factor applied to column j, then
*>            LSCALE(j) = P(j)    for J = 1,...,ILO-1
*>                      = D(j)    for J = ILO,...,IHI
*>                      = P(j)    for J = IHI+1,...,N.
*>          The order in which the interchanges are made is N to IHI+1,
*>          then 1 to ILO-1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (lwork)
*>          lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and
*>          at least 1 when JOB = 'N' or 'P'.
*> \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 ggbal
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  See R.C. WARD, Balancing the generalized eigenvalue problem,
*>                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE sggbal( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE,
     $                   RSCALE, WORK, 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          JOB
      INTEGER            IHI, ILO, INFO, LDA, LDB, N
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), B( LDB, * ), LSCALE( * ),
     $                   rscale( * ), work( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, HALF, ONE
      parameter( zero = 0.0e+0, half = 0.5e+0, one = 1.0e+0 )
      REAL               THREE, SCLFAC
      parameter( three = 3.0e+0, sclfac = 1.0e+1 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1,
     $                   k, kount, l, lcab, lm1, lrab, lsfmax, lsfmin,
     $                   m, nr, nrp2
      REAL               ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2,
     $                   coef5, cor, ew, ewc, gamma, pgamma, rab, sfmax,
     $                   sfmin, sum, t, ta, tb, tc
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ISAMAX
      REAL               SDOT, SLAMCH
      EXTERNAL           lsame, isamax, sdot, slamch
*     ..
*     .. External Subroutines ..
      EXTERNAL           saxpy, sscal, sswap, xerbla
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, int, log10, max, min, real, sign
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      info = 0
      IF( .NOT.lsame( job, 'N' ) .AND. .NOT.lsame( job, 'P' ) .AND.
     $    .NOT.lsame( job, 'S' ) .AND. .NOT.lsame( job, 'B' ) ) THEN
         info = -1
      ELSE IF( n.LT.0 ) THEN
         info = -2
      ELSE IF( lda.LT.max( 1, n ) ) THEN
         info = -4
      ELSE IF( ldb.LT.max( 1, n ) ) THEN
         info = -6
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'SGGBAL', -info )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( n.EQ.0 ) THEN
         ilo = 1
         ihi = n
         RETURN
      END IF
*
      IF( n.EQ.1 ) THEN
         ilo = 1
         ihi = n
         lscale( 1 ) = one
         rscale( 1 ) = one
         RETURN
      END IF
*
      IF( lsame( job, 'N' ) ) THEN
         ilo = 1
         ihi = n
         DO 10 i = 1, n
            lscale( i ) = one
            rscale( i ) = one
   10    CONTINUE
         RETURN
      END IF
*
      k = 1
      l = n
      IF( lsame( job, 'S' ) )
     $   GO TO 190
*
      GO TO 30
*
*     Permute the matrices A and B to isolate the eigenvalues.
*
*     Find row with one nonzero in columns 1 through L
*
   20 CONTINUE
      l = lm1
      IF( l.NE.1 )
     $   GO TO 30
*
      rscale( 1 ) = one
      lscale( 1 ) = one
      GO TO 190
*
   30 CONTINUE
      lm1 = l - 1
      DO 80 i = l, 1, -1
         DO 40 j = 1, lm1
            jp1 = j + 1
            IF( a( i, j ).NE.zero .OR. b( i, j ).NE.zero )
     $         GO TO 50
   40    CONTINUE
         j = l
         GO TO 70
*
   50    CONTINUE
         DO 60 j = jp1, l
            IF( a( i, j ).NE.zero .OR. b( i, j ).NE.zero )
     $         GO TO 80
   60    CONTINUE
         j = jp1 - 1
*
   70    CONTINUE
         m = l
         iflow = 1
         GO TO 160
   80 CONTINUE
      GO TO 100
*
*     Find column with one nonzero in rows K through N
*
   90 CONTINUE
      k = k + 1
*
  100 CONTINUE
      DO 150 j = k, l
         DO 110 i = k, lm1
            ip1 = i + 1
            IF( a( i, j ).NE.zero .OR. b( i, j ).NE.zero )
     $         GO TO 120
  110    CONTINUE
         i = l
         GO TO 140
  120    CONTINUE
         DO 130 i = ip1, l
            IF( a( i, j ).NE.zero .OR. b( i, j ).NE.zero )
     $         GO TO 150
  130    CONTINUE
         i = ip1 - 1
  140    CONTINUE
         m = k
         iflow = 2
         GO TO 160
  150 CONTINUE
      GO TO 190
*
*     Permute rows M and I
*
  160 CONTINUE
      lscale( m ) = i
      IF( i.EQ.m )
     $   GO TO 170
      CALL sswap( n-k+1, a( i, k ), lda, a( m, k ), lda )
      CALL sswap( n-k+1, b( i, k ), ldb, b( m, k ), ldb )
*
*     Permute columns M and J
*
  170 CONTINUE
      rscale( m ) = j
      IF( j.EQ.m )
     $   GO TO 180
      CALL sswap( l, a( 1, j ), 1, a( 1, m ), 1 )
      CALL sswap( l, b( 1, j ), 1, b( 1, m ), 1 )
*
  180 CONTINUE
      GO TO ( 20, 90 )iflow
*
  190 CONTINUE
      ilo = k
      ihi = l
*
      IF( lsame( job, 'P' ) ) THEN
         DO 195 i = ilo, ihi
            lscale( i ) = one
            rscale( i ) = one
  195    CONTINUE
         RETURN
      END IF
*
      IF( ilo.EQ.ihi )
     $   RETURN
*
*     Balance the submatrix in rows ILO to IHI.
*
      nr = ihi - ilo + 1
      DO 200 i = ilo, ihi
         rscale( i ) = zero
         lscale( i ) = zero
*
         work( i ) = zero
         work( i+n ) = zero
         work( i+2*n ) = zero
         work( i+3*n ) = zero
         work( i+4*n ) = zero
         work( i+5*n ) = zero
  200 CONTINUE
*
*     Compute right side vector in resulting linear equations
*
      basl = log10( sclfac )
      DO 240 i = ilo, ihi
         DO 230 j = ilo, ihi
            tb = b( i, j )
            ta = a( i, j )
            IF( ta.EQ.zero )
     $         GO TO 210
            ta = log10( abs( ta ) ) / basl
  210       CONTINUE
            IF( tb.EQ.zero )
     $         GO TO 220
            tb = log10( abs( tb ) ) / basl
  220       CONTINUE
            work( i+4*n ) = work( i+4*n ) - ta - tb
            work( j+5*n ) = work( j+5*n ) - ta - tb
  230    CONTINUE
  240 CONTINUE
*
      coef = one / real( 2*nr )
      coef2 = coef*coef
      coef5 = half*coef2
      nrp2 = nr + 2
      beta = zero
      it = 1
*
*     Start generalized conjugate gradient iteration
*
  250 CONTINUE
*
      gamma = sdot( nr, work( ilo+4*n ), 1, work( ilo+4*n ), 1 ) +
     $        sdot( nr, work( ilo+5*n ), 1, work( ilo+5*n ), 1 )
*
      ew = zero
      ewc = zero
      DO 260 i = ilo, ihi
         ew = ew + work( i+4*n )
         ewc = ewc + work( i+5*n )
  260 CONTINUE
*
      gamma = coef*gamma - coef2*( ew**2+ewc**2 ) - coef5*( ew-ewc )**2
      IF( gamma.EQ.zero )
     $   GO TO 350
      IF( it.NE.1 )
     $   beta = gamma / pgamma
      t = coef5*( ewc-three*ew )
      tc = coef5*( ew-three*ewc )
*
      CALL sscal( nr, beta, work( ilo ), 1 )
      CALL sscal( nr, beta, work( ilo+n ), 1 )
*
      CALL saxpy( nr, coef, work( ilo+4*n ), 1, work( ilo+n ), 1 )
      CALL saxpy( nr, coef, work( ilo+5*n ), 1, work( ilo ), 1 )
*
      DO 270 i = ilo, ihi
         work( i ) = work( i ) + tc
         work( i+n ) = work( i+n ) + t
  270 CONTINUE
*
*     Apply matrix to vector
*
      DO 300 i = ilo, ihi
         kount = 0
         sum = zero
         DO 290 j = ilo, ihi
            IF( a( i, j ).EQ.zero )
     $         GO TO 280
            kount = kount + 1
            sum = sum + work( j )
  280       CONTINUE
            IF( b( i, j ).EQ.zero )
     $         GO TO 290
            kount = kount + 1
            sum = sum + work( j )
  290    CONTINUE
         work( i+2*n ) = real( kount )*work( i+n ) + sum
  300 CONTINUE
*
      DO 330 j = ilo, ihi
         kount = 0
         sum = zero
         DO 320 i = ilo, ihi
            IF( a( i, j ).EQ.zero )
     $         GO TO 310
            kount = kount + 1
            sum = sum + work( i+n )
  310       CONTINUE
            IF( b( i, j ).EQ.zero )
     $         GO TO 320
            kount = kount + 1
            sum = sum + work( i+n )
  320    CONTINUE
         work( j+3*n ) = real( kount )*work( j ) + sum
  330 CONTINUE
*
      sum = sdot( nr, work( ilo+n ), 1, work( ilo+2*n ), 1 ) +
     $      sdot( nr, work( ilo ), 1, work( ilo+3*n ), 1 )
      alpha = gamma / sum
*
*     Determine correction to current iteration
*
      cmax = zero
      DO 340 i = ilo, ihi
         cor = alpha*work( i+n )
         IF( abs( cor ).GT.cmax )
     $      cmax = abs( cor )
         lscale( i ) = lscale( i ) + cor
         cor = alpha*work( i )
         IF( abs( cor ).GT.cmax )
     $      cmax = abs( cor )
         rscale( i ) = rscale( i ) + cor
  340 CONTINUE
      IF( cmax.LT.half )
     $   GO TO 350
*
      CALL saxpy( nr, -alpha, work( ilo+2*n ), 1, work( ilo+4*n ), 1 )
      CALL saxpy( nr, -alpha, work( ilo+3*n ), 1, work( ilo+5*n ), 1 )
*
      pgamma = gamma
      it = it + 1
      IF( it.LE.nrp2 )
     $   GO TO 250
*
*     End generalized conjugate gradient iteration
*
  350 CONTINUE
      sfmin = slamch( 'S' )
      sfmax = one / sfmin
      lsfmin = int( log10( sfmin ) / basl+one )
      lsfmax = int( log10( sfmax ) / basl )
      DO 360 i = ilo, ihi
         irab = isamax( n-ilo+1, a( i, ilo ), lda )
         rab = abs( a( i, irab+ilo-1 ) )
         irab = isamax( n-ilo+1, b( i, ilo ), ldb )
         rab = max( rab, abs( b( i, irab+ilo-1 ) ) )
         lrab = int( log10( rab+sfmin ) / basl+one )
         ir = int( lscale( i ) + sign( half, lscale( i ) ) )
         ir = min( max( ir, lsfmin ), lsfmax, lsfmax-lrab )
         lscale( i ) = sclfac**ir
         icab = isamax( ihi, a( 1, i ), 1 )
         cab = abs( a( icab, i ) )
         icab = isamax( ihi, b( 1, i ), 1 )
         cab = max( cab, abs( b( icab, i ) ) )
         lcab = int( log10( cab+sfmin ) / basl+one )
         jc = int( rscale( i ) + sign( half, rscale( i ) ) )
         jc = min( max( jc, lsfmin ), lsfmax, lsfmax-lcab )
         rscale( i ) = sclfac**jc
  360 CONTINUE
*
*     Row scaling of matrices A and B
*
      DO 370 i = ilo, ihi
         CALL sscal( n-ilo+1, lscale( i ), a( i, ilo ), lda )
         CALL sscal( n-ilo+1, lscale( i ), b( i, ilo ), ldb )
  370 CONTINUE
*
*     Column scaling of matrices A and B
*
      DO 380 j = ilo, ihi
         CALL sscal( ihi, rscale( j ), a( 1, j ), 1 )
         CALL sscal( ihi, rscale( j ), b( 1, j ), 1 )
  380 CONTINUE
*
      RETURN
*
*     End of SGGBAL
*
      END