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

◆ strexc()

subroutine strexc ( character compq,
integer n,
real, dimension( ldt, * ) t,
integer ldt,
real, dimension( ldq, * ) q,
integer ldq,
integer ifst,
integer ilst,
real, dimension( * ) work,
integer info )

STREXC

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

Purpose:
!>
!> STREXC reorders the real Schur factorization of a real matrix
!> A = Q*T*Q**T, so that the diagonal block of T with row index IFST is
!> moved to row ILST.
!>
!> The real Schur form T is reordered by an orthogonal similarity
!> transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors
!> is updated by postmultiplying it with Z.
!>
!> T must be in Schur canonical form (as returned by SHSEQR), that is,
!> block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
!> 2-by-2 diagonal block has its diagonal elements equal and its
!> off-diagonal elements of opposite sign.
!>
Parameters
[in]COMPQ
!>          COMPQ is CHARACTER*1
!>          = 'V':  update the matrix Q of Schur vectors;
!>          = 'N':  do not update Q.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix T. N >= 0.
!>          If N == 0 arguments ILST and IFST may be any value.
!>
[in,out]T
!>          T is REAL array, dimension (LDT,N)
!>          On entry, the upper quasi-triangular matrix T, in Schur
!>          Schur canonical form.
!>          On exit, the reordered upper quasi-triangular matrix, again
!>          in Schur canonical form.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T. LDT >= max(1,N).
!>
[in,out]Q
!>          Q is REAL array, dimension (LDQ,N)
!>          On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
!>          On exit, if COMPQ = 'V', Q has been postmultiplied by the
!>          orthogonal transformation matrix Z which reorders T.
!>          If COMPQ = 'N', Q is not referenced.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.  LDQ >= 1, and if
!>          COMPQ = 'V', LDQ >= max(1,N).
!>
[in,out]IFST
!>          IFST is INTEGER
!>
[in,out]ILST
!>          ILST is INTEGER
!>
!>          Specify the reordering of the diagonal blocks of T.
!>          The block with row index IFST is moved to row ILST, by a
!>          sequence of transpositions between adjacent blocks.
!>          On exit, if IFST pointed on entry to the second row of a
!>          2-by-2 block, it is changed to point to the first row; ILST
!>          always points to the first row of the block in its final
!>          position (which may differ from its input value by +1 or -1).
!>          1 <= IFST <= N; 1 <= ILST <= N.
!>
[out]WORK
!>          WORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          = 1:  two adjacent blocks were too close to swap (the problem
!>                is very ill-conditioned); T may have been partially
!>                reordered, and ILST points to the first row of the
!>                current position of the block being moved.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 144 of file strexc.f.

