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

PURPOSE

485 LAPACK auxiliary routine (versionNo3v.e1m)ber 2006                       SLAQR2(1)