00001 /* figi.f -- translated by f2c (version 19961017).
00002    You must link the resulting object file with the libraries:
00003         -lf2c -lm   (in that order)
00004 */
00005 
00006 #include "f2c.h"
00007 
00008 /* Subroutine */ int figi_(integer *nm, integer *n, doublereal *t, doublereal 
00009         *d__, doublereal *e, doublereal *e2, integer *ierr)
00010 {
00011     /* System generated locals */
00012     integer t_dim1, t_offset, i__1;
00013     doublereal d__1;
00014 
00015     /* Builtin functions */
00016     double sqrt(doublereal);
00017 
00018     /* Local variables */
00019     static integer i__;
00020 
00021 
00022 
00023 /*     GIVEN A NONSYMMETRIC TRIDIAGONAL MATRIX SUCH THAT THE PRODUCTS */
00024 /*     OF CORRESPONDING PAIRS OF OFF-DIAGONAL ELEMENTS ARE ALL */
00025 /*     NON-NEGATIVE, THIS SUBROUTINE REDUCES IT TO A SYMMETRIC */
00026 /*     TRIDIAGONAL MATRIX WITH THE SAME EIGENVALUES.  IF, FURTHER, */
00027 /*     A ZERO PRODUCT ONLY OCCURS WHEN BOTH FACTORS ARE ZERO, */
00028 /*     THE REDUCED MATRIX IS SIMILAR TO THE ORIGINAL MATRIX. */
00029 
00030 /*     ON INPUT */
00031 
00032 /*        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00033 /*          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00034 /*          DIMENSION STATEMENT. */
00035 
00036 /*        N IS THE ORDER OF THE MATRIX. */
00037 
00038 /*        T CONTAINS THE INPUT MATRIX.  ITS SUBDIAGONAL IS */
00039 /*          STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, */
00040 /*          ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN, */
00041 /*          AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF */
00042 /*          THE THIRD COLUMN.  T(1,1) AND T(N,3) ARE ARBITRARY. */
00043 
00044 /*     ON OUTPUT */
00045 
00046 /*        T IS UNALTERED. */
00047 
00048 /*        D CONTAINS THE DIAGONAL ELEMENTS OF THE SYMMETRIC MATRIX. */
00049 
00050 /*        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC */
00051 /*          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS NOT SET. */
00052 
00053 /*        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
00054 /*          E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. */
00055 
00056 /*        IERR IS SET TO */
00057 /*          ZERO       FOR NORMAL RETURN, */
00058 /*          N+I        IF T(I,1)*T(I-1,3) IS NEGATIVE, */
00059 /*          -(3*N+I)   IF T(I,1)*T(I-1,3) IS ZERO WITH ONE FACTOR */
00060 /*                     NON-ZERO.  IN THIS CASE, THE EIGENVECTORS OF */
00061 /*                     THE SYMMETRIC MATRIX ARE NOT SIMPLY RELATED */
00062 /*                     TO THOSE OF  T  AND SHOULD NOT BE SOUGHT. */
00063 
00064 /*     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00065 /*     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 
00066 */
00067 
00068 /*     THIS VERSION DATED AUGUST 1983. */
00069 
00070 /*     ------------------------------------------------------------------ 
00071 */
00072 
00073     /* Parameter adjustments */
00074     t_dim1 = *nm;
00075     t_offset = t_dim1 + 1;
00076     t -= t_offset;
00077     --e2;
00078     --e;
00079     --d__;
00080 
00081     /* Function Body */
00082     *ierr = 0;
00083 
00084     i__1 = *n;
00085     for (i__ = 1; i__ <= i__1; ++i__) {
00086         if (i__ == 1) {
00087             goto L90;
00088         }
00089         e2[i__] = t[i__ + t_dim1] * t[i__ - 1 + t_dim1 * 3];
00090         if ((d__1 = e2[i__]) < 0.) {
00091             goto L1000;
00092         } else if (d__1 == 0) {
00093             goto L60;
00094         } else {
00095             goto L80;
00096         }
00097 L60:
00098         if (t[i__ + t_dim1] == 0. && t[i__ - 1 + t_dim1 * 3] == 0.) {
00099             goto L80;
00100         }
00101 /*     .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL */
00102 /*                ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO ..........
00103  */
00104         *ierr = -(*n * 3 + i__);
00105 L80:
00106         e[i__] = sqrt(e2[i__]);
00107 L90:
00108         d__[i__] = t[i__ + (t_dim1 << 1)];
00109 /* L100: */
00110     }
00111 
00112     goto L1001;
00113 /*     .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL */
00114 /*                ELEMENTS IS NEGATIVE .......... */
00115 L1000:
00116     *ierr = *n + i__;
00117 L1001:
00118     return 0;
00119 } /* figi_ */
00120