1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
|
SUBROUTINE SLARRF2( N, D, L, LD, CLSTRT, CLEND,
$ CLMID1, CLMID2, W, WGAP, WERR, TRYMID,
$ SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA,
$ DPLUS, LPLUS, WORK, INFO )
*
* -- ScaLAPACK computational routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
* July 4, 2010
*
IMPLICIT NONE
*
* .. Scalar Arguments ..
INTEGER CLSTRT, CLEND, CLMID1, CLMID2, INFO, N
REAL CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM
LOGICAL TRYMID
* ..
* .. Array Arguments ..
REAL D( * ), DPLUS( * ), L( * ), LD( * ),
$ LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* Given the initial representation L D L^T and its cluster of close
* eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...
* W( CLEND ), SLARRF2 finds a new relatively robust representation
* L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the
* eigenvalues of L(+) D(+) L(+)^T is relatively isolated.
*
* This is an enhanced version of SLARRF that also tries shifts in
* the middle of the cluster, should there be a large gap, in order to
* break large clusters into at least two pieces.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix (subblock, if the matrix splitted).
*
* D (input) REAL array, dimension (N)
* The N diagonal elements of the diagonal matrix D.
*
* L (input) REAL array, dimension (N-1)
* The (N-1) subdiagonal elements of the unit bidiagonal
* matrix L.
*
* LD (input) REAL array, dimension (N-1)
* The (N-1) elements L(i)*D(i).
*
* CLSTRT (input) INTEGER
* The index of the first eigenvalue in the cluster.
*
* CLEND (input) INTEGER
* The index of the last eigenvalue in the cluster.
*
* CLMID1,2(input) INTEGER
* The index of a middle eigenvalue pair with large gap
*
* W (input) REAL array, dimension >= (CLEND-CLSTRT+1)
* The eigenvalue APPROXIMATIONS of L D L^T in ascending order.
* W( CLSTRT ) through W( CLEND ) form the cluster of relatively
* close eigenalues.
*
* WGAP (input/output) REAL array, dimension >= (CLEND-CLSTRT+1)
* The separation from the right neighbor eigenvalue in W.
*
* WERR (input) REAL array, dimension >= (CLEND-CLSTRT+1)
* WERR contain the semiwidth of the uncertainty
* interval of the corresponding eigenvalue APPROXIMATION in W
*
* SPDIAM (input) estimate of the spectral diameter obtained from the
* Gerschgorin intervals
*
* CLGAPL, CLGAPR (input) absolute gap on each end of the cluster.
* Set by the calling routine to protect against shifts too close
* to eigenvalues outside the cluster.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot allowed in the sturm sequence.
*
* SIGMA (output) REAL
* The shift used to form L(+) D(+) L(+)^T.
*
* DPLUS (output) REAL array, dimension (N)
* The N diagonal elements of the diagonal matrix D(+).
*
* LPLUS (output) REAL array, dimension (N-1)
* The first (N-1) elements of LPLUS contain the subdiagonal
* elements of the unit bidiagonal matrix L(+).
*
* WORK (workspace) REAL array, dimension (2*N)
* Workspace.
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL FOUR, MAXGROWTH1, MAXGROWTH2, ONE, QUART, TWO
PARAMETER ( ONE = 1.0E0, TWO = 2.0E0,
$ FOUR = 4.0E0, QUART = 0.25E0,
$ MAXGROWTH1 = 8.E0,
$ MAXGROWTH2 = 8.E0 )
* ..
* .. Local Scalars ..
LOGICAL DORRR1, NOFAIL, SAWNAN1, SAWNAN2, TRYRRR1
INTEGER BI,I,J,KTRY,KTRYMAX,SLEFT,SRIGHT,SMID,SHIFT
PARAMETER ( KTRYMAX = 1, SMID =0, SLEFT = 1, SRIGHT = 2 )
* DSTQDS loops will be blocked to detect NaNs earlier if they occur
INTEGER BLKLEN
PARAMETER ( BLKLEN = 512 )
REAL AVGAP, BESTSHIFT, CLWDTH, EPS, FACT, FAIL,
$ FAIL2, GROWTHBOUND, LDELTA, LDMAX, LEASTGROWTH,
$ LSIGMA, MAX1, MAX2, MINGAP, MSIGMA1, MSIGMA2,
$ OLDP, PROD, RDELTA, RDMAX, RRR1, RRR2, RSIGMA,
$ S, TMP, ZNM2
* ..
* .. External Functions ..
LOGICAL SISNAN
REAL SLAMCH
EXTERNAL SISNAN, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SCOPY
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
INFO = 0
FACT = REAL(2**KTRYMAX)
EPS = SLAMCH( 'Precision' )
SHIFT = 0
* Decide whether the code should accept the best among all
* representations despite large element growth or signal INFO=1
NOFAIL = .TRUE.
*
* Compute the average gap length of the cluster
CLWDTH = ABS(W(CLEND)-W(CLSTRT)) + WERR(CLEND) + WERR(CLSTRT)
AVGAP = CLWDTH / REAL(CLEND-CLSTRT)
MINGAP = MIN(CLGAPL, CLGAPR)
* Initial values for shifts to both ends of cluster
LSIGMA = MIN(W( CLSTRT ),W( CLEND )) - WERR( CLSTRT )
RSIGMA = MAX(W( CLSTRT ),W( CLEND )) + WERR( CLEND )
MSIGMA1 = W( CLMID1 ) + WERR( CLMID1 )
MSIGMA2 = W( CLMID2 ) - WERR( CLMID2 )
* Use a small fudge to make sure that we really shift to the outside
LSIGMA = LSIGMA - ABS(LSIGMA)* TWO * EPS
RSIGMA = RSIGMA + ABS(RSIGMA)* TWO * EPS
* Compute upper bounds for how much to back off the initial shifts
LDMAX = QUART * MINGAP + TWO * PIVMIN
RDMAX = QUART * MINGAP + TWO * PIVMIN
LDELTA = MAX(AVGAP,WGAP( CLSTRT ))/FACT
RDELTA = MAX(AVGAP,WGAP( CLEND-1 ))/FACT
*
* Initialize the record of the best representation found
*
S = SLAMCH( 'S' )
LEASTGROWTH = ONE / S
FAIL = REAL(N-1)*MINGAP/(SPDIAM*EPS)
FAIL2 = REAL(N-1)*MINGAP/(SPDIAM*SQRT(EPS))
GROWTHBOUND = MAXGROWTH1*SPDIAM
*
* Set default best shift
*
BESTSHIFT = LSIGMA
IF(.NOT.TRYMID) GOTO 4
*
* Try shifts in the middle
*
SHIFT = SMID
DO 3 J=1,2
SAWNAN1 = .FALSE.
IF(J.EQ.1) THEN
* Try left middle point
SIGMA = MSIGMA1
ELSE
* Try left middle point
SIGMA = MSIGMA2
ENDIF
S = -SIGMA
DPLUS( 1 ) = D( 1 ) + S
MAX1 = ABS( DPLUS( 1 ) )
DO 2 BI = 1, N-1, BLKLEN
DO 1 I = BI, MIN( BI+BLKLEN-1, N-1)
LPLUS( I ) = LD( I ) / DPLUS( I )
S = S*LPLUS( I )*L( I ) - SIGMA
DPLUS( I+1 ) = D( I+1 ) + S
MAX1 = MAX( MAX1,ABS(DPLUS(I+1)) )
1 CONTINUE
SAWNAN1=SAWNAN1 .OR. SISNAN(MAX1)
IF (SAWNAN1) GOTO 3
2 CONTINUE
IF( .NOT.SAWNAN1 ) THEN
IF( MAX1.LE.GROWTHBOUND ) THEN
GOTO 100
ELSE IF( MAX1.LE.LEASTGROWTH ) THEN
LEASTGROWTH = MAX1
BESTSHIFT = SIGMA
ENDIF
ENDIF
3 CONTINUE
4 CONTINUE
*
* Shifts in the middle not tried or not succeeded
* Find best shift on the outside of the cluster
*
* while (KTRY <= KTRYMAX)
KTRY = 0
*
*
*
5 CONTINUE
* Compute element growth when shifting to both ends of the cluster
* accept shift if there is no element growth at one of the two ends
* Left end
SAWNAN1 = .FALSE.
S = -LSIGMA
DPLUS( 1 ) = D( 1 ) + S
MAX1 = ABS( DPLUS( 1 ) )
DO 12 BI = 1, N-1, BLKLEN
DO 11 I = BI, MIN( BI+BLKLEN-1, N-1)
LPLUS( I ) = LD( I ) / DPLUS( I )
S = S*LPLUS( I )*L( I ) - LSIGMA
DPLUS( I+1 ) = D( I+1 ) + S
MAX1 = MAX( MAX1,ABS(DPLUS(I+1)) )
11 CONTINUE
SAWNAN1=SAWNAN1 .OR. SISNAN(MAX1)
IF (SAWNAN1) GOTO 13
12 CONTINUE
IF( .NOT.SAWNAN1 ) THEN
IF( MAX1.LE.GROWTHBOUND ) THEN
SIGMA = LSIGMA
SHIFT = SLEFT
GOTO 100
ELSE IF( MAX1.LE.LEASTGROWTH ) THEN
LEASTGROWTH = MAX1
BESTSHIFT = LSIGMA
ENDIF
ENDIF
13 CONTINUE
* Right end
SAWNAN2 = .FALSE.
S = -RSIGMA
WORK( 1 ) = D( 1 ) + S
MAX2 = ABS( WORK( 1 ) )
DO 22 BI = 1, N-1, BLKLEN
DO 21 I = BI, MIN( BI+BLKLEN-1, N-1)
WORK( N+I ) = LD( I ) / WORK( I )
S = S*WORK( N+I )*L( I ) - RSIGMA
WORK( I+1 ) = D( I+1 ) + S
MAX2 = MAX( MAX2,ABS(WORK(I+1)) )
21 CONTINUE
SAWNAN2=SAWNAN2 .OR. SISNAN(MAX2)
IF (SAWNAN2) GOTO 23
22 CONTINUE
IF( .NOT.SAWNAN2 ) THEN
IF( MAX2.LE.GROWTHBOUND ) THEN
SIGMA = RSIGMA
SHIFT = SRIGHT
GOTO 100
ELSE IF( MAX2.LE.LEASTGROWTH ) THEN
LEASTGROWTH = MAX2
BESTSHIFT = RSIGMA
ENDIF
ENDIF
23 CONTINUE
* If we are at this point, both shifts led to too much element growth
50 CONTINUE
IF (KTRY.LT.KTRYMAX) THEN
* If we are here, both shifts failed also the RRR test.
* Back off to the outside
LSIGMA = MAX( LSIGMA - LDELTA,
$ LSIGMA - LDMAX)
RSIGMA = MIN( RSIGMA + RDELTA,
$ RSIGMA + RDMAX )
LDELTA = TWO * LDELTA
RDELTA = TWO * RDELTA
* Ensure that we do not back off too much of the initial shifts
LDELTA = MIN(LDMAX,LDELTA)
RDELTA = MIN(RDMAX,RDELTA)
KTRY = KTRY + 1
GOTO 5
ELSE
* None of the representations investigated satisfied our
* criteria. Take the best one we found.
IF((LEASTGROWTH.LT.FAIL).OR.NOFAIL) THEN
LSIGMA = BESTSHIFT
SAWNAN1 = .FALSE.
S = -LSIGMA
DPLUS( 1 ) = D( 1 ) + S
DO 6 I = 1, N - 1
LPLUS( I ) = LD( I ) / DPLUS( I )
S = S*LPLUS( I )*L( I ) - LSIGMA
DPLUS( I+1 ) = D( I+1 ) + S
IF(ABS(DPLUS(I+1)).LT.PIVMIN) THEN
DPLUS(I+1) = -PIVMIN
ENDIF
6 CONTINUE
SIGMA = LSIGMA
SHIFT = SLEFT
GOTO 100
ELSE
INFO = 1
RETURN
ENDIF
END IF
100 CONTINUE
IF (SHIFT.EQ.SLEFT .OR. SHIFT.EQ.SMID ) THEN
ELSEIF (SHIFT.EQ.SRIGHT) THEN
* store new L and D back into DPLUS, LPLUS
CALL SCOPY( N, WORK, 1, DPLUS, 1 )
CALL SCOPY( N-1, WORK(N+1), 1, LPLUS, 1 )
ENDIF
RETURN
*
* End of SLARRF2
*
END
|