146*
147* -- LAPACK computational routine --
148* -- LAPACK is a software package provided by Univ. of Tennessee, --
149* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
150*
151* .. Scalar Arguments ..
152 CHARACTER COMPQ
153 INTEGER IFST, ILST, INFO, LDQ, LDT, N
154* ..
155* .. Array Arguments ..
156 REAL Q( LDQ, * ), T( LDT, * ), WORK( * )
157* ..
158*
159* =====================================================================
160*
161* .. Parameters ..
162 REAL ZERO
163 parameter( zero = 0.0e+0 )
164* ..
165* .. Local Scalars ..
166 LOGICAL WANTQ
167 INTEGER HERE, NBF, NBL, NBNEXT
168* ..
169* .. External Functions ..
170 LOGICAL LSAME
171 EXTERNAL lsame
172* ..
173* .. External Subroutines ..
174 EXTERNAL slaexc, xerbla
175* ..
176* .. Intrinsic Functions ..
177 INTRINSIC max
178* ..
179* .. Executable Statements ..
180*
181* Decode and test the input arguments.
182*
183 info = 0
184 wantq = lsame( compq, 'V' )
185 IF( .NOT.wantq .AND. .NOT.lsame( compq, 'N' ) ) THEN
186 info = -1
187 ELSE IF( n.LT.0 ) THEN
188 info = -2
189 ELSE IF( ldt.LT.max( 1, n ) ) THEN
190 info = -4
191 ELSE IF( ldq.LT.1 .OR. ( wantq .AND. ldq.LT.max( 1, n ) ) ) THEN
192 info = -6
193 ELSE IF(( ifst.LT.1 .OR. ifst.GT.n ).AND.( n.GT.0 )) THEN
194 info = -7
195 ELSE IF(( ilst.LT.1 .OR. ilst.GT.n ).AND.( n.GT.0 )) THEN
196 info = -8
197 END IF
198 IF( info.NE.0 ) THEN
199 CALL xerbla( 'STREXC', -info )
200 RETURN
201 END IF
202*
203* Quick return if possible
204*
205 IF( n.LE.1 )
206 $ RETURN
207*
208* Determine the first row of specified block
209* and find out it is 1 by 1 or 2 by 2.
210*
211 IF( ifst.GT.1 ) THEN
212 IF( t( ifst, ifst-1 ).NE.zero )
213 $ ifst = ifst - 1
214 END IF
215 nbf = 1
216 IF( ifst.LT.n ) THEN
217 IF( t( ifst+1, ifst ).NE.zero )
218 $ nbf = 2
219 END IF
220*
221* Determine the first row of the final block
222* and find out it is 1 by 1 or 2 by 2.
223*
224 IF( ilst.GT.1 ) THEN
225 IF( t( ilst, ilst-1 ).NE.zero )
226 $ ilst = ilst - 1
227 END IF
228 nbl = 1
229 IF( ilst.LT.n ) THEN
230 IF( t( ilst+1, ilst ).NE.zero )
231 $ nbl = 2
232 END IF
233*
234 IF( ifst.EQ.ilst )
235 $ RETURN
236*
237 IF( ifst.LT.ilst ) THEN
238*
239* Update ILST
240*
241 IF( nbf.EQ.2 .AND. nbl.EQ.1 )
242 $ ilst = ilst - 1
243 IF( nbf.EQ.1 .AND. nbl.EQ.2 )
244 $ ilst = ilst + 1
245*
246 here = ifst
247*
248 10 CONTINUE
249*
250* Swap block with next one below
251*
252 IF( nbf.EQ.1 .OR. nbf.EQ.2 ) THEN
253*
254* Current block either 1 by 1 or 2 by 2
255*
256 nbnext = 1
257 IF( here+nbf+1.LE.n ) THEN
258 IF( t( here+nbf+1, here+nbf ).NE.zero )
259 $ nbnext = 2
260 END IF
261 CALL slaexc( wantq, n, t, ldt, q, ldq, here, nbf, nbnext,
262 $ work, info )
263 IF( info.NE.0 ) THEN
264 ilst = here
265 RETURN
266 END IF
267 here = here + nbnext
268*
269* Test if 2 by 2 block breaks into two 1 by 1 blocks
270*
271 IF( nbf.EQ.2 ) THEN
272 IF( t( here+1, here ).EQ.zero )
273 $ nbf = 3
274 END IF
275*
276 ELSE
277*
278* Current block consists of two 1 by 1 blocks each of which
279* must be swapped individually
280*
281 nbnext = 1
282 IF( here+3.LE.n ) THEN
283 IF( t( here+3, here+2 ).NE.zero )
284 $ nbnext = 2
285 END IF
286 CALL slaexc( wantq, n, t, ldt, q, ldq, here+1, 1, nbnext,
287 $ work, info )
288 IF( info.NE.0 ) THEN
289 ilst = here
290 RETURN
291 END IF
292 IF( nbnext.EQ.1 ) THEN
293*
294* Swap two 1 by 1 blocks, no problems possible
295*
296 CALL slaexc( wantq, n, t, ldt, q, ldq, here, 1,
297 $ nbnext,
298 $ work, info )
299 here = here + 1
300 ELSE
301*
302* Recompute NBNEXT in case 2 by 2 split
303*
304 IF( t( here+2, here+1 ).EQ.zero )
305 $ nbnext = 1
306 IF( nbnext.EQ.2 ) THEN
307*
308* 2 by 2 Block did not split
309*
310 CALL slaexc( wantq, n, t, ldt, q, ldq, here, 1,
311 $ nbnext, work, info )
312 IF( info.NE.0 ) THEN
313 ilst = here
314 RETURN
315 END IF
316 here = here + 2
317 ELSE
318*
319* 2 by 2 Block did split
320*
321 CALL slaexc( wantq, n, t, ldt, q, ldq, here, 1, 1,
322 $ work, info )
323 CALL slaexc( wantq, n, t, ldt, q, ldq, here+1, 1,
324 $ 1,
325 $ work, info )
326 here = here + 2
327 END IF
328 END IF
329 END IF
330 IF( here.LT.ilst )
331 $ GO TO 10
332*
333 ELSE
334*
335 here = ifst
336 20 CONTINUE
337*
338* Swap block with next one above
339*
340 IF( nbf.EQ.1 .OR. nbf.EQ.2 ) THEN
341*
342* Current block either 1 by 1 or 2 by 2
343*
344 nbnext = 1
345 IF( here.GE.3 ) THEN
346 IF( t( here-1, here-2 ).NE.zero )
347 $ nbnext = 2
348 END IF
349 CALL slaexc( wantq, n, t, ldt, q, ldq, here-nbnext,
350 $ nbnext,
351 $ nbf, work, info )
352 IF( info.NE.0 ) THEN
353 ilst = here
354 RETURN
355 END IF
356 here = here - nbnext
357*
358* Test if 2 by 2 block breaks into two 1 by 1 blocks
359*
360 IF( nbf.EQ.2 ) THEN
361 IF( t( here+1, here ).EQ.zero )
362 $ nbf = 3
363 END IF
364*
365 ELSE
366*
367* Current block consists of two 1 by 1 blocks each of which
368* must be swapped individually
369*
370 nbnext = 1
371 IF( here.GE.3 ) THEN
372 IF( t( here-1, here-2 ).NE.zero )
373 $ nbnext = 2
374 END IF
375 CALL slaexc( wantq, n, t, ldt, q, ldq, here-nbnext,
376 $ nbnext,
377 $ 1, work, info )
378 IF( info.NE.0 ) THEN
379 ilst = here
380 RETURN
381 END IF
382 IF( nbnext.EQ.1 ) THEN
383*
384* Swap two 1 by 1 blocks, no problems possible
385*
386 CALL slaexc( wantq, n, t, ldt, q, ldq, here, nbnext,
387 $ 1,
388 $ work, info )
389 here = here - 1
390 ELSE
391*
392* Recompute NBNEXT in case 2 by 2 split
393*
394 IF( t( here, here-1 ).EQ.zero )
395 $ nbnext = 1
396 IF( nbnext.EQ.2 ) THEN
397*
398* 2 by 2 Block did not split
399*
400 CALL slaexc( wantq, n, t, ldt, q, ldq, here-1, 2,
401 $ 1,
402 $ work, info )
403 IF( info.NE.0 ) THEN
404 ilst = here
405 RETURN
406 END IF
407 here = here - 2
408 ELSE
409*
410* 2 by 2 Block did split
411*
412 CALL slaexc( wantq, n, t, ldt, q, ldq, here, 1, 1,
413 $ work, info )
414 CALL slaexc( wantq, n, t, ldt, q, ldq, here-1, 1,
415 $ 1,
416 $ work, info )
417 here = here - 2
418 END IF
419 END IF
420 END IF
421 IF( here.GT.ilst )
422 $ GO TO 20
423 END IF
424 ilst = here
425*
426 RETURN
427*
428* End of STREXC
429*
xerbla
subroutine xerbla(srname, info)
Definition cblat2.f:3285
slaexc
subroutine slaexc(wantq, n, t, ldt, q, ldq, j1, n1, n2, work, info)
SLAEXC swaps adjacent diagonal blocks of a real upper quasi-triangular matrix in Schur canonical form...
Definition slaexc.f:136
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
Here is the call graph for this function:
Here is the caller graph for this function: