001:       SUBROUTINE SLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX,
002:      $                   CTOT, W, S, INFO )
003: *
004: *  -- LAPACK routine (version 3.2) --
005: *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
006: *     November 2006
007: *
008: *     .. Scalar Arguments ..
009:       INTEGER            INFO, K, LDQ, N, N1
010:       REAL               RHO
011: *     ..
012: *     .. Array Arguments ..
013:       INTEGER            CTOT( * ), INDX( * )
014:       REAL               D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
015:      $                   S( * ), W( * )
016: *     ..
017: *
018: *  Purpose
019: *  =======
020: *
021: *  SLAED3 finds the roots of the secular equation, as defined by the
022: *  values in D, W, and RHO, between 1 and K.  It makes the
023: *  appropriate calls to SLAED4 and then updates the eigenvectors by
024: *  multiplying the matrix of eigenvectors of the pair of eigensystems
025: *  being combined by the matrix of eigenvectors of the K-by-K system
026: *  which is solved here.
027: *
028: *  This code makes very mild assumptions about floating point
029: *  arithmetic. It will work on machines with a guard digit in
030: *  add/subtract, or on those binary machines without guard digits
031: *  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
032: *  It could conceivably fail on hexadecimal or decimal machines
033: *  without guard digits, but we know of none.
034: *
035: *  Arguments
036: *  =========
037: *
038: *  K       (input) INTEGER
039: *          The number of terms in the rational function to be solved by
040: *          SLAED4.  K >= 0.
041: *
042: *  N       (input) INTEGER
043: *          The number of rows and columns in the Q matrix.
044: *          N >= K (deflation may result in N>K).
045: *
046: *  N1      (input) INTEGER
047: *          The location of the last eigenvalue in the leading submatrix.
048: *          min(1,N) <= N1 <= N/2.
049: *
050: *  D       (output) REAL array, dimension (N)
051: *          D(I) contains the updated eigenvalues for
052: *          1 <= I <= K.
053: *
054: *  Q       (output) REAL array, dimension (LDQ,N)
055: *          Initially the first K columns are used as workspace.
056: *          On output the columns 1 to K contain
057: *          the updated eigenvectors.
058: *
059: *  LDQ     (input) INTEGER
060: *          The leading dimension of the array Q.  LDQ >= max(1,N).
061: *
062: *  RHO     (input) REAL
063: *          The value of the parameter in the rank one update equation.
064: *          RHO >= 0 required.
065: *
066: *  DLAMDA  (input/output) REAL array, dimension (K)
067: *          The first K elements of this array contain the old roots
068: *          of the deflated updating problem.  These are the poles
069: *          of the secular equation. May be changed on output by
070: *          having lowest order bit set to zero on Cray X-MP, Cray Y-MP,
071: *          Cray-2, or Cray C-90, as described above.
072: *
073: *  Q2      (input) REAL array, dimension (LDQ2, N)
074: *          The first K columns of this matrix contain the non-deflated
075: *          eigenvectors for the split problem.
076: *
077: *  INDX    (input) INTEGER array, dimension (N)
078: *          The permutation used to arrange the columns of the deflated
079: *          Q matrix into three groups (see SLAED2).
080: *          The rows of the eigenvectors found by SLAED4 must be likewise
081: *          permuted before the matrix multiply can take place.
082: *
083: *  CTOT    (input) INTEGER array, dimension (4)
084: *          A count of the total number of the various types of columns
085: *          in Q, as described in INDX.  The fourth column type is any
086: *          column which has been deflated.
087: *
088: *  W       (input/output) REAL array, dimension (K)
089: *          The first K elements of this array contain the components
090: *          of the deflation-adjusted updating vector. Destroyed on
091: *          output.
092: *
093: *  S       (workspace) REAL array, dimension (N1 + 1)*K
094: *          Will contain the eigenvectors of the repaired matrix which
095: *          will be multiplied by the previously accumulated eigenvectors
096: *          to update the system.
097: *
098: *  LDS     (input) INTEGER
099: *          The leading dimension of S.  LDS >= max(1,K).
100: *
101: *  INFO    (output) INTEGER
102: *          = 0:  successful exit.
103: *          < 0:  if INFO = -i, the i-th argument had an illegal value.
104: *          > 0:  if INFO = 1, an eigenvalue did not converge
105: *
106: *  Further Details
107: *  ===============
108: *
109: *  Based on contributions by
110: *     Jeff Rutter, Computer Science Division, University of California
111: *     at Berkeley, USA
112: *  Modified by Francoise Tisseur, University of Tennessee.
113: *
114: *  =====================================================================
115: *
116: *     .. Parameters ..
117:       REAL               ONE, ZERO
118:       PARAMETER          ( ONE = 1.0E0, ZERO = 0.0E0 )
119: *     ..
120: *     .. Local Scalars ..
121:       INTEGER            I, II, IQ2, J, N12, N2, N23
122:       REAL               TEMP
123: *     ..
124: *     .. External Functions ..
125:       REAL               SLAMC3, SNRM2
126:       EXTERNAL           SLAMC3, SNRM2
127: *     ..
128: *     .. External Subroutines ..
129:       EXTERNAL           SCOPY, SGEMM, SLACPY, SLAED4, SLASET, XERBLA
130: *     ..
131: *     .. Intrinsic Functions ..
132:       INTRINSIC          MAX, SIGN, SQRT
133: *     ..
134: *     .. Executable Statements ..
135: *
136: *     Test the input parameters.
137: *
138:       INFO = 0
139: *
140:       IF( K.LT.0 ) THEN
141:          INFO = -1
142:       ELSE IF( N.LT.K ) THEN
143:          INFO = -2
144:       ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
145:          INFO = -6
146:       END IF
147:       IF( INFO.NE.0 ) THEN
148:          CALL XERBLA( 'SLAED3', -INFO )
149:          RETURN
150:       END IF
151: *
152: *     Quick return if possible
153: *
154:       IF( K.EQ.0 )
155:      $   RETURN
156: *
157: *     Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
158: *     be computed with high relative accuracy (barring over/underflow).
159: *     This is a problem on machines without a guard digit in
160: *     add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
161: *     The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
162: *     which on any of these machines zeros out the bottommost
163: *     bit of DLAMDA(I) if it is 1; this makes the subsequent
164: *     subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
165: *     occurs. On binary machines with a guard digit (almost all
166: *     machines) it does not change DLAMDA(I) at all. On hexadecimal
167: *     and decimal machines with a guard digit, it slightly
168: *     changes the bottommost bits of DLAMDA(I). It does not account
169: *     for hexadecimal or decimal machines without guard digits
170: *     (we know of none). We use a subroutine call to compute
171: *     2*DLAMBDA(I) to prevent optimizing compilers from eliminating
172: *     this code.
173: *
174:       DO 10 I = 1, K
175:          DLAMDA( I ) = SLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
176:    10 CONTINUE
177: *
178:       DO 20 J = 1, K
179:          CALL SLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
180: *
181: *        If the zero finder fails, the computation is terminated.
182: *
183:          IF( INFO.NE.0 )
184:      $      GO TO 120
185:    20 CONTINUE
186: *
187:       IF( K.EQ.1 )
188:      $   GO TO 110
189:       IF( K.EQ.2 ) THEN
190:          DO 30 J = 1, K
191:             W( 1 ) = Q( 1, J )
192:             W( 2 ) = Q( 2, J )
193:             II = INDX( 1 )
194:             Q( 1, J ) = W( II )
195:             II = INDX( 2 )
196:             Q( 2, J ) = W( II )
197:    30    CONTINUE
198:          GO TO 110
199:       END IF
200: *
201: *     Compute updated W.
202: *
203:       CALL SCOPY( K, W, 1, S, 1 )
204: *
205: *     Initialize W(I) = Q(I,I)
206: *
207:       CALL SCOPY( K, Q, LDQ+1, W, 1 )
208:       DO 60 J = 1, K
209:          DO 40 I = 1, J - 1
210:             W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
211:    40    CONTINUE
212:          DO 50 I = J + 1, K
213:             W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
214:    50    CONTINUE
215:    60 CONTINUE
216:       DO 70 I = 1, K
217:          W( I ) = SIGN( SQRT( -W( I ) ), S( I ) )
218:    70 CONTINUE
219: *
220: *     Compute eigenvectors of the modified rank-1 modification.
221: *
222:       DO 100 J = 1, K
223:          DO 80 I = 1, K
224:             S( I ) = W( I ) / Q( I, J )
225:    80    CONTINUE
226:          TEMP = SNRM2( K, S, 1 )
227:          DO 90 I = 1, K
228:             II = INDX( I )
229:             Q( I, J ) = S( II ) / TEMP
230:    90    CONTINUE
231:   100 CONTINUE
232: *
233: *     Compute the updated eigenvectors.
234: *
235:   110 CONTINUE
236: *
237:       N2 = N - N1
238:       N12 = CTOT( 1 ) + CTOT( 2 )
239:       N23 = CTOT( 2 ) + CTOT( 3 )
240: *
241:       CALL SLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 )
242:       IQ2 = N1*N12 + 1
243:       IF( N23.NE.0 ) THEN
244:          CALL SGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23,
245:      $               ZERO, Q( N1+1, 1 ), LDQ )
246:       ELSE
247:          CALL SLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ )
248:       END IF
249: *
250:       CALL SLACPY( 'A', N12, K, Q, LDQ, S, N12 )
251:       IF( N12.NE.0 ) THEN
252:          CALL SGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q,
253:      $               LDQ )
254:       ELSE
255:          CALL SLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ )
256:       END IF
257: *
258: *
259:   120 CONTINUE
260:       RETURN
261: *
262: *     End of SLAED3
263: *
264:       END
265: