SRC\dlasorte.f
#lines: 145   size: 4 Kb   creation: 29/03/2007 01:44:42   last modification: 08/05/2008 18:37:40   attribute: ARCH    Find   Reload   
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
 
      SUBROUTINE DLASORTE( S, LDS, J, OUT, INFO )
*
*  -- ScaLAPACK routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     December 31, 1998
*
*     .. Scalar Arguments ..
      INTEGER            INFO, J, LDS
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   OUT( J, * ), S( LDS, * )
*     ..
*
*  Purpose
*  =======
*
*  DLASORTE sorts eigenpairs so that real eigenpairs are together and
*    complex are together.  This way one can employ 2x2 shifts easily
*    since every 2nd subdiagonal is guaranteed to be zero.
*  This routine does no parallel work.
*
*  Arguments
*  =========
*
*  S       (local input/output) DOUBLE PRECISION array, dimension LDS
*          On entry, a matrix already in Schur form.
*          On exit, the diagonal blocks of S have been rewritten to pair
*             the eigenvalues.  The resulting matrix is no longer
*             similar to the input.
*
*  LDS     (local input) INTEGER
*          On entry, the leading dimension of the local array S.
*          Unchanged on exit.
*
*  J       (local input) INTEGER
*          On entry, the order of the matrix S.
*          Unchanged on exit.
*
*  OUT     (local input/output) DOUBLE PRECISION array, dimension Jx2
*          This is the work buffer required by this routine.
*
*  INFO    (local input) INTEGER
*          This is set if the input matrix had an odd number of real
*          eigenvalues and things couldn't be paired or if the input
*           matrix S was not originally in Schur form.
*          0 indicates successful completion.
*
*  Implemented by:  G. Henry, November 17, 1996
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            BOT, I, LAST, TOP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MOD
*     ..
*     .. Executable Statements ..
*
      LAST = J
      TOP = 1
      BOT = J
      INFO = 0
      DO 10 I = J - 1, 1, -1
         IF( S( I+1, I ).EQ.ZERO ) THEN
            IF( LAST-I.EQ.2 ) THEN
               OUT( BOT-1, 1 ) = S( I+1, I+1 )
               OUT( BOT, 2 ) = S( I+2, I+2 )
               OUT( BOT-1, 2 ) = S( I+1, I+2 )
               OUT( BOT, 1 ) = S( I+2, I+1 )
               BOT = BOT - 2
            END IF
            IF( LAST-I.EQ.1 ) THEN
               IF( MOD( TOP, 2 ).EQ.1 ) THEN
*
*                 FIRST OF A PAIR
*
                  IF( ( I.EQ.J-1 ) .OR. ( I.EQ.1 ) ) THEN
                     OUT( TOP, 1 ) = S( I+1, I+1 )
                  ELSE
                     OUT( TOP, 1 ) = S( I+1, I+1 )
                  END IF
                  OUT( TOP, 2 ) = ZERO
               ELSE
*
*                 SECOND OF A PAIR
*
                  IF( ( I.EQ.J-1 ) .OR. ( I.EQ.1 ) ) THEN
                     OUT( TOP, 2 ) = S( I+1, I+1 )
                  ELSE
                     OUT( TOP, 2 ) = S( I+1, I+1 )
                  END IF
                  OUT( TOP, 1 ) = ZERO
               END IF
               TOP = TOP + 1
            END IF
            IF( LAST-I.GT.2 ) THEN
               INFO = I
               RETURN
            END IF
            LAST = I
         END IF
   10 CONTINUE
      IF( LAST.EQ.2 ) THEN
*
*        GRAB LAST DOUBLE PAIR
*
         OUT( BOT-1, 1 ) = S( 1, 1 )
         OUT( BOT, 2 ) = S( 2, 2 )
         OUT( BOT-1, 2 ) = S( 1, 2 )
         OUT( BOT, 1 ) = S( 2, 1 )
         BOT = BOT - 2
      END IF
      IF( LAST.EQ.1 .and. mod(top, 2) .eq. 0 ) THEN
*
*        GRAB SECOND PART OF LAST PAIR
*
         OUT(TOP, 2) = s(1,1)
         OUT(TOP, 1) = zero
         TOP = TOP + 1
      END IF
      IF( TOP-1.NE.BOT ) THEN
         INFO = -BOT
         RETURN
      END IF
*
*     Overwrite the S diagonals
*
      DO 20 I = 1, J, 2
         S( I, I ) = OUT( I, 1 )
         S( I+1, I ) = OUT( I+1, 1 )
         S( I, I+1 ) = OUT( I, 2 )
         S( I+1, I+1 ) = OUT( I+1, 2 )
   20 CONTINUE
*
      RETURN
*
*     End of DLASORTE
*
      END