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

PURPOSE

502 LAPACK auxiliary routine (versionNo3v.e2m)ber 2008                       SLAQR3(1)