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

NAME

SYNOPSIS

7       SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ,
8                          Z, LDZ, NS, ND, SH, 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           COMPLEX*16     H( LDH, * ), SH( * ), T( LDT, *  ),  V(  LDV,  *  ),
17                          WORK( * ), WV( LDWV, * ), Z( LDZ, * )
18
19           COMPLEX*16     ZERO, ONE
20
21           PARAMETER      ( ZERO = ( 0.0d0, 0.0d0 ), ONE = ( 1.0d0, 0.0d0 ) )
22
23           DOUBLE         PRECISION RZERO, RONE
24
25           PARAMETER      ( RZERO = 0.0d0, RONE = 1.0d0 )
26
27           COMPLEX*16     BETA, CDUM, S, TAU
28
29           DOUBLE         PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP
30
31           INTEGER        I,  IFST,  ILST, INFO, INFQR, J, JW, KCOL, KLN, KNT,
32                          KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, LWKOPT, NMIN
33
34           DOUBLE         PRECISION DLAMCH
35
36           INTEGER        ILAENV
37
38           EXTERNAL       DLAMCH, ILAENV
39
40           EXTERNAL       DLABAD,  ZCOPY,  ZGEHRD,  ZGEMM,   ZLACPY,   ZLAHQR,
41                          ZLAQR4, ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNGHR
42
43           INTRINSIC      ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN
44
45           DOUBLE         PRECISION CABS1
46
47           CABS1(         CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
48
49           JW             = MIN( NW, KBOT-KTOP+1 )
50
51           IF(            JW.LE.2 ) THEN
52
53           LWKOPT         = 1
54
55           ELSE
56
57           CALL           ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
58
59           LWK1           = INT( WORK( 1 ) )
60
61           CALL           ZUNGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
62
63           LWK2           = INT( WORK( 1 ) )
64
65           CALL           ZLAQR4(  .true.,  .true.,  JW, 1, JW, T, LDT, SH, 1,
66                          JW, V, LDV, WORK, -1, INFQR )
67
68           LWK3           = INT( WORK( 1 ) )
69
70           LWKOPT         = MAX( JW+MAX( LWK1, LWK2 ), LWK3 )
71
72           END            IF
73
74           IF(            LWORK.EQ.-1 ) THEN
75
76           WORK(          1 ) = DCMPLX( LWKOPT, 0 )
77
78           RETURN
79
80           END            IF
81
82           NS             = 0
83
84           ND             = 0
85
86           IF(            KTOP.GT.KBOT ) RETURN
87
88           IF(            NW.LT.1 ) RETURN
89
90           SAFMIN         = DLAMCH( 'SAFE MINIMUM' )
91
92           SAFMAX         = RONE / SAFMIN
93
94           CALL           DLABAD( SAFMIN, SAFMAX )
95
96           ULP            = DLAMCH( 'PRECISION' )
97
98           SMLNUM         = SAFMIN*( DBLE( N ) / ULP )
99
100           JW             = MIN( NW, KBOT-KTOP+1 )
101
102           KWTOP          = KBOT - JW + 1
103
104           IF(            KWTOP.EQ.KTOP ) THEN
105
106           S              = ZERO
107
108           ELSE
109
110           S              = H( KWTOP, KWTOP-1 )
111
112           END            IF
113
114           IF(            KBOT.EQ.KWTOP ) THEN
115
116           SH(            KWTOP ) = H( KWTOP, KWTOP )
117
118           NS             = 1
119
120           ND             = 0
121
122           IF(            CABS1( S  ).LE.MAX(  SMLNUM,  ULP*CABS1(  H(  KWTOP,
123                          KWTOP ) ) ) ) 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           RETURN
134
135           END            IF
136
137           CALL           ZLACPY(  'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT
138                          )
139
140           CALL           ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1  ),
141                          LDT+1 )
142
143           CALL           ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
144
145           NMIN           = ILAENV( 12, 'ZLAQR3', 'SV', JW, 1, JW, LWORK )
146
147           IF(            JW.GT.NMIN ) THEN
148
149           CALL           ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP
150                          ), 1, JW, V, LDV, WORK, LWORK, INFQR )
151
152           ELSE
153
154           CALL           ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP
155                          ), 1, JW, V, LDV, INFQR )
156
157           END            IF
158
159           NS             = JW
160
161           ILST           = INFQR + 1
162
163           DO             10 KNT = INFQR + 1, JW
164
165           FOO            = CABS1( T( NS, NS ) )
166
167           IF(            FOO.EQ.RZERO ) FOO = CABS1( S )
168
169           IF(            CABS1(  S  )*CABS1(  V(  1,  NS  ) ).LE.MAX( SMLNUM,
170                          ULP*FOO ) ) THEN
171
172           NS             = NS - 1
173
174           ELSE
175
176           IFST           = NS
177
178           CALL           ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
179
180           ILST           = ILST + 1
181
182           END            IF
183
184           10             CONTINUE
185
186           IF(            NS.EQ.0 ) S = ZERO
187
188           IF(            NS.LT.JW ) THEN
189
190           DO             30 I = INFQR + 1, NS
191
192           IFST           = I
193
194           DO             20 J = I + 1, NS
195
196           IF(            CABS1( T( J, J ) ).GT.CABS1( T( IFST,  IFST  )  )  )
197                          IFST = J
198
199           20             CONTINUE
200
201           ILST           = I
202
203           IF(            IFST.NE.ILST ) CALL ZTREXC( 'V', JW, T, LDT, V, LDV,
204                          IFST, ILST, INFO )
205
206           30             CONTINUE
207
208           END            IF
209
210           DO             40 I = INFQR + 1, JW
211
212           SH(            KWTOP+I-1 ) = T( I, I )
213
214           40             CONTINUE
215
216           IF(            NS.LT.JW .OR. S.EQ.ZERO ) THEN
217
218           IF(            NS.GT.1 .AND. S.NE.ZERO ) THEN
219
220           CALL           ZCOPY( NS, V, LDV, WORK, 1 )
221
222           DO             50 I = 1, NS
223
224           WORK(          I ) = DCONJG( WORK( I ) )
225
226           50             CONTINUE
227
228           BETA           = WORK( 1 )
229
230           CALL           ZLARFG( NS, BETA, WORK( 2 ), 1, TAU )
231
232           WORK(          1 ) = ONE
233
234           CALL           ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ),  LDT
235                          )
236
237           CALL           ZLARF(  'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT,
238                          WORK( JW+1 ) )
239
240           CALL           ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, WORK( JW+1
241                          ) )
242
243           CALL           ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, WORK( JW+1
244                          ) )
245
246           CALL           ZGEHRD( JW, 1, NS,  T,  LDT,  WORK,  WORK(  JW+1  ),
247                          LWORK-JW, INFO )
248
249           END            IF
250
251           IF(            KWTOP.GT.1 ) H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1
252                          ) )
253
254           CALL           ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ),  LDH
255                          )
256
257           CALL           ZCOPY(  JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ),
258                          LDH+1 )
259
260           IF(            NS.GT.1 .AND. S.NE.ZERO ) THEN
261
262           CALL           ZUNGHR( JW, 1, NS,  T,  LDT,  WORK,  WORK(  JW+1  ),
263                          LWORK-JW, INFO )
264
265           CALL           ZGEMM(  'N',  'N',  JW, NS, NS, ONE, V, LDV, T, LDT,
266                          ZERO, WV, LDWV )
267
268           CALL           ZLACPY( 'A', JW, NS, WV, LDWV, V, LDV )
269
270           END            IF
271
272           IF(            WANTT ) THEN
273
274           LTOP           = 1
275
276           ELSE
277
278           LTOP           = KTOP
279
280           END            IF
281
282           DO             60 KROW = LTOP, KWTOP - 1, NV
283
284           KLN            = MIN( NV, KWTOP-KROW )
285
286           CALL           ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
287                          LDH, V, LDV, ZERO, WV, LDWV )
288
289           CALL           ZLACPY(  'A',  KLN,  JW, WV, LDWV, H( KROW, KWTOP ),
290                          LDH )
291
292           60             CONTINUE
293
294           IF(            WANTT ) THEN
295
296           DO             70 KCOL = KBOT + 1, N, NH
297
298           KLN            = MIN( NH, N-KCOL+1 )
299
300           CALL           ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, H( KWTOP,
301                          KCOL ), LDH, ZERO, T, LDT )
302
303           CALL           ZLACPY(  'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), LDH
304                          )
305
306           70             CONTINUE
307
308           END            IF
309
310           IF(            WANTZ ) THEN
311
312           DO             80 KROW = ILOZ, IHIZ, NV
313
314           KLN            = MIN( NV, IHIZ-KROW+1 )
315
316           CALL           ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
317                          LDZ, V, LDV, ZERO, WV, LDWV )
318
319           CALL           ZLACPY(  'A',  KLN,  JW, WV, LDWV, Z( KROW, KWTOP ),
320                          LDZ )
321
322           80             CONTINUE
323
324           END            IF
325
326           END            IF
327
328           ND             = JW - NS
329
330           NS             = NS - INFQR
331
332           WORK(          1 ) = DCMPLX( LWKOPT, 0 )
333
334           END
335

PURPOSE

337 LAPACK auxiliary routine (versionNo3v.e1m)ber 2006                       ZLAQR3(1)