LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
dlaqz2.f
Go to the documentation of this file.
1*> \brief \b DLAQZ2
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8*> Download DLAQZ2 + dependencies
9*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaqz2.f">
10*> [TGZ]</a>
11*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaqz2.f">
12*> [ZIP]</a>
13*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaqz2.f">
14*> [TXT]</a>
15*
16* Definition:
17* ===========
18*
19* SUBROUTINE DLAQZ2( ILQ, ILZ, K, ISTARTM, ISTOPM, IHI, A, LDA, B,
20* $ LDB, NQ, QSTART, Q, LDQ, NZ, ZSTART, Z, LDZ )
21* IMPLICIT NONE
22*
23* Arguments
24* LOGICAL, INTENT( IN ) :: ILQ, ILZ
25* INTEGER, INTENT( IN ) :: K, LDA, LDB, LDQ, LDZ, ISTARTM, ISTOPM,
26* $ NQ, NZ, QSTART, ZSTART, IHI
27* DOUBLE PRECISION :: A( LDA, * ), B( LDB, * ), Q( LDQ, * ), Z( LDZ,
28* $ * )
29* ..
30*
31*
32*> \par Purpose:
33* =============
34*>
35*> \verbatim
36*>
37*> DLAQZ2 chases a 2x2 shift bulge in a matrix pencil down a single position
38*> \endverbatim
39*
40*
41* Arguments:
42* ==========
43*
44*>
45*> \param[in] ILQ
46*> \verbatim
47*> ILQ is LOGICAL
48*> Determines whether or not to update the matrix Q
49*> \endverbatim
50*>
51*> \param[in] ILZ
52*> \verbatim
53*> ILZ is LOGICAL
54*> Determines whether or not to update the matrix Z
55*> \endverbatim
56*>
57*> \param[in] K
58*> \verbatim
59*> K is INTEGER
60*> Index indicating the position of the bulge.
61*> On entry, the bulge is located in
62*> (A(k+1:k+2,k:k+1),B(k+1:k+2,k:k+1)).
63*> On exit, the bulge is located in
64*> (A(k+2:k+3,k+1:k+2),B(k+2:k+3,k+1:k+2)).
65*> \endverbatim
66*>
67*> \param[in] ISTARTM
68*> \verbatim
69*> ISTARTM is INTEGER
70*> \endverbatim
71*>
72*> \param[in] ISTOPM
73*> \verbatim
74*> ISTOPM is INTEGER
75*> Updates to (A,B) are restricted to
76*> (istartm:k+3,k:istopm). It is assumed
77*> without checking that istartm <= k+1 and
78*> k+2 <= istopm
79*> \endverbatim
80*>
81*> \param[in] IHI
82*> \verbatim
83*> IHI is INTEGER
84*> \endverbatim
85*>
86*> \param[inout] A
87*> \verbatim
88*> A is DOUBLE PRECISION array, dimension (LDA,N)
89*> \endverbatim
90*>
91*> \param[in] LDA
92*> \verbatim
93*> LDA is INTEGER
94*> The leading dimension of A as declared in
95*> the calling procedure.
96*> \endverbatim
97*
98*> \param[inout] B
99*> \verbatim
100*> B is DOUBLE PRECISION array, dimension (LDB,N)
101*> \endverbatim
102*>
103*> \param[in] LDB
104*> \verbatim
105*> LDB is INTEGER
106*> The leading dimension of B as declared in
107*> the calling procedure.
108*> \endverbatim
109*>
110*> \param[in] NQ
111*> \verbatim
112*> NQ is INTEGER
113*> The order of the matrix Q
114*> \endverbatim
115*>
116*> \param[in] QSTART
117*> \verbatim
118*> QSTART is INTEGER
119*> Start index of the matrix Q. Rotations are applied
120*> To columns k+2-qStart:k+4-qStart of Q.
121*> \endverbatim
122*
123*> \param[inout] Q
124*> \verbatim
125*> Q is DOUBLE PRECISION array, dimension (LDQ,NQ)
126*> \endverbatim
127*>
128*> \param[in] LDQ
129*> \verbatim
130*> LDQ is INTEGER
131*> The leading dimension of Q as declared in
132*> the calling procedure.
133*> \endverbatim
134*>
135*> \param[in] NZ
136*> \verbatim
137*> NZ is INTEGER
138*> The order of the matrix Z
139*> \endverbatim
140*>
141*> \param[in] ZSTART
142*> \verbatim
143*> ZSTART is INTEGER
144*> Start index of the matrix Z. Rotations are applied
145*> To columns k+1-qStart:k+3-qStart of Z.
146*> \endverbatim
147*
148*> \param[inout] Z
149*> \verbatim
150*> Z is DOUBLE PRECISION array, dimension (LDZ,NZ)
151*> \endverbatim
152*>
153*> \param[in] LDZ
154*> \verbatim
155*> LDZ is INTEGER
156*> The leading dimension of Q as declared in
157*> the calling procedure.
158*> \endverbatim
159*
160* Authors:
161* ========
162*
163*> \author Thijs Steel, KU Leuven
164*
165*> \date May 2020
166*
167*> \ingroup laqz2
168*>
169* =====================================================================
170 SUBROUTINE dlaqz2( ILQ, ILZ, K, ISTARTM, ISTOPM, IHI, A, LDA,
171 $ B,
172 $ LDB, NQ, QSTART, Q, LDQ, NZ, ZSTART, Z, LDZ )
173 IMPLICIT NONE
174*
175* Arguments
176 LOGICAL, INTENT( IN ) :: ILQ, ILZ
177 INTEGER, INTENT( IN ) :: K, LDA, LDB, LDQ, LDZ, ISTARTM, ISTOPM,
178 $ nq, nz, qstart, zstart, ihi
179 DOUBLE PRECISION :: A( LDA, * ), B( LDB, * ), Q( LDQ, * ), Z( LDZ,
180 $ * )
181*
182* Parameters
183 DOUBLE PRECISION :: ZERO, ONE, HALF
184 PARAMETER( ZERO = 0.0d0, one = 1.0d0, half = 0.5d0 )
185*
186* Local variables
187 DOUBLE PRECISION :: H( 2, 3 ), C1, S1, C2, S2, TEMP
188*
189* External functions
190 EXTERNAL :: dlartg, drot
191*
192 IF( k+2 .EQ. ihi ) THEN
193* Shift is located on the edge of the matrix, remove it
194 h = b( ihi-1:ihi, ihi-2:ihi )
195* Make H upper triangular
196 CALL dlartg( h( 1, 1 ), h( 2, 1 ), c1, s1, temp )
197 h( 2, 1 ) = zero
198 h( 1, 1 ) = temp
199 CALL drot( 2, h( 1, 2 ), 2, h( 2, 2 ), 2, c1, s1 )
200*
201 CALL dlartg( h( 2, 3 ), h( 2, 2 ), c1, s1, temp )
202 CALL drot( 1, h( 1, 3 ), 1, h( 1, 2 ), 1, c1, s1 )
203 CALL dlartg( h( 1, 2 ), h( 1, 1 ), c2, s2, temp )
204*
205 CALL drot( ihi-istartm+1, b( istartm, ihi ), 1, b( istartm,
206 $ ihi-1 ), 1, c1, s1 )
207 CALL drot( ihi-istartm+1, b( istartm, ihi-1 ), 1,
208 $ b( istartm,
209 $ ihi-2 ), 1, c2, s2 )
210 b( ihi-1, ihi-2 ) = zero
211 b( ihi, ihi-2 ) = zero
212 CALL drot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,
213 $ ihi-1 ), 1, c1, s1 )
214 CALL drot( ihi-istartm+1, a( istartm, ihi-1 ), 1,
215 $ a( istartm,
216 $ ihi-2 ), 1, c2, s2 )
217 IF ( ilz ) THEN
218 CALL drot( nz, z( 1, ihi-zstart+1 ), 1, z( 1,
219 $ ihi-1-zstart+
220 $ 1 ), 1, c1, s1 )
221 CALL drot( nz, z( 1, ihi-1-zstart+1 ), 1, z( 1,
222 $ ihi-2-zstart+1 ), 1, c2, s2 )
223 END IF
224*
225 CALL dlartg( a( ihi-1, ihi-2 ), a( ihi, ihi-2 ), c1, s1,
226 $ temp )
227 a( ihi-1, ihi-2 ) = temp
228 a( ihi, ihi-2 ) = zero
229 CALL drot( istopm-ihi+2, a( ihi-1, ihi-1 ), lda, a( ihi,
230 $ ihi-1 ), lda, c1, s1 )
231 CALL drot( istopm-ihi+2, b( ihi-1, ihi-1 ), ldb, b( ihi,
232 $ ihi-1 ), ldb, c1, s1 )
233 IF ( ilq ) THEN
234 CALL drot( nq, q( 1, ihi-1-qstart+1 ), 1, q( 1,
235 $ ihi-qstart+
236 $ 1 ), 1, c1, s1 )
237 END IF
238*
239 CALL dlartg( b( ihi, ihi ), b( ihi, ihi-1 ), c1, s1, temp )
240 b( ihi, ihi ) = temp
241 b( ihi, ihi-1 ) = zero
242 CALL drot( ihi-istartm, b( istartm, ihi ), 1, b( istartm,
243 $ ihi-1 ), 1, c1, s1 )
244 CALL drot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,
245 $ ihi-1 ), 1, c1, s1 )
246 IF ( ilz ) THEN
247 CALL drot( nz, z( 1, ihi-zstart+1 ), 1, z( 1,
248 $ ihi-1-zstart+
249 $ 1 ), 1, c1, s1 )
250 END IF
251*
252 ELSE
253*
254* Normal operation, move bulge down
255*
256 h = b( k+1:k+2, k:k+2 )
257*
258* Make H upper triangular
259*
260 CALL dlartg( h( 1, 1 ), h( 2, 1 ), c1, s1, temp )
261 h( 2, 1 ) = zero
262 h( 1, 1 ) = temp
263 CALL drot( 2, h( 1, 2 ), 2, h( 2, 2 ), 2, c1, s1 )
264*
265* Calculate Z1 and Z2
266*
267 CALL dlartg( h( 2, 3 ), h( 2, 2 ), c1, s1, temp )
268 CALL drot( 1, h( 1, 3 ), 1, h( 1, 2 ), 1, c1, s1 )
269 CALL dlartg( h( 1, 2 ), h( 1, 1 ), c2, s2, temp )
270*
271* Apply transformations from the right
272*
273 CALL drot( k+3-istartm+1, a( istartm, k+2 ), 1, a( istartm,
274 $ k+1 ), 1, c1, s1 )
275 CALL drot( k+3-istartm+1, a( istartm, k+1 ), 1, a( istartm,
276 $ k ), 1, c2, s2 )
277 CALL drot( k+2-istartm+1, b( istartm, k+2 ), 1, b( istartm,
278 $ k+1 ), 1, c1, s1 )
279 CALL drot( k+2-istartm+1, b( istartm, k+1 ), 1, b( istartm,
280 $ k ), 1, c2, s2 )
281 IF ( ilz ) THEN
282 CALL drot( nz, z( 1, k+2-zstart+1 ), 1, z( 1, k+1-zstart+
283 $ 1 ), 1, c1, s1 )
284 CALL drot( nz, z( 1, k+1-zstart+1 ), 1, z( 1,
285 $ k-zstart+1 ),
286 $ 1, c2, s2 )
287 END IF
288 b( k+1, k ) = zero
289 b( k+2, k ) = zero
290*
291* Calculate Q1 and Q2
292*
293 CALL dlartg( a( k+2, k ), a( k+3, k ), c1, s1, temp )
294 a( k+2, k ) = temp
295 a( k+3, k ) = zero
296 CALL dlartg( a( k+1, k ), a( k+2, k ), c2, s2, temp )
297 a( k+1, k ) = temp
298 a( k+2, k ) = zero
299*
300* Apply transformations from the left
301*
302 CALL drot( istopm-k, a( k+2, k+1 ), lda, a( k+3, k+1 ), lda,
303 $ c1, s1 )
304 CALL drot( istopm-k, a( k+1, k+1 ), lda, a( k+2, k+1 ), lda,
305 $ c2, s2 )
306*
307 CALL drot( istopm-k, b( k+2, k+1 ), ldb, b( k+3, k+1 ), ldb,
308 $ c1, s1 )
309 CALL drot( istopm-k, b( k+1, k+1 ), ldb, b( k+2, k+1 ), ldb,
310 $ c2, s2 )
311 IF ( ilq ) THEN
312 CALL drot( nq, q( 1, k+2-qstart+1 ), 1, q( 1, k+3-qstart+
313 $ 1 ), 1, c1, s1 )
314 CALL drot( nq, q( 1, k+1-qstart+1 ), 1, q( 1, k+2-qstart+
315 $ 1 ), 1, c2, s2 )
316 END IF
317*
318 END IF
319*
320* End of DLAQZ2
321*
322 END SUBROUTINE
subroutine dlaqz2(ilq, ilz, k, istartm, istopm, ihi, a, lda, b, ldb, nq, qstart, q, ldq, nz, zstart, z, ldz)
DLAQZ2
Definition dlaqz2.f:173
subroutine dlartg(f, g, c, s, r)
DLARTG generates a plane rotation with real cosine and real sine.
Definition dlartg.f90:111
subroutine drot(n, dx, incx, dy, incy, c, s)
DROT
Definition drot.f:92