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

NAME

SYNOPSIS

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

PURPOSE

319 LAPACK auxiliary routine (versionNo3v.e1m)ber 2006                       ZLAQR2(1)