1 /* ./src_f77/cgebak.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
cgebak_(char * job,char * side,integer * n,integer * ilo,integer * ihi,real * scale,integer * m,complex * v,integer * ldv,integer * info,ftnlen job_len,ftnlen side_len)8 /* Subroutine */ int cgebak_(char *job, char *side, integer *n, integer *ilo,
9 integer *ihi, real *scale, integer *m, complex *v, integer *ldv,
10 integer *info, ftnlen job_len, ftnlen side_len)
11 {
12 /* System generated locals */
13 integer v_dim1, v_offset, i__1;
14
15 /* Local variables */
16 static integer i__, k;
17 static real s;
18 static integer ii;
19 extern logical lsame_(char *, char *, ftnlen, ftnlen);
20 extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
21 complex *, integer *);
22 static logical leftv;
23 extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
24 *), xerbla_(char *, integer *, ftnlen);
25 static logical rightv;
26
27
28 /* -- LAPACK routine (version 3.0) -- */
29 /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
30 /* Courant Institute, Argonne National Lab, and Rice University */
31 /* September 30, 1994 */
32
33 /* .. Scalar Arguments .. */
34 /* .. */
35 /* .. Array Arguments .. */
36 /* .. */
37
38 /* Purpose */
39 /* ======= */
40
41 /* CGEBAK forms the right or left eigenvectors of a complex general */
42 /* matrix by backward transformation on the computed eigenvectors of the */
43 /* balanced matrix output by CGEBAL. */
44
45 /* Arguments */
46 /* ========= */
47
48 /* JOB (input) CHARACTER*1 */
49 /* Specifies the type of backward transformation required: */
50 /* = 'N', do nothing, return immediately; */
51 /* = 'P', do backward transformation for permutation only; */
52 /* = 'S', do backward transformation for scaling only; */
53 /* = 'B', do backward transformations for both permutation and */
54 /* scaling. */
55 /* JOB must be the same as the argument JOB supplied to CGEBAL. */
56
57 /* SIDE (input) CHARACTER*1 */
58 /* = 'R': V contains right eigenvectors; */
59 /* = 'L': V contains left eigenvectors. */
60
61 /* N (input) INTEGER */
62 /* The number of rows of the matrix V. N >= 0. */
63
64 /* ILO (input) INTEGER */
65 /* IHI (input) INTEGER */
66 /* The integers ILO and IHI determined by CGEBAL. */
67 /* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
68
69 /* SCALE (input) REAL array, dimension (N) */
70 /* Details of the permutation and scaling factors, as returned */
71 /* by CGEBAL. */
72
73 /* M (input) INTEGER */
74 /* The number of columns of the matrix V. M >= 0. */
75
76 /* V (input/output) COMPLEX array, dimension (LDV,M) */
77 /* On entry, the matrix of right or left eigenvectors to be */
78 /* transformed, as returned by CHSEIN or CTREVC. */
79 /* On exit, V is overwritten by the transformed eigenvectors. */
80
81 /* LDV (input) INTEGER */
82 /* The leading dimension of the array V. LDV >= max(1,N). */
83
84 /* INFO (output) INTEGER */
85 /* = 0: successful exit */
86 /* < 0: if INFO = -i, the i-th argument had an illegal value. */
87
88 /* ===================================================================== */
89
90 /* .. Parameters .. */
91 /* .. */
92 /* .. Local Scalars .. */
93 /* .. */
94 /* .. External Functions .. */
95 /* .. */
96 /* .. External Subroutines .. */
97 /* .. */
98 /* .. Intrinsic Functions .. */
99 /* .. */
100 /* .. Executable Statements .. */
101
102 /* Decode and Test the input parameters */
103
104 /* Parameter adjustments */
105 --scale;
106 v_dim1 = *ldv;
107 v_offset = 1 + v_dim1;
108 v -= v_offset;
109
110 /* Function Body */
111 rightv = lsame_(side, "R", (ftnlen)1, (ftnlen)1);
112 leftv = lsame_(side, "L", (ftnlen)1, (ftnlen)1);
113
114 *info = 0;
115 if (! lsame_(job, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(job, "P", (
116 ftnlen)1, (ftnlen)1) && ! lsame_(job, "S", (ftnlen)1, (ftnlen)1)
117 && ! lsame_(job, "B", (ftnlen)1, (ftnlen)1)) {
118 *info = -1;
119 } else if (! rightv && ! leftv) {
120 *info = -2;
121 } else if (*n < 0) {
122 *info = -3;
123 } else if (*ilo < 1 || *ilo > max(1,*n)) {
124 *info = -4;
125 } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
126 *info = -5;
127 } else if (*m < 0) {
128 *info = -7;
129 } else if (*ldv < max(1,*n)) {
130 *info = -9;
131 }
132 if (*info != 0) {
133 i__1 = -(*info);
134 xerbla_("CGEBAK", &i__1, (ftnlen)6);
135 return 0;
136 }
137
138 /* Quick return if possible */
139
140 if (*n == 0) {
141 return 0;
142 }
143 if (*m == 0) {
144 return 0;
145 }
146 if (lsame_(job, "N", (ftnlen)1, (ftnlen)1)) {
147 return 0;
148 }
149
150 if (*ilo == *ihi) {
151 goto L30;
152 }
153
154 /* Backward balance */
155
156 if (lsame_(job, "S", (ftnlen)1, (ftnlen)1) || lsame_(job, "B", (ftnlen)1,
157 (ftnlen)1)) {
158
159 if (rightv) {
160 i__1 = *ihi;
161 for (i__ = *ilo; i__ <= i__1; ++i__) {
162 s = scale[i__];
163 csscal_(m, &s, &v[i__ + v_dim1], ldv);
164 /* L10: */
165 }
166 }
167
168 if (leftv) {
169 i__1 = *ihi;
170 for (i__ = *ilo; i__ <= i__1; ++i__) {
171 s = 1.f / scale[i__];
172 csscal_(m, &s, &v[i__ + v_dim1], ldv);
173 /* L20: */
174 }
175 }
176
177 }
178
179 /* Backward permutation */
180
181 /* For I = ILO-1 step -1 until 1, */
182 /* IHI+1 step 1 until N do -- */
183
184 L30:
185 if (lsame_(job, "P", (ftnlen)1, (ftnlen)1) || lsame_(job, "B", (ftnlen)1,
186 (ftnlen)1)) {
187 if (rightv) {
188 i__1 = *n;
189 for (ii = 1; ii <= i__1; ++ii) {
190 i__ = ii;
191 if (i__ >= *ilo && i__ <= *ihi) {
192 goto L40;
193 }
194 if (i__ < *ilo) {
195 i__ = *ilo - ii;
196 }
197 k = scale[i__];
198 if (k == i__) {
199 goto L40;
200 }
201 cswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
202 L40:
203 ;
204 }
205 }
206
207 if (leftv) {
208 i__1 = *n;
209 for (ii = 1; ii <= i__1; ++ii) {
210 i__ = ii;
211 if (i__ >= *ilo && i__ <= *ihi) {
212 goto L50;
213 }
214 if (i__ < *ilo) {
215 i__ = *ilo - ii;
216 }
217 k = scale[i__];
218 if (k == i__) {
219 goto L50;
220 }
221 cswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
222 L50:
223 ;
224 }
225 }
226 }
227
228 return 0;
229
230 /* End of CGEBAK */
231
232 } /* cgebak_ */
233
234