1: *> \brief \b DLASD8 finds the square roots of the roots of the secular equation, and stores, for each element in D, the distance to its two nearest poles. Used by sbdsdc.
2: *
3: * =========== DOCUMENTATION ===========
4: *
5: * Online html documentation available at
6: * http://www.netlib.org/lapack/explore-html/
7: *
8: *> \htmlonly
9: *> Download DLASD8 + dependencies
10: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasd8.f">
11: *> [TGZ]</a>
12: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasd8.f">
13: *> [ZIP]</a>
14: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasd8.f">
15: *> [TXT]</a>
16: *> \endhtmlonly
17: *
18: * Definition:
19: * ===========
20: *
21: * SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR,
22: * DSIGMA, WORK, INFO )
23: *
24: * .. Scalar Arguments ..
25: * INTEGER ICOMPQ, INFO, K, LDDIFR
26: * ..
27: * .. Array Arguments ..
28: * DOUBLE PRECISION D( * ), DIFL( * ), DIFR( LDDIFR, * ),
29: * $ DSIGMA( * ), VF( * ), VL( * ), WORK( * ),
30: * $ Z( * )
31: * ..
32: *
33: *
34: *> \par Purpose:
35: * =============
36: *>
37: *> \verbatim
38: *>
39: *> DLASD8 finds the square roots of the roots of the secular equation,
40: *> as defined by the values in DSIGMA and Z. It makes the appropriate
41: *> calls to DLASD4, and stores, for each element in D, the distance
42: *> to its two nearest poles (elements in DSIGMA). It also updates
43: *> the arrays VF and VL, the first and last components of all the
44: *> right singular vectors of the original bidiagonal matrix.
45: *>
46: *> DLASD8 is called from DLASD6.
47: *> \endverbatim
48: *
49: * Arguments:
50: * ==========
51: *
52: *> \param[in] ICOMPQ
53: *> \verbatim
54: *> ICOMPQ is INTEGER
55: *> Specifies whether singular vectors are to be computed in
56: *> factored form in the calling routine:
57: *> = 0: Compute singular values only.
58: *> = 1: Compute singular vectors in factored form as well.
59: *> \endverbatim
60: *>
61: *> \param[in] K
62: *> \verbatim
63: *> K is INTEGER
64: *> The number of terms in the rational function to be solved
65: *> by DLASD4. K >= 1.
66: *> \endverbatim
67: *>
68: *> \param[out] D
69: *> \verbatim
70: *> D is DOUBLE PRECISION array, dimension ( K )
71: *> On output, D contains the updated singular values.
72: *> \endverbatim
73: *>
74: *> \param[in,out] Z
75: *> \verbatim
76: *> Z is DOUBLE PRECISION array, dimension ( K )
77: *> On entry, the first K elements of this array contain the
78: *> components of the deflation-adjusted updating row vector.
79: *> On exit, Z is updated.
80: *> \endverbatim
81: *>
82: *> \param[in,out] VF
83: *> \verbatim
84: *> VF is DOUBLE PRECISION array, dimension ( K )
85: *> On entry, VF contains information passed through DBEDE8.
86: *> On exit, VF contains the first K components of the first
87: *> components of all right singular vectors of the bidiagonal
88: *> matrix.
89: *> \endverbatim
90: *>
91: *> \param[in,out] VL
92: *> \verbatim
93: *> VL is DOUBLE PRECISION array, dimension ( K )
94: *> On entry, VL contains information passed through DBEDE8.
95: *> On exit, VL contains the first K components of the last
96: *> components of all right singular vectors of the bidiagonal
97: *> matrix.
98: *> \endverbatim
99: *>
100: *> \param[out] DIFL
101: *> \verbatim
102: *> DIFL is DOUBLE PRECISION array, dimension ( K )
103: *> On exit, DIFL(I) = D(I) - DSIGMA(I).
104: *> \endverbatim
105: *>
106: *> \param[out] DIFR
107: *> \verbatim
108: *> DIFR is DOUBLE PRECISION array,
109: *> dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and
110: *> dimension ( K ) if ICOMPQ = 0.
111: *> On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not
112: *> defined and will not be referenced.
113: *>
114: *> If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
115: *> normalizing factors for the right singular vector matrix.
116: *> \endverbatim
117: *>
118: *> \param[in] LDDIFR
119: *> \verbatim
120: *> LDDIFR is INTEGER
121: *> The leading dimension of DIFR, must be at least K.
122: *> \endverbatim
123: *>
124: *> \param[in,out] DSIGMA
125: *> \verbatim
126: *> DSIGMA is DOUBLE PRECISION array, dimension ( K )
127: *> On entry, the first K elements of this array contain the old
128: *> roots of the deflated updating problem. These are the poles
129: *> of the secular equation.
130: *> On exit, the elements of DSIGMA may be very slightly altered
131: *> in value.
132: *> \endverbatim
133: *>
134: *> \param[out] WORK
135: *> \verbatim
136: *> WORK is DOUBLE PRECISION array, dimension (3*K)
137: *> \endverbatim
138: *>
139: *> \param[out] INFO
140: *> \verbatim
141: *> INFO is INTEGER
142: *> = 0: successful exit.
143: *> < 0: if INFO = -i, the i-th argument had an illegal value.
144: *> > 0: if INFO = 1, a singular value did not converge
145: *> \endverbatim
146: *
147: * Authors:
148: * ========
149: *
150: *> \author Univ. of Tennessee
151: *> \author Univ. of California Berkeley
152: *> \author Univ. of Colorado Denver
153: *> \author NAG Ltd.
154: *
155: *> \ingroup OTHERauxiliary
156: *
157: *> \par Contributors:
158: * ==================
159: *>
160: *> Ming Gu and Huan Ren, Computer Science Division, University of
161: *> California at Berkeley, USA
162: *>
163: * =====================================================================
164: SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR,
165: $ DSIGMA, WORK, INFO )
166: *
167: * -- LAPACK auxiliary routine --
168: * -- LAPACK is a software package provided by Univ. of Tennessee, --
169: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
170: *
171: * .. Scalar Arguments ..
172: INTEGER ICOMPQ, INFO, K, LDDIFR
173: * ..
174: * .. Array Arguments ..
175: DOUBLE PRECISION D( * ), DIFL( * ), DIFR( LDDIFR, * ),
176: $ DSIGMA( * ), VF( * ), VL( * ), WORK( * ),
177: $ Z( * )
178: * ..
179: *
180: * =====================================================================
181: *
182: * .. Parameters ..
183: DOUBLE PRECISION ONE
184: PARAMETER ( ONE = 1.0D+0 )
185: * ..
186: * .. Local Scalars ..
187: INTEGER I, IWK1, IWK2, IWK2I, IWK3, IWK3I, J
188: DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, RHO, TEMP
189: * ..
190: * .. External Subroutines ..
191: EXTERNAL DCOPY, DLASCL, DLASD4, DLASET, XERBLA
192: * ..
193: * .. External Functions ..
194: DOUBLE PRECISION DDOT, DLAMC3, DNRM2
195: EXTERNAL DDOT, DLAMC3, DNRM2
196: * ..
197: * .. Intrinsic Functions ..
198: INTRINSIC ABS, SIGN, SQRT
199: * ..
200: * .. Executable Statements ..
201: *
202: * Test the input parameters.
203: *
204: INFO = 0
205: *
206: IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
207: INFO = -1
208: ELSE IF( K.LT.1 ) THEN
209: INFO = -2
210: ELSE IF( LDDIFR.LT.K ) THEN
211: INFO = -9
212: END IF
213: IF( INFO.NE.0 ) THEN
214: CALL XERBLA( 'DLASD8', -INFO )
215: RETURN
216: END IF
217: *
218: * Quick return if possible
219: *
220: IF( K.EQ.1 ) THEN
221: D( 1 ) = ABS( Z( 1 ) )
222: DIFL( 1 ) = D( 1 )
223: IF( ICOMPQ.EQ.1 ) THEN
224: DIFL( 2 ) = ONE
225: DIFR( 1, 2 ) = ONE
226: END IF
227: RETURN
228: END IF
229: *
230: * Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
231: * be computed with high relative accuracy (barring over/underflow).
232: * This is a problem on machines without a guard digit in
233: * add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
234: * The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
235: * which on any of these machines zeros out the bottommost
236: * bit of DSIGMA(I) if it is 1; this makes the subsequent
237: * subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
238: * occurs. On binary machines with a guard digit (almost all
239: * machines) it does not change DSIGMA(I) at all. On hexadecimal
240: * and decimal machines with a guard digit, it slightly
241: * changes the bottommost bits of DSIGMA(I). It does not account
242: * for hexadecimal or decimal machines without guard digits
243: * (we know of none). We use a subroutine call to compute
244: * 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
245: * this code.
246: *
247: DO 10 I = 1, K
248: DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I )
249: 10 CONTINUE
250: *
251: * Book keeping.
252: *
253: IWK1 = 1
254: IWK2 = IWK1 + K
255: IWK3 = IWK2 + K
256: IWK2I = IWK2 - 1
257: IWK3I = IWK3 - 1
258: *
259: * Normalize Z.
260: *
261: RHO = DNRM2( K, Z, 1 )
262: CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO )
263: RHO = RHO*RHO
264: *
265: * Initialize WORK(IWK3).
266: *
267: CALL DLASET( 'A', K, 1, ONE, ONE, WORK( IWK3 ), K )
268: *
269: * Compute the updated singular values, the arrays DIFL, DIFR,
270: * and the updated Z.
271: *
272: DO 40 J = 1, K
273: CALL DLASD4( K, J, DSIGMA, Z, WORK( IWK1 ), RHO, D( J ),
274: $ WORK( IWK2 ), INFO )
275: *
276: * If the root finder fails, report the convergence failure.
277: *
278: IF( INFO.NE.0 ) THEN
279: RETURN
280: END IF
281: WORK( IWK3I+J ) = WORK( IWK3I+J )*WORK( J )*WORK( IWK2I+J )
282: DIFL( J ) = -WORK( J )
283: DIFR( J, 1 ) = -WORK( J+1 )
284: DO 20 I = 1, J - 1
285: WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )*
286: $ WORK( IWK2I+I ) / ( DSIGMA( I )-
287: $ DSIGMA( J ) ) / ( DSIGMA( I )+
288: $ DSIGMA( J ) )
289: 20 CONTINUE
290: DO 30 I = J + 1, K
291: WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )*
292: $ WORK( IWK2I+I ) / ( DSIGMA( I )-
293: $ DSIGMA( J ) ) / ( DSIGMA( I )+
294: $ DSIGMA( J ) )
295: 30 CONTINUE
296: 40 CONTINUE
297: *
298: * Compute updated Z.
299: *
300: DO 50 I = 1, K
301: Z( I ) = SIGN( SQRT( ABS( WORK( IWK3I+I ) ) ), Z( I ) )
302: 50 CONTINUE
303: *
304: * Update VF and VL.
305: *
306: DO 80 J = 1, K
307: DIFLJ = DIFL( J )
308: DJ = D( J )
309: DSIGJ = -DSIGMA( J )
310: IF( J.LT.K ) THEN
311: DIFRJ = -DIFR( J, 1 )
312: DSIGJP = -DSIGMA( J+1 )
313: END IF
314: WORK( J ) = -Z( J ) / DIFLJ / ( DSIGMA( J )+DJ )
315: DO 60 I = 1, J - 1
316: WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJ )-DIFLJ )
317: $ / ( DSIGMA( I )+DJ )
318: 60 CONTINUE
319: DO 70 I = J + 1, K
320: WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJP )+DIFRJ )
321: $ / ( DSIGMA( I )+DJ )
322: 70 CONTINUE
323: TEMP = DNRM2( K, WORK, 1 )
324: WORK( IWK2I+J ) = DDOT( K, WORK, 1, VF, 1 ) / TEMP
325: WORK( IWK3I+J ) = DDOT( K, WORK, 1, VL, 1 ) / TEMP
326: IF( ICOMPQ.EQ.1 ) THEN
327: DIFR( J, 2 ) = TEMP
328: END IF
329: 80 CONTINUE
330: *
331: CALL DCOPY( K, WORK( IWK2 ), 1, VF, 1 )
332: CALL DCOPY( K, WORK( IWK3 ), 1, VL, 1 )
333: *
334: RETURN
335: *
336: * End of DLASD8
337: *
338: END
339:
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to dlasd8.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack