1SLAQR3(1)           LAPACK auxiliary routine (version 3.1)           SLAQR3(1)
2
3
4

NAME

SYNOPSIS

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

PURPOSE

505 LAPACK auxiliary routine (versionNo3v.e1m)ber 2006                       SLAQR3(1)