slaed3.f

*> \brief \b SLAED3 used by SSTEDC. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is tridiagonal.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAED3 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slaed3.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slaed3.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slaed3.f">
*> [TXT]</a>
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX,
*                          CTOT, W, S, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, K, LDQ, N, N1
*       REAL               RHO
*       ..
*       .. Array Arguments ..
*       INTEGER            CTOT( * ), INDX( * )
*       REAL               D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
*      $                   S( * ), W( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SLAED3 finds the roots of the secular equation, as defined by the
*> values in D, W, and RHO, between 1 and K.  It makes the
*> appropriate calls to SLAED4 and then updates the eigenvectors by
*> multiplying the matrix of eigenvectors of the pair of eigensystems
*> being combined by the matrix of eigenvectors of the K-by-K system
*> which is solved here.
*>
*> This code makes very mild assumptions about floating point
*> arithmetic. It will work on machines with a guard digit in
*> add/subtract, or on those binary machines without guard digits
*> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
*> It could conceivably fail on hexadecimal or decimal machines
*> without guard digits, but we know of none.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] K
*> \verbatim
*>          K is INTEGER
*>          The number of terms in the rational function to be solved by
*>          SLAED4.  K >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of rows and columns in the Q matrix.
*>          N >= K (deflation may result in N>K).
*> \endverbatim
*>
*> \param[in] N1
*> \verbatim
*>          N1 is INTEGER
*>          The location of the last eigenvalue in the leading submatrix.
*>          min(1,N) <= N1 <= N/2.
*> \endverbatim
*>
*> \param[out] D
*> \verbatim
*>          D is REAL array, dimension (N)
*>          D(I) contains the updated eigenvalues for
*>          1 <= I <= K.
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*>          Q is REAL array, dimension (LDQ,N)
*>          Initially the first K columns are used as workspace.
*>          On output the columns 1 to K contain
*>          the updated eigenvectors.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*>          LDQ is INTEGER
*>          The leading dimension of the array Q.  LDQ >= max(1,N).
*> \endverbatim
*>
*> \param[in] RHO
*> \verbatim
*>          RHO is REAL
*>          The value of the parameter in the rank one update equation.
*>          RHO >= 0 required.
*> \endverbatim
*>
*> \param[in,out] DLAMDA
*> \verbatim
*>          DLAMDA is REAL array, dimension (K)
*>          The first K elements of this array contain the old roots
*>          of the deflated updating problem.  These are the poles
*>          of the secular equation. May be changed on output by
*>          having lowest order bit set to zero on Cray X-MP, Cray Y-MP,
*>          Cray-2, or Cray C-90, as described above.
*> \endverbatim
*>
*> \param[in] Q2
*> \verbatim
*>          Q2 is REAL array, dimension (LDQ2*N)
*>          The first K columns of this matrix contain the non-deflated
*>          eigenvectors for the split problem.
*> \endverbatim
*>
*> \param[in] INDX
*> \verbatim
*>          INDX is INTEGER array, dimension (N)
*>          The permutation used to arrange the columns of the deflated
*>          Q matrix into three groups (see SLAED2).
*>          The rows of the eigenvectors found by SLAED4 must be likewise
*>          permuted before the matrix multiply can take place.
*> \endverbatim
*>
*> \param[in] CTOT
*> \verbatim
*>          CTOT is INTEGER array, dimension (4)
*>          A count of the total number of the various types of columns
*>          in Q, as described in INDX.  The fourth column type is any
*>          column which has been deflated.
*> \endverbatim
*>
*> \param[in,out] W
*> \verbatim
*>          W is REAL array, dimension (K)
*>          The first K elements of this array contain the components
*>          of the deflation-adjusted updating vector. Destroyed on
*>          output.
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*>          S is REAL array, dimension (N1 + 1)*K
*>          Will contain the eigenvectors of the repaired matrix which
*>          will be multiplied by the previously accumulated eigenvectors
*>          to update the system.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit.
*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
*>          > 0:  if INFO = 1, an eigenvalue did not converge
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup laed3
*
*> \par Contributors:
*  ==================
*>
*> Jeff Rutter, Computer Science Division, University of California
*> at Berkeley, USA \n
*>  Modified by Francoise Tisseur, University of Tennessee
*>
*  =====================================================================
      SUBROUTINE slaed3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX,
     $                   CTOT, W, S, 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 ..
      INTEGER            INFO, K, LDQ, N, N1
      REAL               RHO
*     ..
*     .. Array Arguments ..
      INTEGER            CTOT( * ), INDX( * )
      REAL               D( * ), DLAMDA( * ), Q( ldq, * ), Q2( * ),
     $                   s( * ), w( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, ZERO
      parameter( one = 1.0e0, zero = 0.0e0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, II, IQ2, J, N12, N2, N23
      REAL               TEMP
*     ..
*     .. External Functions ..
      REAL               SLAMC3, SNRM2
      EXTERNAL           slamc3, snrm2
*     ..
*     .. External Subroutines ..
      EXTERNAL           scopy, sgemm, slacpy, slaed4, slaset, xerbla
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          max, sign, sqrt
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
*
      IF( k.LT.0 ) THEN
         info = -1
      ELSE IF( n.LT.k ) THEN
         info = -2
      ELSE IF( ldq.LT.max( 1, n ) ) THEN
         info = -6
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'SLAED3', -info )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( k.EQ.0 )
     $   RETURN
*
*     Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
*     be computed with high relative accuracy (barring over/underflow).
*     This is a problem on machines without a guard digit in
*     add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
*     The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
*     which on any of these machines zeros out the bottommost
*     bit of DLAMDA(I) if it is 1; this makes the subsequent
*     subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
*     occurs. On binary machines with a guard digit (almost all
*     machines) it does not change DLAMDA(I) at all. On hexadecimal
*     and decimal machines with a guard digit, it slightly
*     changes the bottommost bits of DLAMDA(I). It does not account
*     for hexadecimal or decimal machines without guard digits
*     (we know of none). We use a subroutine call to compute
*     2*DLAMBDA(I) to prevent optimizing compilers from eliminating
*     this code.
*
      DO 10 i = 1, k
         dlamda( i ) = slamc3( dlamda( i ), dlamda( i ) ) - dlamda( i )
   10 CONTINUE
*
      DO 20 j = 1, k
         CALL slaed4( k, j, dlamda, w, q( 1, j ), rho, d( j ), info )
*
*        If the zero finder fails, the computation is terminated.
*
         IF( info.NE.0 )
     $      GO TO 120
   20 CONTINUE
*
      IF( k.EQ.1 )
     $   GO TO 110
      IF( k.EQ.2 ) THEN
         DO 30 j = 1, k
            w( 1 ) = q( 1, j )
            w( 2 ) = q( 2, j )
            ii = indx( 1 )
            q( 1, j ) = w( ii )
            ii = indx( 2 )
            q( 2, j ) = w( ii )
   30    CONTINUE
         GO TO 110
      END IF
*
*     Compute updated W.
*
      CALL scopy( k, w, 1, s, 1 )
*
*     Initialize W(I) = Q(I,I)
*
      CALL scopy( k, q, ldq+1, w, 1 )
      DO 60 j = 1, k
         DO 40 i = 1, j - 1
            w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
   40    CONTINUE
         DO 50 i = j + 1, k
            w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
   50    CONTINUE
   60 CONTINUE
      DO 70 i = 1, k
         w( i ) = sign( sqrt( -w( i ) ), s( i ) )
   70 CONTINUE
*
*     Compute eigenvectors of the modified rank-1 modification.
*
      DO 100 j = 1, k
         DO 80 i = 1, k
            s( i ) = w( i ) / q( i, j )
   80    CONTINUE
         temp = snrm2( k, s, 1 )
         DO 90 i = 1, k
            ii = indx( i )
            q( i, j ) = s( ii ) / temp
   90    CONTINUE
  100 CONTINUE
*
*     Compute the updated eigenvectors.
*
  110 CONTINUE
*
      n2 = n - n1
      n12 = ctot( 1 ) + ctot( 2 )
      n23 = ctot( 2 ) + ctot( 3 )
*
      CALL slacpy( 'A', n23, k, q( ctot( 1 )+1, 1 ), ldq, s, n23 )
      iq2 = n1*n12 + 1
      IF( n23.NE.0 ) THEN
         CALL sgemm( 'N', 'N', n2, k, n23, one, q2( iq2 ), n2, s, n23,
     $               zero, q( n1+1, 1 ), ldq )
      ELSE
         CALL slaset( 'A', n2, k, zero, zero, q( n1+1, 1 ), ldq )
      END IF
*
      CALL slacpy( 'A', n12, k, q, ldq, s, n12 )
      IF( n12.NE.0 ) THEN
         CALL sgemm( 'N', 'N', n1, k, n12, one, q2, n1, s, n12, zero, q,
     $               ldq )
      ELSE
         CALL slaset( 'A', n1, k, zero, zero, q( 1, 1 ), ldq )
      END IF
*
*
  120 CONTINUE
      RETURN
*
*     End of SLAED3
*
      END