LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ slaqz2()

subroutine slaqz2 ( logical, intent(in) ilq,
logical, intent(in) ilz,
integer, intent(in) k,
integer, intent(in) istartm,
integer, intent(in) istopm,
integer, intent(in) ihi,
real, dimension( lda, * ) a,
integer, intent(in) lda,
real, dimension( ldb, * ) b,
integer, intent(in) ldb,
integer, intent(in) nq,
integer, intent(in) qstart,
real, dimension( ldq, * ) q,
integer, intent(in) ldq,
integer, intent(in) nz,
integer, intent(in) zstart,
real, dimension( ldz, * ) z,
integer, intent(in) ldz )

SLAQZ2

Download SLAQZ2 + dependencies [TGZ] [ZIP] [TXT]

Purpose:
!>
!>      SLAQZ2 chases a 2x2 shift bulge in a matrix pencil down a single position
!>
Parameters
[in]ILQ
!>          ILQ is LOGICAL
!>              Determines whether or not to update the matrix Q
!>
[in]ILZ
!>          ILZ is LOGICAL
!>              Determines whether or not to update the matrix Z
!>
[in]K
!>          K is INTEGER
!>              Index indicating the position of the bulge.
!>              On entry, the bulge is located in
!>              (A(k+1:k+2,k:k+1),B(k+1:k+2,k:k+1)).
!>              On exit, the bulge is located in
!>              (A(k+2:k+3,k+1:k+2),B(k+2:k+3,k+1:k+2)).
!>
[in]ISTARTM
!>          ISTARTM is INTEGER
!>
[in]ISTOPM
!>          ISTOPM is INTEGER
!>              Updates to (A,B) are restricted to
!>              (istartm:k+3,k:istopm). It is assumed
!>              without checking that istartm <= k+1 and
!>              k+2 <= istopm
!>
[in]IHI
!>          IHI is INTEGER
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>
[in]LDA
!>          LDA is INTEGER
!>              The leading dimension of A as declared in
!>              the calling procedure.
!>
[in,out]B
!>          B is REAL array, dimension (LDB,N)
!>
[in]LDB
!>          LDB is INTEGER
!>              The leading dimension of B as declared in
!>              the calling procedure.
!>
[in]NQ
!>          NQ is INTEGER
!>              The order of the matrix Q
!>
[in]QSTART
!>          QSTART is INTEGER
!>              Start index of the matrix Q. Rotations are applied
!>              To columns k+2-qStart:k+4-qStart of Q.
!>
[in,out]Q
!>          Q is REAL array, dimension (LDQ,NQ)
!>
[in]LDQ
!>          LDQ is INTEGER
!>              The leading dimension of Q as declared in
!>              the calling procedure.
!>
[in]NZ
!>          NZ is INTEGER
!>              The order of the matrix Z
!>
[in]ZSTART
!>          ZSTART is INTEGER
!>              Start index of the matrix Z. Rotations are applied
!>              To columns k+1-qStart:k+3-qStart of Z.
!>
[in,out]Z
!>          Z is REAL array, dimension (LDZ,NZ)
!>
[in]LDZ
!>          LDZ is INTEGER
!>              The leading dimension of Q as declared in
!>              the calling procedure.
!>
Author
Thijs Steel, KU Leuven
Date
May 2020

Definition at line 169 of file slaqz2.f.

