This is lpc.roottest.c in view mode; [Download] [Up]
/* lpc.roottest.f -- translated by f2c (version of 26 January 1990 18:57:16).
You must link the resulting object file with the libraries:
-lF77 -lI77 -lm -lc (in that order)
*/
#include <f2c.h>
/* Table of constant values */
static integer c__1 = 1;
/* Subroutine */ int rootst_(anal, unstab, npoles, ifirst, ilast, anal_len,
unstab_len)
char *anal, *unstab;
integer *npoles, *ifirst, *ilast;
ftnlen anal_len;
ftnlen unstab_len;
{
/* Format strings */
static char fmt_145[] = "(a20,x,a20,x,i4,x,i4,x,i4)";
/* System generated locals */
integer i_1, i_2, i_3;
olist o_1;
/* Builtin functions */
integer s_wsfe(), do_fio(), e_wsfe(), f_open(), s_rdue(), do_uio(),
e_rdue(), s_wdue(), e_wdue();
/* Local variables */
static integer nbad;
static logical flag_;
static integer nall;
static real a[40];
static integer j, ndata;
static real y[36];
static integer nlocs, ii, jx;
extern /* Subroutine */ int stable_();
/* Fortran I/O blocks */
static cilist io__4 = { 0, 6, 0, fmt_145, 0 };
static cilist io__7 = { 0, 18, 1, 0, 0 };
static cilist io__13 = { 0, 19, 0, 0, 0 };
ndata = 4;
nlocs = *npoles + ndata << 2;
nall = *npoles + ndata;
/* L145: */
s_wsfe(&io__4);
do_fio(&c__1, anal, 64L);
do_fio(&c__1, unstab, 64L);
do_fio(&c__1, (char *)&(*npoles), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*ifirst), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*ilast), (ftnlen)sizeof(integer));
e_wsfe();
o_1.oerr = 0;
o_1.ounit = 18;
o_1.ofnmlen = 64;
o_1.ofnm = anal;
o_1.orl = nlocs;
o_1.osta = "old";
o_1.oacc = "direct";
o_1.ofm = "unformatted";
o_1.oblnk = 0;
f_open(&o_1);
o_1.oerr = 0;
o_1.ounit = 19;
o_1.ofnmlen = 64;
o_1.ofnm = unstab;
o_1.orl = 4;
o_1.osta = "old";
o_1.oacc = "direct";
o_1.ofm = "unformatted";
o_1.oblnk = 0;
f_open(&o_1);
nbad = 1;
i_1 = *ilast;
for (j = *ifirst; j <= i_1; ++j) {
io__7.cirec = j;
i_2 = s_rdue(&io__7);
if (i_2 != 0) {
goto L999;
}
i_3 = nall;
for (jx = 1; jx <= i_3; ++jx) {
i_2 = do_uio(&c__1, (char *)&a[jx - 1], (ftnlen)sizeof(real));
if (i_2 != 0) {
goto L999;
}
}
i_2 = e_rdue();
i_2 = *npoles;
for (ii = 1; ii <= i_2; ++ii) {
y[ii - 1] = -(doublereal)a[nall + 1 - ii - 1];
/* L1601: */
}
stable_(y, npoles, &flag_);
if (flag_) {
goto L1000;
}
io__13.cirec = nbad;
s_wdue(&io__13);
do_uio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
e_wdue();
++nbad;
L1000:
;}
L999:
return 0;
} /* rootst_ */
/* Subroutine */ int stable_(frame, n, flag_)
real *frame;
integer *n;
logical *flag_;
{
/* System generated locals */
integer i_1, i_2;
real r_1;
/* Local variables */
static real a[2500] /* was [50][50] */;
static integer i, m, mm;
static real rk[49];
/* Parameter adjustments */
--frame;
/* Function Body */
*flag_ = TRUE_;
a[(*n + 1) * 50 - 50] = (float)1.;
i_1 = *n;
for (i = 1; i <= i_1; ++i) {
/* L10: */
a[i + 1 + (*n + 1) * 50 - 51] = frame[i];
}
i_1 = *n;
for (mm = 1; mm <= i_1; ++mm) {
m = *n - mm + 1;
rk[m - 1] = a[m + 1 + (m + 1) * 50 - 51];
if ((r_1 = rk[m - 1], dabs(r_1)) < (float)1.) {
goto L20;
}
*flag_ = FALSE_;
return 0;
L20:
i_2 = m;
for (i = 1; i <= i_2; ++i) {
/* L25: */
/* Computing 2nd power */
r_1 = rk[m - 1];
a[i + m * 50 - 51] = (a[i + (m + 1) * 50 - 51] - rk[m - 1] * a[m
- i + 2 + (m + 1) * 50 - 51]) / ((float)1. - r_1 * r_1);
}
}
return 0;
} /* stable_ */
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.