LAPACK  3.7.0
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.
          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.
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 *
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
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
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: