00001 /* figi2.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 figi2_(integer *nm, integer *n, doublereal *t, 
00009         doublereal *d__, doublereal *e, doublereal *z__, integer *ierr)
00010 {
00011     /* System generated locals */
00012     integer t_dim1, t_offset, z_dim1, z_offset, i__1, i__2;
00013 
00014     /* Builtin functions */
00015     double sqrt(doublereal);
00016 
00017     /* Local variables */
00018     static doublereal h__;
00019     static integer i__, j;
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, AND ZERO ONLY WHEN BOTH FACTORS ARE ZERO, THIS */
00026 /*     SUBROUTINE REDUCES IT TO A SYMMETRIC TRIDIAGONAL MATRIX */
00027 /*     USING AND ACCUMULATING DIAGONAL SIMILARITY TRANSFORMATIONS. */
00028 
00029 /*     ON INPUT */
00030 
00031 /*        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00032 /*          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00033 /*          DIMENSION STATEMENT. */
00034 
00035 /*        N IS THE ORDER OF THE MATRIX. */
00036 
00037 /*        T CONTAINS THE INPUT MATRIX.  ITS SUBDIAGONAL IS */
00038 /*          STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, */
00039 /*          ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN, */
00040 /*          AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF */
00041 /*          THE THIRD COLUMN.  T(1,1) AND T(N,3) ARE ARBITRARY. */
00042 
00043 /*     ON OUTPUT */
00044 
00045 /*        T IS UNALTERED. */
00046 
00047 /*        D CONTAINS THE DIAGONAL ELEMENTS OF THE SYMMETRIC MATRIX. */
00048 
00049 /*        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC */
00050 /*          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS NOT SET. */
00051 
00052 /*        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN */
00053 /*          THE REDUCTION. */
00054 
00055 /*        IERR IS SET TO */
00056 /*          ZERO       FOR NORMAL RETURN, */
00057 /*          N+I        IF T(I,1)*T(I-1,3) IS NEGATIVE, */
00058 /*          2*N+I      IF T(I,1)*T(I-1,3) IS ZERO WITH */
00059 /*                     ONE FACTOR NON-ZERO. */
00060 
00061 /*     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00062 /*     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 
00063 */
00064 
00065 /*     THIS VERSION DATED AUGUST 1983. */
00066 
00067 /*     ------------------------------------------------------------------ 
00068 */
00069 
00070     /* Parameter adjustments */
00071     t_dim1 = *nm;
00072     t_offset = t_dim1 + 1;
00073     t -= t_offset;
00074     z_dim1 = *nm;
00075     z_offset = z_dim1 + 1;
00076     z__ -= z_offset;
00077     --e;
00078     --d__;
00079 
00080     /* Function Body */
00081     *ierr = 0;
00082 
00083     i__1 = *n;
00084     for (i__ = 1; i__ <= i__1; ++i__) {
00085 
00086         i__2 = *n;
00087         for (j = 1; j <= i__2; ++j) {
00088 /* L50: */
00089             z__[i__ + j * z_dim1] = 0.;
00090         }
00091 
00092         if (i__ == 1) {
00093             goto L70;
00094         }
00095         h__ = t[i__ + t_dim1] * t[i__ - 1 + t_dim1 * 3];
00096         if (h__ < 0.) {
00097             goto L900;
00098         } else if (h__ == 0) {
00099             goto L60;
00100         } else {
00101             goto L80;
00102         }
00103 L60:
00104         if (t[i__ + t_dim1] != 0. || t[i__ - 1 + t_dim1 * 3] != 0.) {
00105             goto L1000;
00106         }
00107         e[i__] = 0.;
00108 L70:
00109         z__[i__ + i__ * z_dim1] = 1.;
00110         goto L90;
00111 L80:
00112         e[i__] = sqrt(h__);
00113         z__[i__ + i__ * z_dim1] = z__[i__ - 1 + (i__ - 1) * z_dim1] * e[i__] /
00114                  t[i__ - 1 + t_dim1 * 3];
00115 L90:
00116         d__[i__] = t[i__ + (t_dim1 << 1)];
00117 /* L100: */
00118     }
00119 
00120     goto L1001;
00121 /*     .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL */
00122 /*                ELEMENTS IS NEGATIVE .......... */
00123 L900:
00124     *ierr = *n + i__;
00125     goto L1001;
00126 /*     .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL */
00127 /*                ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO .......... */
00128 L1000:
00129     *ierr = (*n << 1) + i__;
00130 L1001:
00131     return 0;
00132 } /* figi2_ */
00133