dlaed3.f

          SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX,
         $                   CTOT, W, S, INFO )
    *
    *  -- LAPACK routine (version 3.1) --
    *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
    *     November 2006
    *
    *     .. Scalar Arguments ..
          INTEGER            INFO, K, LDQ, N, N1
          DOUBLE PRECISION   RHO
    *     ..
    *     .. Array Arguments ..
          INTEGER            CTOT( * ), INDX( * )
          DOUBLE PRECISION   D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
         $                   S( * ), W( * )
    *     ..
    *
    *  Purpose
    *  =======
    *
    *  DLAED3 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 DLAED4 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.
    *
    *  Arguments
    *  =========
    *
    *  K       (input) INTEGER
    *          The number of terms in the rational function to be solved by
    *          DLAED4.  K >= 0.
    *
    *  N       (input) INTEGER
    *          The number of rows and columns in the Q matrix.
    *          N >= K (deflation may result in N>K).
    *
    *  N1      (input) INTEGER
    *          The location of the last eigenvalue in the leading submatrix.
    *          min(1,N) <= N1 <= N/2.
    *
    *  D       (output) DOUBLE PRECISION array, dimension (N)
    *          D(I) contains the updated eigenvalues for
    *          1 <= I <= K.
    *
    *  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
    *          Initially the first K columns are used as workspace.
    *          On output the columns 1 to K contain
    *          the updated eigenvectors.
    *
    *  LDQ     (input) INTEGER
    *          The leading dimension of the array Q.  LDQ >= max(1,N).
    *
    *  RHO     (input) DOUBLE PRECISION
    *          The value of the parameter in the rank one update equation.
    *          RHO >= 0 required.
    *
    *  DLAMDA  (input/output) DOUBLE PRECISION 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.
    *
    *  Q2      (input) DOUBLE PRECISION array, dimension (LDQ2, N)
    *          The first K columns of this matrix contain the non-deflated
    *          eigenvectors for the split problem.
    *
    *  INDX    (input) INTEGER array, dimension (N)
    *          The permutation used to arrange the columns of the deflated
    *          Q matrix into three groups (see DLAED2).
    *          The rows of the eigenvectors found by DLAED4 must be likewise
    *          permuted before the matrix multiply can take place.
    *
    *  CTOT    (input) 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.
    *
    *  W       (input/output) DOUBLE PRECISION array, dimension (K)
    *          The first K elements of this array contain the components
    *          of the deflation-adjusted updating vector. Destroyed on
    *          output.
    *
    *  S       (workspace) DOUBLE PRECISION 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.
    *
    *  LDS     (input) INTEGER
    *          The leading dimension of S.  LDS >= max(1,K).
    *
    *  INFO    (output) 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
    *
    *  Further Details
    *  ===============
    *
    *  Based on contributions by
    *     Jeff Rutter, Computer Science Division, University of California
    *     at Berkeley, USA
    *  Modified by Francoise Tisseur, University of Tennessee.
    *
    *  =====================================================================
    *
    *     .. Parameters ..
          DOUBLE PRECISION   ONE, ZERO
          PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
    *     ..
    *     .. Local Scalars ..
          INTEGER            I, II, IQ2, J, N12, N2, N23
          DOUBLE PRECISION   TEMP
    *     ..
    *     .. External Functions ..
          DOUBLE PRECISION   DLAMC3, DNRM2
          EXTERNAL           DLAMC3, DNRM2
    *     ..
    *     .. External Subroutines ..
          EXTERNAL           DCOPY, DGEMM, DLACPY, DLAED4, DLASET, 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( 'DLAED3', -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 ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
       10 CONTINUE
    *
          DO 20 J = 1, K
             CALL DLAED4( 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 DCOPY( K, W, 1, S, 1 )
    *
    *     Initialize W(I) = Q(I,I)
    *
          CALL DCOPY( 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 = DNRM2( 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 DLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 )
          IQ2 = N1*N12 + 1
          IF( N23.NE.0 ) THEN
             CALL DGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23,
         $               ZERO, Q( N1+1, 1 ), LDQ )
          ELSE
             CALL DLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ )
          END IF
    *
          CALL DLACPY( 'A', N12, K, Q, LDQ, S, N12 )
          IF( N12.NE.0 ) THEN
             CALL DGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q,
         $               LDQ )
          ELSE
             CALL DLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ )
          END IF
    *
    *
      120 CONTINUE
          RETURN
    *
    *     End of DLAED3
    *
          END