172 IMPLICIT NONE
173*
174* Arguments
175 LOGICAL, INTENT( IN ) :: ILQ, ILZ
176 INTEGER, INTENT( IN ) :: K, LDA, LDB, LDQ, LDZ, ISTARTM, ISTOPM,
177 $ NQ, NZ, QSTART, ZSTART, IHI
178 REAL :: A( LDA, * ), B( LDB, * ), Q( LDQ, * ), Z( LDZ, * )
179*
180* Parameters
181 REAL :: ZERO, ONE, HALF
182 parameter( zero = 0.0, one = 1.0, half = 0.5 )
183*
184* Local variables
185 REAL :: H( 2, 3 ), C1, S1, C2, S2, TEMP
186*
187* External functions
188 EXTERNAL :: slartg, srot
189*
190 IF( k+2 .EQ. ihi ) THEN
191* Shift is located on the edge of the matrix, remove it
192 h = b( ihi-1:ihi, ihi-2:ihi )
193* Make H upper triangular
194 CALL slartg( h( 1, 1 ), h( 2, 1 ), c1, s1, temp )
195 h( 2, 1 ) = zero
196 h( 1, 1 ) = temp
197 CALL srot( 2, h( 1, 2 ), 2, h( 2, 2 ), 2, c1, s1 )
198*
199 CALL slartg( h( 2, 3 ), h( 2, 2 ), c1, s1, temp )
200 CALL srot( 1, h( 1, 3 ), 1, h( 1, 2 ), 1, c1, s1 )
201 CALL slartg( h( 1, 2 ), h( 1, 1 ), c2, s2, temp )
202*
203 CALL srot( ihi-istartm+1, b( istartm, ihi ), 1, b( istartm,
204 $ ihi-1 ), 1, c1, s1 )
205 CALL srot( ihi-istartm+1, b( istartm, ihi-1 ), 1,
206 $ b( istartm,
207 $ ihi-2 ), 1, c2, s2 )
208 b( ihi-1, ihi-2 ) = zero
209 b( ihi, ihi-2 ) = zero
210 CALL srot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,
211 $ ihi-1 ), 1, c1, s1 )
212 CALL srot( ihi-istartm+1, a( istartm, ihi-1 ), 1,
213 $ a( istartm,
214 $ ihi-2 ), 1, c2, s2 )
215 IF ( ilz ) THEN
216 CALL srot( nz, z( 1, ihi-zstart+1 ), 1, z( 1,
217 $ ihi-1-zstart+
218 $ 1 ), 1, c1, s1 )
219 CALL srot( nz, z( 1, ihi-1-zstart+1 ), 1, z( 1,
220 $ ihi-2-zstart+1 ), 1, c2, s2 )
221 END IF
222*
223 CALL slartg( a( ihi-1, ihi-2 ), a( ihi, ihi-2 ), c1, s1,
224 $ temp )
225 a( ihi-1, ihi-2 ) = temp
226 a( ihi, ihi-2 ) = zero
227 CALL srot( istopm-ihi+2, a( ihi-1, ihi-1 ), lda, a( ihi,
228 $ ihi-1 ), lda, c1, s1 )
229 CALL srot( istopm-ihi+2, b( ihi-1, ihi-1 ), ldb, b( ihi,
230 $ ihi-1 ), ldb, c1, s1 )
231 IF ( ilq ) THEN
232 CALL srot( nq, q( 1, ihi-1-qstart+1 ), 1, q( 1,
233 $ ihi-qstart+
234 $ 1 ), 1, c1, s1 )
235 END IF
236*
237 CALL slartg( b( ihi, ihi ), b( ihi, ihi-1 ), c1, s1, temp )
238 b( ihi, ihi ) = temp
239 b( ihi, ihi-1 ) = zero
240 CALL srot( ihi-istartm, b( istartm, ihi ), 1, b( istartm,
241 $ ihi-1 ), 1, c1, s1 )
242 CALL srot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,
243 $ ihi-1 ), 1, c1, s1 )
244 IF ( ilz ) THEN
245 CALL srot( nz, z( 1, ihi-zstart+1 ), 1, z( 1,
246 $ ihi-1-zstart+
247 $ 1 ), 1, c1, s1 )
248 END IF
249*
250 ELSE
251*
252* Normal operation, move bulge down
253*
254 h = b( k+1:k+2, k:k+2 )
255*
256* Make H upper triangular
257*
258 CALL slartg( h( 1, 1 ), h( 2, 1 ), c1, s1, temp )
259 h( 2, 1 ) = zero
260 h( 1, 1 ) = temp
261 CALL srot( 2, h( 1, 2 ), 2, h( 2, 2 ), 2, c1, s1 )
262*
263* Calculate Z1 and Z2
264*
265 CALL slartg( h( 2, 3 ), h( 2, 2 ), c1, s1, temp )
266 CALL srot( 1, h( 1, 3 ), 1, h( 1, 2 ), 1, c1, s1 )
267 CALL slartg( h( 1, 2 ), h( 1, 1 ), c2, s2, temp )
268*
269* Apply transformations from the right
270*
271 CALL srot( k+3-istartm+1, a( istartm, k+2 ), 1, a( istartm,
272 $ k+1 ), 1, c1, s1 )
273 CALL srot( k+3-istartm+1, a( istartm, k+1 ), 1, a( istartm,
274 $ k ), 1, c2, s2 )
275 CALL srot( k+2-istartm+1, b( istartm, k+2 ), 1, b( istartm,
276 $ k+1 ), 1, c1, s1 )
277 CALL srot( k+2-istartm+1, b( istartm, k+1 ), 1, b( istartm,
278 $ k ), 1, c2, s2 )
279 IF ( ilz ) THEN
280 CALL srot( nz, z( 1, k+2-zstart+1 ), 1, z( 1, k+1-zstart+
281 $ 1 ), 1, c1, s1 )
282 CALL srot( nz, z( 1, k+1-zstart+1 ), 1, z( 1,
283 $ k-zstart+1 ),
284 $ 1, c2, s2 )
285 END IF
286 b( k+1, k ) = zero
287 b( k+2, k ) = zero
288*
289* Calculate Q1 and Q2
290*
291 CALL slartg( a( k+2, k ), a( k+3, k ), c1, s1, temp )
292 a( k+2, k ) = temp
293 a( k+3, k ) = zero
294 CALL slartg( a( k+1, k ), a( k+2, k ), c2, s2, temp )
295 a( k+1, k ) = temp
296 a( k+2, k ) = zero
297*
298* Apply transformations from the left
299*
300 CALL srot( istopm-k, a( k+2, k+1 ), lda, a( k+3, k+1 ), lda,
301 $ c1, s1 )
302 CALL srot( istopm-k, a( k+1, k+1 ), lda, a( k+2, k+1 ), lda,
303 $ c2, s2 )
304*
305 CALL srot( istopm-k, b( k+2, k+1 ), ldb, b( k+3, k+1 ), ldb,
306 $ c1, s1 )
307 CALL srot( istopm-k, b( k+1, k+1 ), ldb, b( k+2, k+1 ), ldb,
308 $ c2, s2 )
309 IF ( ilq ) THEN
310 CALL srot( nq, q( 1, k+2-qstart+1 ), 1, q( 1, k+3-qstart+
311 $ 1 ), 1, c1, s1 )
312 CALL srot( nq, q( 1, k+1-qstart+1 ), 1, q( 1, k+2-qstart+
313 $ 1 ), 1, c2, s2 )
314 END IF
315*
316 END IF
317*
318* End of SLAQZ2
319*
slartg
subroutine slartg(f, g, c, s, r)
SLARTG generates a plane rotation with real cosine and real sine.
Definition slartg.f90:111
srot
subroutine srot(n, sx, incx, sy, incy, c, s)
SROT
Definition srot.f:92
Here is the call graph for this function:
Here is the caller graph for this function: