LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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.
[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 >= 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.
Date
November 2011

Definition at line 148 of file strexc.f.

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

Here is the call graph for this function:

Here is the caller graph for this function: