This is roottest.c in view mode; [Download] [Up]
/* 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;
/* Main program */ MAIN__()
{
/* Format strings */
static char fmt_110[] = "(\002 Enter name of file containing analysis da\
ta.\002)";
static char fmt_11[] = "(a16)";
static char fmt_112[] = "(\002 Enter name of file containing list of uns\
table frames.\002)";
static char fmt_113[] = "(\002 Enter number of poles (max is 36).\002)";
static char fmt_114[] = "(i2)";
static char fmt_115[] = "(\002 Enter first and last frames to test (2i6 \
ugh fortran)\002)";
static char fmt_116[] = "(2i6)";
static char fmt_117[] = "(\002 testing frames\002,i6,\002 to\002,i6)";
static char fmt_900[] = "(\002 got here\002)";
static char fmt_901[] = "(3i8)";
static char fmt_100[] = "(\002 frame \002,i5,\002 is unstable \002)";
/* System generated locals */
integer i_1, i_2, i_3;
olist o_1;
/* Builtin functions */
integer s_wsfe(), e_wsfe(), s_rsfe(), do_fio(), e_rsfe(), f_open(),
s_rdue(), do_uio(), e_rdue(), s_wdue(), e_wdue();
/* Subroutine */ int s_stop();
/* Local variables */
static integer nbad;
static logical flag_;
static char anal[16];
static integer nall;
static real a[140];
static integer j, ndata;
static real y[136];
static integer ilast, nlocs, ii, jx;
extern /* Subroutine */ int stable_();
static char unstab[16];
static integer npoles, ifirst;
/* Fortran I/O blocks */
static cilist io__1 = { 0, 6, 0, fmt_110, 0 };
static cilist io__2 = { 0, 5, 0, fmt_11, 0 };
static cilist io__4 = { 0, 6, 0, fmt_112, 0 };
static cilist io__5 = { 0, 5, 0, fmt_11, 0 };
static cilist io__7 = { 0, 6, 0, fmt_113, 0 };
static cilist io__8 = { 0, 5, 0, fmt_114, 0 };
static cilist io__10 = { 0, 6, 0, fmt_115, 0 };
static cilist io__11 = { 0, 5, 0, fmt_116, 0 };
static cilist io__14 = { 0, 6, 0, fmt_117, 0 };
static cilist io__18 = { 0, 6, 0, fmt_900, 0 };
static cilist io__21 = { 0, 6, 0, fmt_901, 0 };
static cilist io__22 = { 0, 18, 1, 0, 0 };
static cilist io__25 = { 0, 6, 0, fmt_900, 0 };
static cilist io__29 = { 0, 6, 0, fmt_100, 0 };
static cilist io__30 = { 0, 19, 0, 0, 0 };
s_wsfe(&io__1);
e_wsfe();
s_rsfe(&io__2);
do_fio(&c__1, anal, 16L);
e_rsfe();
s_wsfe(&io__4);
e_wsfe();
s_rsfe(&io__5);
do_fio(&c__1, unstab, 16L);
e_rsfe();
s_wsfe(&io__7);
e_wsfe();
s_rsfe(&io__8);
do_fio(&c__1, (char *)&npoles, (ftnlen)sizeof(integer));
e_rsfe();
s_wsfe(&io__10);
e_wsfe();
s_rsfe(&io__11);
do_fio(&c__1, (char *)&ifirst, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ilast, (ftnlen)sizeof(integer));
e_rsfe();
s_wsfe(&io__14);
do_fio(&c__1, (char *)&ifirst, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ilast, (ftnlen)sizeof(integer));
e_wsfe();
ndata = 4;
nlocs = npoles + ndata << 2;
nall = npoles + ndata;
o_1.oerr = 0;
o_1.ounit = 18;
o_1.ofnmlen = 16;
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);
s_wsfe(&io__18);
e_wsfe();
o_1.oerr = 0;
o_1.ounit = 19;
o_1.ofnmlen = 16;
o_1.ofnm = unstab;
o_1.orl = 4;
o_1.osta = "new";
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) {
s_wsfe(&io__21);
do_fio(&c__1, (char *)&ifirst, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ilast, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
e_wsfe();
io__22.cirec = j;
i_2 = s_rdue(&io__22);
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();
s_wsfe(&io__25);
e_wsfe();
i_2 = npoles;
for (ii = 1; ii <= i_2; ++ii) {
y[ii - 1] = -(doublereal)a[nall + 1 - ii - 1];
/* print*, ii,y(ii) */
/* L1601: */
}
stable_(y, &npoles, &flag_);
if (flag_) {
goto L1000;
}
s_wsfe(&io__29);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
e_wsfe();
io__30.cirec = nbad;
s_wdue(&io__30);
do_uio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
e_wdue();
++nbad;
L1000:
;}
L999:
s_stop("", 0L);
} /* MAIN__ */
/* 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[22500] /* was [150][150] */;
static integer i, m, mm;
static real rk[149];
/* Parameter adjustments */
--frame;
/* Function Body */
*flag_ = TRUE_;
a[(*n + 1) * 150 - 150] = (float)1.;
i_1 = *n;
for (i = 1; i <= i_1; ++i) {
/* L10: */
a[i + 1 + (*n + 1) * 150 - 151] = frame[i];
}
i_1 = *n;
for (mm = 1; mm <= i_1; ++mm) {
m = *n - mm + 1;
rk[m - 1] = a[m + 1 + (m + 1) * 150 - 151];
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 * 150 - 151] = (a[i + (m + 1) * 150 - 151] - rk[m - 1] *
a[m - i + 2 + (m + 1) * 150 - 151]) / ((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.