File Coverage

lib/PDL/MatrixOps/eigen.c
Criterion Covered Total %
statement 493 633 77.8
branch 250 328 76.2
condition n/a
subroutine n/a
pod n/a
total 743 961 77.3


line stmt bran cond sub pod time code
1             /*
2             * eigen.c - calculation of eigen values and vectors.
3             *
4             * (C) Copyright 2001 by NetGroup A/S. All rights reserved.
5             *
6             * $Log$
7             * Revision 1.1 2006/06/20 15:57:22 djburke
8             * Hopefully a saner way to build Basic/MatrixOps
9             *
10             * Revision 1.1 2005/01/08 09:22:57 zowie
11             * Added non-symmetric matrices to eigens; updated version to 2.4.2cvs.
12             *
13             * Revision 1.1.1.1 2001/07/06 13:39:35 kneth
14             * Initial import of code.
15             *
16             *
17             * Eigen is a library for computing eigenvalues and eigenvectors of general
18             * matrices. There is only one routine exported, namely Eigen.
19             *
20             * The meaning of the arguments to Eigen is:
21             * 1. The dimension of the general matrix (n).
22             * 2. A general matrix (A).
23             * 3. The maximal number of iterations.
24             * 4. The precision.
25             * 5. A vector with the eigenvalues.
26             * 6. A matrix with the eigenvectors.
27             *
28             */
29              
30             #include
31             #include "matrix.h"
32             #include
33             #include
34              
35 22           void BlockCheck(double **A, int n, int i, int *block, double epsx) {
36              
37             /* block == 1 <=> TRUE, block == 0 <=> FALSE */
38              
39 22 100         if (i>=n-1)
40 6           *block=0;
41             else {
42 16 100         if ((fabs(A[i][i+1]-A[i+1][i])>epsx) &&
43 8 50         (fabs(A[i][i]-A[i+1][i+1])<=epsx))
44 8           *block=1;
45             else
46 8           *block=0;
47             } /* else */
48 22           } /* BlockCheck */
49              
50              
51 0           void PrintEigen(int n, double **A, double **B, double eps, FILE *outfile) {
52              
53             int i, j;
54             int block;
55              
56 0           fprintf(outfile, "\nEigenvalues:\t\t\tRe\t\t\tIm\n");
57 0           i=0;
58             do {
59 0           BlockCheck(A, n, i, &block, eps);
60 0 0         if (block==1) {
61 0           fprintf(outfile, "\t\t\t\t%e\t\t%e\n", A[i][i], A[i][i+1]);
62 0           fprintf(outfile, "\t\t\t\t%e\t\t%e\n", A[i+1][i+1], A[i+1][i]);
63 0           i+=2;
64             } else {
65 0           fprintf(outfile, "\t\t\t\t%e\t\t%e\n", A[i][i], 0.0);
66 0           i++;
67             } /* if else */
68 0 0         } while (i
69 0           fprintf(outfile, "\nEigenvectors:\t\t\tRe\t\t\tIm\n");
70 0           i=0;
71             do {
72 0           BlockCheck(A, n, i, &block, eps);
73 0 0         if (block==1) {
74 0 0         for(j=0; j
75 0           fprintf(outfile, "\t\t\t\t%e\t\t%e\n", B[j][i], B[j][i+1]);
76 0           fprintf(outfile, "\n");
77 0 0         for(j=0; j
78 0           fprintf(outfile, "\t\t\t\t%e\t\t%e\n", B[j][i], -B[j][i+1]);
79 0           fprintf(outfile, "\n");
80 0           i+=2;
81             } else {
82 0 0         for(j=0; j
83 0           fprintf(outfile, "\t\t\t\t%e\t\t%e\n", B[j][i], 0.0);
84 0           fprintf(outfile, "\n");
85 0           i++;
86             } /* if else */
87 0 0         } while (i
88 0           } /* PrintEigen */
89              
90              
91 3           void NormalizingMatrix(int n, double **A,
92             double **V, double eps) {
93              
94 3           int j, col=0, block;
95              
96             do {
97 6           double sumsq = 0;
98 6           BlockCheck(A, n, col, &block, eps);
99 24 100         for(j=0; j
100 18 100         sumsq += (V[j][col] * V[j][col]) + (block==1 ? (V[j][col+1] * V[j][col+1]) : 0);
101 6           double norm = sqrt(sumsq);
102 6 50         if (norm == 0.0) continue;
103 6 100         if (block==1) {
104 8 100         for(j=0; j
105 6           complex double c2 = V[j][col] + I * V[j][col+1], c3 = c2 / norm;
106 6           V[j][col]=creal(c3);
107 6           V[j][col+1]=cimag(c3);
108             } /* for j */
109 2           col+=2;
110             } else {
111 16 100         for(j=0; j
112 12           V[j][col] /= norm;
113 4           col++;
114             }
115 6 100         } while (col
116 3           } /* NormalizingMatrix */
117              
118 3           void Permutation(int n, double **P, double **A, double **B, int colon,
119             double eps) {
120              
121             int *nr;
122             int block;
123             double max, x;
124             int im, j, u, i, k, ii;
125             double **AA;
126              
127 3           nr=IntVectorAlloc(n);
128 3           AA=MatrixAlloc(n);
129              
130 3           MatrixCopy(n, AA, A);
131 11 100         for(i=0; i
132 8           nr[i]=i;
133 32 100         for(k=0; k
134 24           P[i][k]=0.0;
135             } /* for i */
136 3           i=ii=0;
137 7 100         while (i
138 4           BlockCheck(A, n, i, &block, eps);
139 4 100         if (block==1) {
140 2           A[i+1][i+1]=A[i][i];
141 2           AA[i+1][i+1]=AA[i][i];
142 2 50         if (A[i][i+1]>0.0) {
143 2           A[i+1][i]=A[i][i+1];
144 2           A[i][i+1]=-A[i+1][i];
145 2           AA[i+1][i]=AA[i][i+1];
146 2           AA[i][i+1]=-AA[i+1][i];
147 8 100         for(j=0; j
148 6           B[j][i+1]=-B[j][i+1];
149             } else {
150 0           A[i+1][i]=-A[i][i+1];
151 0           AA[i+1][i]=-AA[i][i+1];
152             } /* else */
153 2           j=i;
154 2 50         for(k=ii; k
155 0           x=AA[k][k];
156 0           AA[k][k]=A[j][j];
157 0           AA[j][j]=x;
158 0           u=nr[k];
159 0           nr[k]=nr[j];
160 0           nr[j]=u;
161 0           j++;
162             } /* for k */
163 2 50         if (ii>0) {
164 0 0         if (AA[ii][ii]>AA[0][0]) {
165 0           j=ii;
166 0 0         for(k=0; k<2; k++) {
167 0           x=AA[k][k];
168 0           AA[k][k]=A[j][j];
169 0           AA[j][j]=x;
170 0           u=nr[k];
171 0           nr[k]=nr[j];
172 0           nr[j]=u;
173 0           j++;
174             } /* for k */
175             } /* if */
176             } /* if */
177 2           i+=2;
178 2           ii+=2;
179             } /* if */
180             else
181 2           i++;
182             } /* while */
183              
184 3 100         if (n>3) {
185             do {
186 1           i=im=ii;
187 1           max=AA[im][im];
188             do {
189 1           i++;
190 1 50         if (AA[i][i]>max) {
191 0           im=i;
192 0           max=AA[i][i];
193             } /* if */
194 1 50         } while (i
195 1 50         if (im>ii) {
196 0           x=AA[ii][ii];
197 0           u=nr[ii];
198 0           AA[ii][ii]=max;
199 0           nr[ii]=nr[im];
200 0           AA[im][im]=x;
201 0           nr[im]=u;
202             } /* if */
203 1           ii++;
204 1 50         } while (ii
205             } /* if */
206 11 100         for(i=0; i
207 8 50         if (colon==1)
208 8           P[nr[i]][i]=1.0;
209             else
210 0           P[i][nr[i]]=1.0;
211             } /* for i */
212              
213 3           MatrixFree(n, AA);
214 3           IntVectorFree(n, nr);
215 3           } /* Permutation */
216              
217              
218 3           void Swap(int n, double **A, double **B, double epsx) {
219              
220             double **PR, **PS;
221             double **temp;
222              
223 3           PR=MatrixAlloc(n);
224 3           PS=MatrixAlloc(n);
225 3           temp=MatrixAlloc(n);
226              
227 3           Permutation(n, PS, A, B, 1, epsx);
228 3           MatrixMul(n, temp, B, PS);
229 3           MatrixCopy(n, B, temp);
230 3           Transpose(n, PR, PS);
231 3           MatrixMul(n, temp, PR, A);
232 3           MatrixCopy(n, A, temp);
233 3           MatrixMul(n, temp, A, PS);
234 3           MatrixCopy(n, A, temp);
235              
236 3           MatrixFree(n, PR);
237 3           MatrixFree(n, PS);
238 3           MatrixFree(n, temp);
239 3           } /* Swap */
240              
241 4           void Balance(int n, int b, double **a, int *low, int *hi, double *d) {
242              
243             int i, j, k, l;
244             double b2, c, f, g, r, s;
245             int noconv;
246              
247 4           b2=b*b;
248 4           l=0;
249 4           k=n-1;
250              
251 6           L110:
252 19 100         for(j=k; j>=0; j--) {
253 15           r=0.0;
254 30 100         for(i=0; i
255 15           r+=fabs(a[j][i]);
256 27 100         for(i=j+1; i
257 12           r+=fabs(a[j][i]);
258 15 100         if (r==0.0) {
259 2           d[k]=(double)(j+1);
260 2 50         if (j!=k) {
261 9 100         for(i=0; i
262 7           f=a[i][j];
263 7           a[i][j]=a[i][k];
264 7           a[i][k]=f;
265             }
266 10 100         for(i=l; i
267 8           f=a[j][i];
268 8           a[j][i]=a[k][i];
269 8           a[k][i]=f;
270             }
271             }
272 2           k--;
273 2           goto L110;
274             } /* if */
275             } /* for j */
276              
277 4           L120:
278 13 100         for(j=l; j<=k; j++) {
279 9           c=0.0;
280 24 100         for (i=l; i<=j; i++)
281 15           c+=fabs(a[i][j]);
282 15 100         for(i=(j+1); i<=k; i++)
283 6           c+=fabs(a[i][j]);
284 9 50         if (c==0.0) {
285 0           d[l]=(double)(j+1);
286 0 0         if (j!=l) {
287 0 0         for(i=0; i<=k; i++) {
288 0           f=a[i][j];
289 0           a[i][j]=a[i][l];
290 0           a[i][l]=f;
291             }
292 0 0         for(i=l; i
293 0           f=a[j][i];
294 0           a[j][i]=a[l][i];
295 0           a[l][i]=f;
296             }
297             }
298 0           l++;
299 0           goto L120;
300             } /* if */
301             } /* for j */
302              
303 4           *low=l;
304 4           *hi=k;
305 13 100         for(i=l; i<=k; i++)
306 9           d[i]=1.0;
307              
308 4           L130:
309 5           noconv=0;
310 17 100         for(i=l; i<=k; i++) {
311 12           r=c=0.0;
312 21 100         for(j=l; j
313 9           c+=fabs(a[j][i]);
314 9           r+=fabs(a[i][j]);
315             } /* for j */
316 21 100         for(j=i+1; j<=k; j++) {
317 9           c+=fabs(a[j][i]);
318 9           r+=fabs(a[i][j]);
319             } /* for j */
320 12           g=r/((double) b);
321 12           f=1.0;
322 12           s=c+r;
323              
324 13           L140:
325 13 100         if (c
326 1           f*=(double) b;
327 1           c*=(double) b2;
328 1           goto L140;
329             } /* if */
330 12           g=r*((double) b);
331              
332 12           L150:
333 12 50         if (c>=g) {
334 0           f/=(double) b;
335 0           c/=(double) b2;
336 0           goto L150;
337             } /* if */
338              
339 12 100         if ((c+r)/f<(0.95*s)) {
340 1           g=1.0/f;
341 1           d[i]*=f;
342 1           noconv=1;
343 4 100         for(j=l; j
344 3           a[i][j]*=g;
345 4 100         for(j=0; j<=k; j++)
346 3           a[j][i]*=f;
347             } /* if */
348             } /* for i */
349 5 100         if (noconv==1)
350 1           goto L130;
351 4           } /* Balance */
352              
353 3           void BalBak(int n, int low, int hi, int m, double **z, double *d) {
354              
355             int i, j, k;
356             double s;
357              
358 9 100         for(i=low; i
359 6           s=d[i];
360 22 100         for(j=0; j
361 16           z[i][j]*=s;
362             } /* for i */
363 3 50         for(i=low-1; i>=0; i--) {
364 0           k=(int)floor(d[i]+0.5)-1;
365 0 0         if (k!=i)
366 0 0         for(j=0; j
367 0           s=z[i][j];
368 0           z[i][j]=z[k][j];
369 0           z[k][j]=s;
370             } /* for j */
371             } /* for i */
372 5 100         for(i=hi+1; i
373 2           k=(int)floor(d[i]+0.5)-1;
374 2 50         if (k!=i)
375 10 100         for(j=0; j
376 8           s=z[i][j];
377 8           z[i][j]=z[k][j];
378 8           z[k][j]=s;
379             } /* for j */
380             } /* for i */
381 3           } /* BalBak */
382              
383 4           void Elmhes(int n, int k, int l, double **a, int *index) {
384              
385             int i, j, la, m;
386             double x, y;
387              
388 4           la=l;
389 5 100         for(m=k+1; m
390 1           i=m;
391 1           x=0.0;
392 3 100         for(j=m; j
393 2 100         if (fabs(a[j][m-1])>fabs(x)) {
394 1           x=a[j][m-1];
395 1           i=j-1;
396             } /* if */
397 1           index[m]=i+1;
398 1 50         if (i!=m) {
399 4 100         for(j=m-1; j
400 3           y=a[i][j];
401 3           a[i][j]=a[m][j];
402 3           a[m][j]=y;
403             } /* for j */
404 4 100         for(j=0; j
405 3           y=a[j][i];
406 3           a[j][i]=a[j][m];
407 3           a[j][m]=y;
408             } /* for j */
409             } /* if */
410 1 50         if (x!=0.0)
411 2 100         for(i=(m+1); i
412 1           y=a[i][m-1];
413 1 50         if (y!=0.0) {
414 1           a[i][m-1]=y/x;
415 1           y/=x;
416 3 100         for(j=m; j
417 2           a[i][j]-=y*a[m][j];
418 4 100         for(j=0; j
419 3           a[j][m]+=y*a[j][i];
420             } /* if */
421             } /* for i */
422             } /* for m */
423 4           } /* Elmhes */
424              
425 4           void Elmtrans(int n, int low, int upp, double **h, int *index,
426             double **v) {
427              
428             int i, j, k;
429              
430 15 100         for(i=0; i
431 44 100         for(j=0; j
432 33           v[i][j]=0.0;
433 11           v[i][i]=1.0;
434             } /* for i */
435 5 100         for(i=(upp-1); i>=low+1; i--) {
436 1           j=index[i]-1;
437 2 100         for(k=(i+1); k
438 1           v[k][i]=h[k][i-1];
439 1 50         if (i!=j) {
440 3 100         for(k=i; k
441 2           v[i][k]=v[j][k];
442 2           v[j][k]=0.0;
443             } /* for k */
444 1           v[j][i]=1.0;
445             } /* if */
446             } /* for i */
447 4           } /* Elmtrans */
448              
449              
450 4           void hqr2(int n, int low, int upp, int maxits, double macheps,
451             double **h, double **vecs, double *wr,
452             double *wi, int *cnt, int *fail) {
453              
454             int i, j, k, l, m, na, its, en;
455 4           double p = 0, q = 0, r = 0, s = 0, t, w, x, y, z = 0, ra, sa, vr, vi, norm;
456             int notlast;
457             complex double c1, c2, c3;
458              
459 4           *fail=0;
460 4 50         for(i=0; i
461 0           wr[i]=h[i][i];
462 0           wi[i]=0.0;
463 0           cnt[i]=0;
464             } /* for i */
465 6 100         for(i=upp+1; i
466 2           wr[i]=h[i][i];
467 2           wi[i]=0.0;
468 2           cnt[i]=0;
469             } /* for i */
470 4           en=upp;
471 4           t=0.0;
472              
473 3           L210:
474 7 100         if (en
475 3           goto L260;
476 4           its=0;
477 4           na=en-1;
478              
479 64           L220:
480 189 100         for(l=en; l>=low+1; l--)
481 125           if (fabs(h[l][l-1])<=
482 125 50         macheps*(fabs(h[l-1][l-1])+fabs(h[l][l])))
483 0           goto L231;
484 64           l=low+1;
485              
486 64           L231:
487 64           x=h[en][en];
488 64 50         if (l==en+1)
489 0           goto L240;
490 64           y=h[na][na];
491 64           w=h[en][na]*h[na][en];
492 64 100         if (l==na+1)
493 3           goto L250;
494 61 100         if (its==maxits) {
495 1           cnt[en]=maxits+1;
496 1           *fail=1;
497 1           goto L270;
498             } /* if */
499 60 100         if ((its % 10)==0) {
500 6           t+=x;
501 24 100         for(i=low; i
502 18           h[i][i]-=x;
503 6           s=fabs(h[en][na])+fabs(h[na][en-2]);
504 6           y=0.75*s;
505 6           x=y;
506 6           w=-0.4375*s*s;
507             } /* if */
508 60           its++;
509              
510 60 50         for(m=(en-2); m>=l-1; m--) {
511 60           z=h[m][m];
512 60           r=x-z;
513 60           s=y-z;
514 60           p=(r*s-w)/h[m+1][m]+h[m][m+1];
515 60           q=h[m+1][m+1]-z-r-s;
516 60           r=h[m+2][m+1];
517 60           s=fabs(p)+fabs(q)+fabs(r);
518 60           p/=s;
519 60           q/=s;
520 60           r/=s;
521 60 50         if (m==0)
522 60           goto L232;
523 0           if ((fabs(h[m][m-1])*(fabs(q)+fabs(r)))<=
524 0 0         (macheps*fabs(p)*(fabs(h[m-1][m-1])+fabs(z)+fabs(h[m+1][m+1]))))
525 0           goto L232;
526             } /* for m */
527              
528 0           L232:
529 120 100         for(i=m+2; i
530 60           h[i][i-2]=0.0;
531 60 50         for(i=(m+3); i
532 0           h[i][i-3]=0.0;
533              
534 180 100         for(k=m; k
535 120 100         if (k!=na)
536 60           notlast=1;
537             else
538 60           notlast=0;
539 120 100         if (k!=m) {
540 60           p=h[k][k-1];
541 60           q=h[k+1][k-1];
542 60 50         if (notlast==1)
543 0           r=h[k+2][k-1];
544             else
545 60           r=0.0;
546 60           x=fabs(p)+fabs(q)+fabs(r);
547 60 50         if (x==0.0)
548 0           goto L233;
549 60           p/=x;
550 60           q/=x;
551 60           r/=x;
552             } /* if */
553 120           s=sqrt(p*p+q*q+r*r);
554 120 100         if (p<0)
555 60           s=-s;
556 120 100         if (k+1!=m+1)
557 60           h[k][k-1]=-s*x;
558             else
559 60 50         if (l!=m+1)
560 0           h[k][k-1]=-h[k][k-1];
561 120           p+=s;
562 120           x=p/s;
563 120           y=q/s;
564 120           z=r/s;
565 120           q/=p;
566 120           r/=p;
567              
568 420 100         for(j=k; j
569 300           p=h[k][j]+q*h[k+1][j];
570 300 100         if (notlast==1) {
571 180           p+=r*h[k+2][j];
572 180           h[k+1][j]-=p*z;
573             } /* if */
574 300           h[k+1][j]-=p*y;
575 300           h[k][j]-=p*x;
576             } /* for j */
577 120 50         if ((k+4)
578 0           j=k+4;
579             else
580 120           j=en+1;
581              
582 480 100         for(i=0; i
583 360           p=x*h[i][k]+y*h[i][k+1];
584 360 100         if (notlast==1) {
585 180           p+=z*h[i][k+2];
586 180           h[i][k+2]-=p*r;
587             } /* if */
588 360           h[i][k+1]-=p*q;
589 360           h[i][k]-=p;
590             } /* for i */
591              
592 480 100         for(i=low; i
593 360           p=x*vecs[i][k]+y*vecs[i][k+1];
594 360 100         if (notlast==1) {
595 180           p+=z*vecs[i][k+2];
596 180           vecs[i][k+2]-=p*r;
597             } /* if */
598 360           vecs[i][k+1]-=p*q;
599 360           vecs[i][k]-=p;
600             } /* for i */
601              
602 120           L233:;
603             } /* for k */
604 60           goto L220;
605              
606 0           L240:
607 0           h[en][en]=x+t;
608 0           wr[en]=h[en][en];
609 0           wi[en]=0.0;
610 0           cnt[en]=its;
611 0           en=na;
612 0           goto L210;
613              
614 3           L250:
615 3           p=0.5*(y-x);
616 3           q=p*p+w;
617 3           z=sqrt(fabs(q));
618 3           h[en][en]=x+t;
619 3           x=h[en][en];
620 3           h[na][na]=y+t;
621 3           cnt[en]=-its;
622 3           cnt[na]=its;
623 3 100         if (q>0.0) {
624 1 50         if (p<0.0)
625 0           z=p-z;
626             else
627 1           z+=p;
628 1           wr[na]=x+z;
629 1           s=x-w/z;
630 1           wr[en]=s;
631 1           wi[na]=0.0;
632 1           wi[en]=0.0;
633 1           x=h[en][na];
634 1           r=sqrt(x*x+z*z);
635 1           p=x/r;
636 1           q=z/r;
637 3 100         for(j=na; j
638 2           z=h[na][j];
639 2           h[na][j]=q*z+p*h[en][j];
640              
641             /* h[en][j]=q*h[en][j]-p*z */
642 2           h[en][j]*=q;
643 2           h[en][j]-=p*z;
644             } /* for j */
645 3 100         for(i=0; i
646 2           z=h[i][na];
647 2           h[i][na]=q*z+p*h[i][en];
648              
649             /* h[i][en]=q*h[i][en]-p*z */
650 2           h[i][en]*=q;
651 2           h[i][en]-=p*z;
652             } /* for i */
653 3 100         for(i=low; i
654 2           z=vecs[i][na];
655 2           vecs[i][na]=q*z+p*vecs[i][en];
656              
657             /* vecs[i][en]=q*vecs[i][en]-p*z */
658 2           vecs[i][en]*=q;
659 2           vecs[i][en]-=p*z;
660             } /* for i */
661             } /* if */
662             else {
663 2           wr[na]=x+p;
664 2           wr[en]=x+p;
665 2           wi[na]=z;
666 2           wi[en]=-z;
667             } /* else */
668 3           en-=2;
669 3           goto L210;
670              
671 3           L260:
672 3           norm=0.0;
673 3           k=0;
674 11 100         for(i=0; i
675 29 100         for(j=k; j
676 21           norm+=fabs(h[i][j]);
677 8           k=i;
678             } /* for i */
679              
680 11 100         for(en=n-1; en>=0; en--) {
681 8           p=wr[en];
682 8           q=wi[en];
683 8           na=en-1;
684 8 100         if (q==0.0) {
685 4           m=en;
686 4           h[en][en]=1.0;
687 10 100         for(i=na; i>=0; i--) {
688 6           w=h[i][i]-p;
689 6           r=h[i][en];
690 8 100         for(j=m; j
691 2           r+=h[i][j]*h[j][en];
692 6 100         if (wi[i]<0.0) {
693 2           z=w;
694 2           s=r;
695             } /* if */
696             else {
697 4           m=i;
698 4 100         if (wi[i]==0.0) {
699 2 100         if (w!=0.0)
700 1           h[i][en]=-r/w;
701             else
702 1           h[i][en]=-r/macheps/norm;
703             } else {
704 2           x=h[i][i+1];
705 2           y=h[i+1][i];
706 2           q=pow(wr[i]-p, 2.0)+wi[i]*wi[i];
707 2           t=(x*s-z*r)/q;
708 2           h[i][en]=t;
709 2 50         if (fabs(x)>fabs(z))
710 0           h[i+1][en]=(-r-w*t)/x;
711             else
712 2           h[i+1][en]=(-s-y*t)/z;
713             } /* else */
714             } /* else */
715             } /* i */
716             } else
717 4 100         if (q<0.0) {
718 2           m=na;
719 2 50         if (fabs(h[en][na])>fabs(h[na][en])) {
720 0           h[na][na]=-(h[en][en]-p)/h[en][na];
721 0           h[na][en]=-q/h[en][na];
722             } /* if */
723             else {
724 2           c1 = -h[na][en];
725 2           c2 = h[na][na]-p + I * q;
726 2           c3 = c1 / c2;
727 2           h[na][na]=creal(c3);
728 2           h[na][en]=cimag(c3);
729             } /* else */
730 2           h[en][na]=1.0;
731 2           h[en][en]=0.0;
732 2 50         for(i=na-1; i>=0; i--) {
733 0           w=h[i][i]-p;
734 0           ra=h[i][en];
735 0           sa=0.0;
736 0 0         for(j=m; j
737 0           ra+=h[i][j]*h[j][na];
738 0           sa+=h[i][j]*h[j][en];
739             } /* for j */
740 0 0         if (wi[i]<0.0) {
741 0           z=w;
742 0           r=ra;
743 0           s=sa;
744             } /* if */
745             else {
746 0           m=i;
747 0 0         if (wi[i]==0.0) {
748 0           c1 = -ra + I * -sa;
749 0           c2 = w + I * q;
750 0           c3 = c1 / c2;
751 0           h[i][na]=creal(c3);
752 0           h[i][en]=cimag(c3);
753             } /* if */
754             else {
755 0           x=h[i][i+1];
756 0           y=h[i+1][i];
757 0           vr=pow(wr[i]-p, 2.0)+wi[i]*wi[i]-q*q;
758 0           vi=(wr[i]-p)*2.0*q;
759 0 0         if ((vr==0.0) && (vi==0.0))
    0          
760 0           vr=macheps*norm*(fabs(w)+fabs(q)+fabs(x)+fabs(y)+fabs(z));
761 0           c1 = x*r-z*ra+q*sa + I * x*s-z*sa-q*ra;
762 0           c2 = vr + I * vi;
763 0           c3 = c1 / c2;
764 0           h[i][na]=creal(c3);
765 0           h[i][en]=cimag(c3);
766 0 0         if (fabs(x)>(fabs(z)+fabs(q))) {
767 0           h[i+1][na]=(-ra-w*h[i][na]+q*h[i][en])/x;
768 0           h[i+1][en]=(-sa-w*h[i][en]-q*h[i][na])/x;
769             } /* if */
770             else {
771 0           c1 = -r-y*h[i][na] + I * -s-y*h[i][en];
772 0           c2 = z + I * q;
773 0           c3 = c1 / c2;
774 0           h[i+1][na]=creal(c3);
775 0           h[i+1][en]=cimag(c3);
776             } /* else */
777             } /* else */
778             } /* else */
779             } /* for i */
780             } /* if */
781             } /* for en */
782              
783 3 50         for(i=0; i
784 0 0         for(j=i+1; j
785 0           vecs[i][j]=h[i][j];
786 5 100         for(i=upp+1; i
787 7 100         for(j=i-1; j
788 5           vecs[i][j]=h[i][j];
789              
790 11 100         for(j=n-1; j>=low; j--) {
791 8 100         if (j<=upp)
792 6           m=j+1;
793             else
794 2           m=upp+1;
795 8           l=j-1;
796 8 100         if (wi[j]<0.0) {
797 6 100         for(i=low; i
798 4           y=z=0.0;
799 12 100         for(k=low; k
800 8           y+=vecs[i][k]*h[k][l];
801 8           z+=vecs[i][k]*h[k][j];
802             } /* for k */
803 4           vecs[i][l]=y;
804 4           vecs[i][j]=z;
805             } /* for i */
806             } /* if */
807             else
808 6 100         if (wi[j]==0.0)
809 12 100         for(i=low; i
810 8           z=0.0;
811 22 100         for(k=low; k
812 14           z+=vecs[i][k]*h[k][j];
813 8           vecs[i][j]=z;
814             } /* for i */
815             } /* for j */
816              
817 3           L270:;
818 4           } /* hqr2 */
819              
820 4           char *Eigen(int n, double *AJAC, int maxit, double eps,
821             complex double *values, complex double *vectors) {
822              
823             double *wr, *wi, *bald, **T, **A;
824             int i, j, ballow, balhi, block;
825             int *intout;
826             int fail;
827              
828 4           intout=IntVectorAlloc(n);
829 4           wr=VectorAlloc(n);
830 4           wi=VectorAlloc(n);
831 4           bald=VectorAlloc(n);
832 4           T=MatrixAlloc(n);
833 4           A=MatrixAlloc(n);
834              
835 15 100         for(i=0; i
836 44 100         for(j=0; j
837 33           A[i][j]=AJAC[i*n + j];
838              
839 4           Balance(n, 10, A, &ballow, &balhi, bald);
840 4           Elmhes(n, ballow, balhi, A, intout);
841 4           Elmtrans(n, ballow, balhi, A, intout, T);
842              
843 4           hqr2(n, ballow, balhi, maxit, eps, A, T, wr, wi, intout, &fail);
844 4 100         if (fail==1)
845 1           return "Failure in hqr2 function";
846 11 100         for(i=0; i
847 32 100         for(j=0; j
848 24           A[i][j]=0.0;
849 3           i=0;
850             do {
851 4 100         if (wi[i]!=0.0) {
852 2           A[i][i]=wr[i];
853 2           A[i+1][i+1]=wr[i];
854 2           A[i][i+1]=wi[i];
855 2           A[i+1][i]=wi[i+1];
856 2           i+=2;
857             } /* if */
858             else {
859 2           A[i][i]=wr[i];
860 2           i++;
861             } /* else */
862 4 100         } while (i
863 3 100         if (i==n-1)
864 2           A[i][i]=wr[i];
865              
866 3           Swap(n, A, T, eps);
867 3           BalBak(n, ballow, balhi, n, T, bald);
868 3           NormalizingMatrix(n, A, T, eps);
869              
870             /* store eigenvectors and eigenvalues nicely */
871 3           i=0; /* eigenvalues */
872             do {
873 6           BlockCheck(A, n, i, &block, eps);
874 6 100         if (block==1) {
875 2           values[i] = A[i][i] + I * A[i][i+1];
876 2           values[i+1] = A[i+1][i+1] + I * A[i+1][i];
877 2           i+=2;
878             } else {
879 4           values[i] = A[i][i] + I * 0.0;
880 4           i++;
881             } /* if else */
882 6 100         } while (i!=n);
883 3           i=0; /* eigenvectors */
884             do {
885 6           BlockCheck(A, n, i, &block, eps);
886 6 100         if (block==1) {
887 8 100         for(j=0; j
888 6           vectors[j*n + i] = T[j][i] + I * T[j][i+1];
889 8 100         for(j=0; j
890 6           vectors[j*n + i+1] = T[j][i] - I * T[j][i+1];
891 2           i+=2;
892             } else {
893 16 100         for(j=0; j
894 12           vectors[j*n + i] = T[j][i];
895 4           i++;
896             } /* if else */
897 6 100         } while (i!=n);
898              
899 3           VectorFree(n, wi);
900 3           VectorFree(n, wr);
901 3           VectorFree(n, bald);
902 3           IntVectorFree(n, intout);
903 3           MatrixFree(n, A);
904 3           MatrixFree(n, T);
905 3           return NULL;
906             } /* Eigen */