LAPACK  3.8.0 LAPACK: Linear Algebra PACKage

## ◆ 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

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.```
Date
December 2016

Definition at line 150 of file strexc.f.

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