1SLAQR2(1)           LAPACK auxiliary routine (version 3.2)           SLAQR2(1)
2
3
4

NAME

SYNOPSIS

7       SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ,
8                          Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, LDT, NV,  WV,
9                          LDWV, WORK, LWORK )
10
11           INTEGER        IHIZ,  ILOZ,  KBOT,  KTOP, LDH, LDT, LDV, LDWV, LDZ,
12                          LWORK, N, ND, NH, NS, NV, NW
13
14           LOGICAL        WANTT, WANTZ
15
16           REAL           H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), V(  LDV,
17                          * ), WORK( * ), WV( LDWV, * ), Z( LDZ, * )
18
19           REAL           ZERO, ONE
20
21           PARAMETER      ( ZERO = 0.0e0, ONE = 1.0e0 )
22
23           REAL           AA,  BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, SAFMAX,
24                          SAFMIN, SMLNUM, SN, TAU, ULP
25
26           INTEGER        I, IFST, ILST, INFO, INFQR, J, JW,  K,  KCOL,  KEND,
27                          KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT
28
29           LOGICAL        BULGE, SORTED
30
31           REAL           SLAMCH
32
33           EXTERNAL       SLAMCH
34
35           EXTERNAL       SCOPY,   SGEHRD,   SGEMM,  SLABAD,  SLACPY,  SLAHQR,
36                          SLANV2, SLARF, SLARFG, SLASET, SORMHR, STREXC
37
38           INTRINSIC      ABS, INT, MAX, MIN, REAL, SQRT
39
40           JW             = MIN( NW, KBOT-KTOP+1 )
41
42           IF(            JW.LE.2 ) THEN
43
44           LWKOPT         = 1
45
46           ELSE
47
48           CALL           SGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
49
50           LWK1           = INT( WORK( 1 ) )
51
52           CALL           SORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK,  V,
53                          LDV, WORK, -1, INFO )
54
55           LWK2           = INT( WORK( 1 ) )
56
57           LWKOPT         = JW + MAX( LWK1, LWK2 )
58
59           END            IF
60
61           IF(            LWORK.EQ.-1 ) THEN
62
63           WORK(          1 ) = REAL( LWKOPT )
64
65           RETURN
66
67           END            IF
68
69           NS             = 0
70
71           ND             = 0
72
73           WORK(          1 ) = ONE
74
75           IF(            KTOP.GT.KBOT ) RETURN
76
77           IF(            NW.LT.1 ) RETURN
78
79           SAFMIN         = SLAMCH( 'SAFE MINIMUM' )
80
81           SAFMAX         = ONE / SAFMIN
82
83           CALL           SLABAD( SAFMIN, SAFMAX )
84
85           ULP            = SLAMCH( 'PRECISION' )
86
87           SMLNUM         = SAFMIN*( REAL( N ) / ULP )
88
89           JW             = MIN( NW, KBOT-KTOP+1 )
90
91           KWTOP          = KBOT - JW + 1
92
93           IF(            KWTOP.EQ.KTOP ) THEN
94
95           S              = ZERO
96
97           ELSE
98
99           S              = H( KWTOP, KWTOP-1 )
100
101           END            IF
102
103           IF(            KBOT.EQ.KWTOP ) THEN
104
105           SR(            KWTOP ) = H( KWTOP, KWTOP )
106
107           SI(            KWTOP ) = ZERO
108
109           NS             = 1
110
111           ND             = 0
112
113           IF(            ABS(  S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP )
114                          ) ) ) THEN
115
116           NS             = 0
117
118           ND             = 1
119
120           IF(            KWTOP.GT.KTOP ) H( KWTOP, KWTOP-1 ) = ZERO
121
122           END            IF
123
124           WORK(          1 ) = ONE
125
126           RETURN
127
128           END            IF
129
130           CALL           SLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T,  LDT
131                          )
132
133           CALL           SCOPY(  JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ),
134                          LDT+1 )
135
136           CALL           SLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
137
138           CALL           SLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP
139                          ), SI( KWTOP ), 1, JW, V, LDV, INFQR )
140
141           DO             10 J = 1, JW - 3
142
143           T(             J+2, J ) = ZERO
144
145           T(             J+3, J ) = ZERO
146
147           10             CONTINUE
148
149           IF(            JW.GT.2 ) T( JW, JW-2 ) = ZERO
150
151           NS             = JW
152
153           ILST           = INFQR + 1
154
155           20             CONTINUE
156
157           IF(            ILST.LE.NS ) THEN
158
159           IF(            NS.EQ.1 ) THEN
160
161           BULGE          = .FALSE.
162
163           ELSE
164
165           BULGE          = T( NS, NS-1 ).NE.ZERO
166
167           END            IF
168
169           IF(
170
171           FOO            = ABS( T( NS, NS ) )
172
173           IF(            FOO.EQ.ZERO ) FOO = ABS( S )
174
175           IF(            ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN
176
177           NS             = NS - 1
178
179           ELSE
180
181           IFST           = NS
182
183           CALL           STREXC(  'V',  JW, T, LDT, V, LDV, IFST, ILST, WORK,
184                          INFO )
185
186           ILST           = ILST + 1
187
188           END            IF
189
190           ELSE
191
192           FOO            = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )*
193                          SQRT( ABS( T( NS-1, NS ) ) )
194
195           IF(            FOO.EQ.ZERO ) FOO = ABS( S )
196
197           IF(            MAX(  ABS(  S*V(  1,  NS  ) ), ABS( S*V( 1, NS-1 ) )
198                          ).LE.  MAX( SMLNUM, ULP*FOO ) ) THEN
199
200           NS             = NS - 2
201
202           ELSE
203
204           IFST           = NS
205
206           CALL           STREXC( 'V', JW, T, LDT, V, LDV, IFST,  ILST,  WORK,
207                          INFO )
208
209           ILST           = ILST + 2
210
211           END            IF
212
213           END            IF
214
215           GO             TO 20
216
217           END            IF
218
219           IF(            NS.EQ.0 ) S = ZERO
220
221           IF(            NS.LT.JW ) THEN
222
223           SORTED         = .false.
224
225           I              = NS + 1
226
227           30             CONTINUE
228
229           IF(            SORTED ) GO TO 50
230
231           SORTED         = .true.
232
233           KEND           = I - 1
234
235           I              = INFQR + 1
236
237           IF(            I.EQ.NS ) THEN
238
239           K              = I + 1
240
241           ELSE           IF( T( I+1, I ).EQ.ZERO ) THEN
242
243           K              = I + 1
244
245           ELSE
246
247           K              = I + 2
248
249           END            IF
250
251           40             CONTINUE
252
253           IF(            K.LE.KEND ) THEN
254
255           IF(            K.EQ.I+1 ) THEN
256
257           EVI            = ABS( T( I, I ) )
258
259           ELSE
260
261           EVI            =  ABS(  T(  I,  I ) ) + SQRT( ABS( T( I+1, I ) ) )*
262                          SQRT( ABS( T( I, I+1 ) ) )
263
264           END            IF
265
266           IF(            K.EQ.KEND ) THEN
267
268           EVK            = ABS( T( K, K ) )
269
270           ELSE           IF( T( K+1, K ).EQ.ZERO ) THEN
271
272           EVK            = ABS( T( K, K ) )
273
274           ELSE
275
276           EVK            = ABS( T( K, K ) ) + SQRT( ABS( T( K+1,  K  )  )  )*
277                          SQRT( ABS( T( K, K+1 ) ) )
278
279           END            IF
280
281           IF(            EVI.GE.EVK ) THEN
282
283           I              = K
284
285           ELSE
286
287           SORTED         = .false.
288
289           IFST           = I
290
291           ILST           = K
292
293           CALL           STREXC(  'V',  JW, T, LDT, V, LDV, IFST, ILST, WORK,
294                          INFO )
295
296           IF(            INFO.EQ.0 ) THEN
297
298           I              = ILST
299
300           ELSE
301
302           I              = K
303
304           END            IF
305
306           END            IF
307
308           IF(            I.EQ.KEND ) THEN
309
310           K              = I + 1
311
312           ELSE           IF( T( I+1, I ).EQ.ZERO ) THEN
313
314           K              = I + 1
315
316           ELSE
317
318           K              = I + 2
319
320           END            IF
321
322           GO             TO 40
323
324           END            IF
325
326           GO             TO 30
327
328           50             CONTINUE
329
330           END            IF
331
332           I              = JW
333
334           60             CONTINUE
335
336           IF(            I.GE.INFQR+1 ) THEN
337
338           IF(            I.EQ.INFQR+1 ) THEN
339
340           SR(            KWTOP+I-1 ) = T( I, I )
341
342           SI(            KWTOP+I-1 ) = ZERO
343
344           I              = I - 1
345
346           ELSE           IF( T( I, I-1 ).EQ.ZERO ) THEN
347
348           SR(            KWTOP+I-1 ) = T( I, I )
349
350           SI(            KWTOP+I-1 ) = ZERO
351
352           I              = I - 1
353
354           ELSE
355
356           AA             = T( I-1, I-1 )
357
358           CC             = T( I, I-1 )
359
360           BB             = T( I-1, I )
361
362           DD             = T( I, I )
363
364           CALL           SLANV2(  AA,  BB,  CC,  DD,  SR(  KWTOP+I-2  ),  SI(
365                          KWTOP+I-2  ),  SR( KWTOP+I-1 ), SI( KWTOP+I-1 ), CS,
366                          SN )
367
368           I              = I - 2
369
370           END            IF
371
372           GO             TO 60
373
374           END            IF
375
376           IF(            NS.LT.JW .OR. S.EQ.ZERO ) THEN
377
378           IF(            NS.GT.1 .AND. S.NE.ZERO ) THEN
379
380           CALL           SCOPY( NS, V, LDV, WORK, 1 )
381
382           BETA           = WORK( 1 )
383
384           CALL           SLARFG( NS, BETA, WORK( 2 ), 1, TAU )
385
386           WORK(          1 ) = ONE
387
388           CALL           SLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ),  LDT
389                          )
390
391           CALL           SLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, WORK( JW+1
392                          ) )
393
394           CALL           SLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, WORK( JW+1
395                          ) )
396
397           CALL           SLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, WORK( JW+1
398                          ) )
399
400           CALL           SGEHRD( JW, 1, NS,  T,  LDT,  WORK,  WORK(  JW+1  ),
401                          LWORK-JW, INFO )
402
403           END            IF
404
405           IF(            KWTOP.GT.1 ) H( KWTOP, KWTOP-1 ) = S*V( 1, 1 )
406
407           CALL           SLACPY(  'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH
408                          )
409
410           CALL           SCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP  ),
411                          LDH+1 )
412
413           IF(            NS.GT.1 .AND. S.NE.ZERO ) CALL SORMHR( 'R', 'N', JW,
414                          NS, 1, NS, T, LDT,  WORK,  V,  LDV,  WORK(  JW+1  ),
415                          LWORK-JW, INFO )
416
417           IF(            WANTT ) THEN
418
419           LTOP           = 1
420
421           ELSE
422
423           LTOP           = KTOP
424
425           END            IF
426
427           DO             70 KROW = LTOP, KWTOP - 1, NV
428
429           KLN            = MIN( NV, KWTOP-KROW )
430
431           CALL           SGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
432                          LDH, V, LDV, ZERO, WV, LDWV )
433
434           CALL           SLACPY( 'A', KLN, JW, WV, LDWV, H(  KROW,  KWTOP  ),
435                          LDH )
436
437           70             CONTINUE
438
439           IF(            WANTT ) THEN
440
441           DO             80 KCOL = KBOT + 1, N, NH
442
443           KLN            = MIN( NH, N-KCOL+1 )
444
445           CALL           SGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, H( KWTOP,
446                          KCOL ), LDH, ZERO, T, LDT )
447
448           CALL           SLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ),  LDH
449                          )
450
451           80             CONTINUE
452
453           END            IF
454
455           IF(            WANTZ ) THEN
456
457           DO             90 KROW = ILOZ, IHIZ, NV
458
459           KLN            = MIN( NV, IHIZ-KROW+1 )
460
461           CALL           SGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
462                          LDZ, V, LDV, ZERO, WV, LDWV )
463
464           CALL           SLACPY( 'A', KLN, JW, WV, LDWV, Z(  KROW,  KWTOP  ),
465                          LDZ )
466
467           90             CONTINUE
468
469           END            IF
470
471           END            IF
472
473           ND             = JW - NS
474
475           NS             = NS - INFQR
476
477           WORK(          1 ) = REAL( LWKOPT )
478
479           END
480

PURPOSE

482 LAPACK auxiliary routine (versionNo3v.e2m)ber 2008                       SLAQR2(1)