1 /* ./src_f77/ztrexc.f -- translated by f2c (version 20030320).
2 You must link the resulting object file with the libraries:
3 -lf2c -lm (in that order)
4 */
5
6 #include <punc/vf2c.h>
7
8 /* Table of constant values */
9
10 static integer c__1 = 1;
11
ztrexc_(char * compq,integer * n,doublecomplex * t,integer * ldt,doublecomplex * q,integer * ldq,integer * ifst,integer * ilst,integer * info,ftnlen compq_len)12 /* Subroutine */ int ztrexc_(char *compq, integer *n, doublecomplex *t,
13 integer *ldt, doublecomplex *q, integer *ldq, integer *ifst, integer *
14 ilst, integer *info, ftnlen compq_len)
15 {
16 /* System generated locals */
17 integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2, i__3;
18 doublecomplex z__1;
19
20 /* Builtin functions */
21 void d_cnjg(doublecomplex *, doublecomplex *);
22
23 /* Local variables */
24 static integer k, m1, m2, m3;
25 static doublereal cs;
26 static doublecomplex t11, t22, sn, temp;
27 extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
28 doublecomplex *, integer *, doublereal *, doublecomplex *);
29 extern logical lsame_(char *, char *, ftnlen, ftnlen);
30 static logical wantq;
31 extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlartg_(
32 doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
33 doublecomplex *);
34
35
36 /* -- LAPACK routine (version 3.0) -- */
37 /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
38 /* Courant Institute, Argonne National Lab, and Rice University */
39 /* March 31, 1993 */
40
41 /* .. Scalar Arguments .. */
42 /* .. */
43 /* .. Array Arguments .. */
44 /* .. */
45
46 /* Purpose */
47 /* ======= */
48
49 /* ZTREXC reorders the Schur factorization of a complex matrix */
50 /* A = Q*T*Q**H, so that the diagonal element of T with row index IFST */
51 /* is moved to row ILST. */
52
53 /* The Schur form T is reordered by a unitary similarity transformation */
54 /* Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by */
55 /* postmultplying it with Z. */
56
57 /* Arguments */
58 /* ========= */
59
60 /* COMPQ (input) CHARACTER*1 */
61 /* = 'V': update the matrix Q of Schur vectors; */
62 /* = 'N': do not update Q. */
63
64 /* N (input) INTEGER */
65 /* The order of the matrix T. N >= 0. */
66
67 /* T (input/output) COMPLEX*16 array, dimension (LDT,N) */
68 /* On entry, the upper triangular matrix T. */
69 /* On exit, the reordered upper triangular matrix. */
70
71 /* LDT (input) INTEGER */
72 /* The leading dimension of the array T. LDT >= max(1,N). */
73
74 /* Q (input/output) COMPLEX*16 array, dimension (LDQ,N) */
75 /* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */
76 /* On exit, if COMPQ = 'V', Q has been postmultiplied by the */
77 /* unitary transformation matrix Z which reorders T. */
78 /* If COMPQ = 'N', Q is not referenced. */
79
80 /* LDQ (input) INTEGER */
81 /* The leading dimension of the array Q. LDQ >= max(1,N). */
82
83 /* IFST (input) INTEGER */
84 /* ILST (input) INTEGER */
85 /* Specify the reordering of the diagonal elements of T: */
86 /* The element with row index IFST is moved to row ILST by a */
87 /* sequence of transpositions between adjacent elements. */
88 /* 1 <= IFST <= N; 1 <= ILST <= N. */
89
90 /* INFO (output) INTEGER */
91 /* = 0: successful exit */
92 /* < 0: if INFO = -i, the i-th argument had an illegal value */
93
94 /* ===================================================================== */
95
96 /* .. Local Scalars .. */
97 /* .. */
98 /* .. External Functions .. */
99 /* .. */
100 /* .. External Subroutines .. */
101 /* .. */
102 /* .. Intrinsic Functions .. */
103 /* .. */
104 /* .. Executable Statements .. */
105
106 /* Decode and test the input parameters. */
107
108 /* Parameter adjustments */
109 t_dim1 = *ldt;
110 t_offset = 1 + t_dim1;
111 t -= t_offset;
112 q_dim1 = *ldq;
113 q_offset = 1 + q_dim1;
114 q -= q_offset;
115
116 /* Function Body */
117 *info = 0;
118 wantq = lsame_(compq, "V", (ftnlen)1, (ftnlen)1);
119 if (! lsame_(compq, "N", (ftnlen)1, (ftnlen)1) && ! wantq) {
120 *info = -1;
121 } else if (*n < 0) {
122 *info = -2;
123 } else if (*ldt < max(1,*n)) {
124 *info = -4;
125 } else if (*ldq < 1 || wantq && *ldq < max(1,*n)) {
126 *info = -6;
127 } else if (*ifst < 1 || *ifst > *n) {
128 *info = -7;
129 } else if (*ilst < 1 || *ilst > *n) {
130 *info = -8;
131 }
132 if (*info != 0) {
133 i__1 = -(*info);
134 xerbla_("ZTREXC", &i__1, (ftnlen)6);
135 return 0;
136 }
137
138 /* Quick return if possible */
139
140 if (*n == 1 || *ifst == *ilst) {
141 return 0;
142 }
143
144 if (*ifst < *ilst) {
145
146 /* Move the IFST-th diagonal element forward down the diagonal. */
147
148 m1 = 0;
149 m2 = -1;
150 m3 = 1;
151 } else {
152
153 /* Move the IFST-th diagonal element backward up the diagonal. */
154
155 m1 = -1;
156 m2 = 0;
157 m3 = -1;
158 }
159
160 i__1 = *ilst + m2;
161 i__2 = m3;
162 for (k = *ifst + m1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
163
164 /* Interchange the k-th and (k+1)-th diagonal elements. */
165
166 i__3 = k + k * t_dim1;
167 t11.r = t[i__3].r, t11.i = t[i__3].i;
168 i__3 = k + 1 + (k + 1) * t_dim1;
169 t22.r = t[i__3].r, t22.i = t[i__3].i;
170
171 /* Determine the transformation to perform the interchange. */
172
173 z__1.r = t22.r - t11.r, z__1.i = t22.i - t11.i;
174 zlartg_(&t[k + (k + 1) * t_dim1], &z__1, &cs, &sn, &temp);
175
176 /* Apply transformation to the matrix T. */
177
178 if (k + 2 <= *n) {
179 i__3 = *n - k - 1;
180 zrot_(&i__3, &t[k + (k + 2) * t_dim1], ldt, &t[k + 1 + (k + 2) *
181 t_dim1], ldt, &cs, &sn);
182 }
183 i__3 = k - 1;
184 d_cnjg(&z__1, &sn);
185 zrot_(&i__3, &t[k * t_dim1 + 1], &c__1, &t[(k + 1) * t_dim1 + 1], &
186 c__1, &cs, &z__1);
187
188 i__3 = k + k * t_dim1;
189 t[i__3].r = t22.r, t[i__3].i = t22.i;
190 i__3 = k + 1 + (k + 1) * t_dim1;
191 t[i__3].r = t11.r, t[i__3].i = t11.i;
192
193 if (wantq) {
194
195 /* Accumulate transformation in the matrix Q. */
196
197 d_cnjg(&z__1, &sn);
198 zrot_(n, &q[k * q_dim1 + 1], &c__1, &q[(k + 1) * q_dim1 + 1], &
199 c__1, &cs, &z__1);
200 }
201
202 /* L10: */
203 }
204
205 return 0;
206
207 /* End of ZTREXC */
208
209 } /* ztrexc_ */
210
211