/* DECK DLGAMS */
/* Subroutine */ int dlgams_(doublereal *x, doublereal *dlgam, doublereal *
sgngam)
{
/* System generated locals */
doublereal d__1;
/* Builtin functions */
double d_int(doublereal *), d_mod(doublereal *, doublereal *);
/* Local variables */
integer int__;
extern doublereal dlngam_(doublereal *);
/* ***BEGIN PROLOGUE DLGAMS */
/* ***PURPOSE Compute the logarithm of the absolute value of the Gamma */
/* function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C7A */
/* ***TYPE DOUBLE PRECISION (ALGAMS-S, DLGAMS-D) */
/* ***KEYWORDS ABSOLUTE VALUE OF THE LOGARITHM OF THE GAMMA FUNCTION, */
/* FNLIB, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* DLGAMS(X,DLGAM,SGNGAM) calculates the double precision natural */
/* logarithm of the absolute value of the Gamma function for */
/* double precision argument X and stores the result in double */
/* precision argument DLGAM. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED DLNGAM */
/* ***REVISION HISTORY (YYMMDD) */
/* 770701 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890531 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* ***END PROLOGUE DLGAMS */
/* ***FIRST EXECUTABLE STATEMENT DLGAMS */
*dlgam = dlngam_(x);
*sgngam = 1.;
if (*x > 0.) {
return 0;
}
d__1 = -d_int(x);
int__ = (integer) (d_mod(&d__1, &c_b2) + .1);
if (int__ == 0) {
*sgngam = -1.;
}
return 0;
} /* dlgams_ */
/* DECK DBETAI */
doublereal dbetai_(doublereal *x, doublereal *pin, doublereal *qin)
{
/* Initialized data */
// static logical first = TRUE_;
/* System generated locals */
integer i__1;
doublereal ret_val, d__1;
/* Builtin functions */
double log(doublereal), d_int(doublereal *), exp(doublereal);
/* Local variables */
doublereal c__;
integer i__, n;
doublereal p, q, y, p1;
integer ib;
doublereal xb, xi, ps;
/* static */ doublereal eps, sml;
doublereal term;
extern doublereal d1mach_(integer *), dlbeta_(doublereal *, doublereal *);
/* static */ doublereal alneps, alnsml;
doublereal finsum;
extern /* Subroutine */ int xermsg_(const char *, const char *, const char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE DBETAI */
/* ***PURPOSE Calculate the incomplete Beta function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C7F */
/* ***TYPE DOUBLE PRECISION (BETAI-S, DBETAI-D) */
/* ***KEYWORDS FNLIB, INCOMPLETE BETA FUNCTION, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* DBETAI calculates the DOUBLE PRECISION incomplete beta function. */
/* The incomplete beta function ratio is the probability that a */
/* random variable from a beta distribution having parameters PIN and */
/* QIN will be less than or equal to X. */
/* -- Input Arguments -- All arguments are DOUBLE PRECISION. */
/* X upper limit of integration. X must be in (0,1) inclusive. */
/* PIN first beta distribution parameter. PIN must be .GT. 0.0. */
/* QIN second beta distribution parameter. QIN must be .GT. 0.0. */
/* ***REFERENCES Nancy E. Bosten and E. L. Battiste, Remark on Algorithm */
/* 179, Communications of the ACM 17, 3 (March 1974), */
/* pp. 156. */
/* ***ROUTINES CALLED D1MACH, DLBETA, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770701 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890911 Removed unnecessary intrinsics. (WRB) */
/* 890911 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 920528 DESCRIPTION and REFERENCES sections revised. (WRB) */
/* ***END PROLOGUE DBETAI */
/* ***FIRST EXECUTABLE STATEMENT DBETAI */
// d1mach has been made thread safe, so there is no need for the
// statics in determining these values
// if (first) {
// eps = d1mach_(&c__3);
// alneps = log(eps);
// sml = d1mach_(&c__1);
// alnsml = log(sml);
// }
// first = FALSE_;
eps = d1mach_(&c__3);
alneps = log(eps);
sml = d1mach_(&c__1);
alnsml = log(sml);
if (*x < 0. || *x > 1.) {
xermsg_("SLATEC", "DBETAI", "X IS NOT IN THE RANGE (0,1)", &c__1, &
c__2, (ftnlen)6, (ftnlen)6, (ftnlen)27);
}
if (*pin <= 0. || *qin <= 0.) {
xermsg_("SLATEC", "DBETAI", "P AND/OR Q IS LE ZERO", &c__2, &c__2, (
ftnlen)6, (ftnlen)6, (ftnlen)21);
}
y = *x;
p = *pin;
q = *qin;
if (q <= p && *x < .8) {
goto L20;
}
if (*x < .2) {
goto L20;
}
y = 1. - y;
p = *qin;
q = *pin;
L20:
if ((p + q) * y / (p + 1.) < eps) {
goto L80;
}
/* EVALUATE THE INFINITE SUM FIRST. TERM WILL EQUAL */
/* Y**P/BETA(PS,P) * (1.-PS)-SUB-I * Y**I / FAC(I) . */
ps = q - d_int(&q);
if (ps == 0.) {
ps = 1.;
}
xb = p * log(y) - dlbeta_(&ps, &p) - log(p);
ret_val = 0.;
if (xb < alnsml) {
goto L40;
}
ret_val = exp(xb);
term = ret_val * p;
if (ps == 1.) {
goto L40;
}
/* Computing MAX */
d__1 = alneps / log(y);
n = (integer) max(d__1,4.);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
xi = (doublereal) i__;
term = term * (xi - ps) * y / xi;
ret_val += term / (p + xi);
/* L30: */
}
/* NOW EVALUATE THE FINITE SUM, MAYBE. */
L40:
if (q <= 1.) {
goto L70;
}
xb = p * log(y) + q * log(1. - y) - dlbeta_(&p, &q) - log(q);
/* Computing MAX */
d__1 = xb / alnsml;
ib = (integer) max(d__1,0.);
term = exp(xb - ib * alnsml);
c__ = 1. / (1. - y);
p1 = q * c__ / (p + q - 1.);
finsum = 0.;
n = (integer) q;
if (q == (doublereal) n) {
--n;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (p1 <= 1. && term / eps <= finsum) {
goto L60;
}
xi = (doublereal) i__;
term = (q - xi + 1.) * c__ * term / (p + q - xi);
if (term > 1.) {
--ib;
}
if (term > 1.) {
term *= sml;
}
if (ib == 0) {
finsum += term;
}
/* L50: */
}
L60:
ret_val += finsum;
L70:
if (y != *x || p != *pin) {
ret_val = 1. - ret_val;
}
/* Computing MAX */
d__1 = min(ret_val,1.);
ret_val = max(d__1,0.);
return ret_val;
L80:
ret_val = 0.;
xb = p * log((max(y,sml))) - log(p) - dlbeta_(&p, &q);
if (xb > alnsml && y != 0.) {
ret_val = exp(xb);
}
if (y != *x || p != *pin) {
ret_val = 1. - ret_val;
}
return ret_val;
} /* dbetai_ */
/* $Procedure ETCAL ( Convert ET to Calendar format ) */
/* Subroutine */ int etcal_(doublereal *et, char *string, ftnlen string_len)
{
/* Initialized data */
static logical first = TRUE_;
static integer extra[12] = { 0,0,1,1,1,1,1,1,1,1,1,1 };
static integer dpjan0[12] = { 0,31,59,90,120,151,181,212,243,273,304,334 }
;
static integer dpbegl[12] = { 0,31,60,91,121,152,182,213,244,274,305,335 }
;
static char months[3*12] = "JAN" "FEB" "MAR" "APR" "MAY" "JUN" "JUL"
"AUG" "SEP" "OCT" "NOV" "DEC";
/* System generated locals */
address a__1[12];
integer i__1, i__2, i__3[12];
doublereal d__1;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
double d_int(doublereal *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
/* Local variables */
static integer dn2000;
static doublereal dp2000, frac;
static char date[180];
static doublereal remd, secs;
static integer year, mins;
static char dstr[16], hstr[16], mstr[16], sstr[16], ystr[16];
static doublereal halfd, q;
static integer tsecs, dofyr, month, hours;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
static doublereal mynum;
static integer bh, bm, iq;
static doublereal secspd;
static char messge[16];
static integer offset;
static doublereal dmnint;
static logical adjust;
static integer daynum;
extern integer intmin_(void), intmax_(void);
extern /* Subroutine */ int dpstrf_(doublereal *, integer *, char *, char
*, ftnlen, ftnlen);
static doublereal dmxint, mydnom;
extern /* Subroutine */ int cmprss_(char *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen);
extern integer lstlti_(integer *, integer *, integer *);
extern /* Subroutine */ int intstr_(integer *, char *, ftnlen);
static integer yr1, yr4;
static char era[16];
static integer day, rem;
extern doublereal spd_(void);
static integer yr100, yr400;
/* $ Abstract */
/* Convert from an ephemeris epoch measured in seconds past */
/* the epoch of J2000 to a calendar string format using a */
/* formal calendar free of leapseconds. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* TIME */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* ET I Ephemeris time measured in seconds past J2000. */
/* STRING O A standard calendar representation of ET. */
/* $ Detailed_Input */
/* ET is an epoch measured in ephemeris seconds */
/* past the epoch of J2000. */
/* $ Detailed_Output */
/* STRING is a calendar string representing the input ephemeris */
/* epoch. This string is based upon extending the */
/* Gregorian Calendar backward and forward indefinitely */
/* keeping the same rules for determining leap years. */
/* Moreover, there is no accounting for leapseconds. */
/* To be sure that all of the date can be stored in */
/* STRING, it should be declared to have length at */
/* least 48 characters. */
/* The string will have the following format */
/* year (era) mon day hr:mn:sc.sss */
/* Where: */
/* year --- is the year */
/* era --- is the chronological era associated with */
/* the date. For years after 999 A.D. */
/* the era is omitted. For years */
/* between 1 A.D. and 999 A.D. (inclusive) */
/* era is the string 'A.D.' For epochs */
/* before 1 A.D. Jan 1 00:00:00, era is */
/* given as 'B.C.' and the year is converted */
/* to years before the "Christian Era". */
/* The last B.C. epoch is */
/* 1 B.C. DEC 31 23:59:59.999 */
/* The first A.D. epoch (which occurs .001 */
/* seconds after the last B.C. epoch) is: */
/* 1 A.D. JAN 1 00:00:00.000 */
/* Note: there is no year 0 A.D. or 0 B.C. */
/* mon --- is a 3-letter abbreviation for the month */
/* in all capital letters. */
/* day --- is the day of the month */
/* hr --- is the hour of the day (between 0 and 23) */
/* leading zeros are added to hr if the */
/* numeric value is less than 10. */
/* mn --- is the minute of the hour (0 to 59) */
/* leading zeros are added to mn if the */
/* numeric value is less than 10. */
/* sc.sss is the second of the minute to 3 decimal */
/* places ( 0 to 59.999). Leading zeros */
/* are added if the numeric value is less */
/* than 10. Seconds are truncated, not */
/* rounded. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* 1) If the input ET is so large that the corresponding */
/* number of days since 1 A.D. Jan 1, 00:00:00 is */
/* within 1 of overflowing or underflowing an integer, */
/* ET will not be converted to the correct string */
/* representation rather, the string returned will */
/* state that the epoch was before or after the day */
/* that is INTMIN +1 or INTMAX - 1 days after */
/* 1 A.D. Jan 1, 00:00:00. */
/* 2) If the output string is not sufficiently long to hold */
/* the full date, it will be truncated on the right. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This is an error free routine for converting ephemeris epochs */
/* represented as seconds past the J2000 epoch to formal */
/* calendar strings based upon the Gregorian Calendar. This formal */
/* time is often useful when one needs a human recognizable */
/* form of an ephemeris epoch. There is no accounting for leap */
/* seconds in the output times produced. */
/* Note: The calendar epochs produced are not the same as the */
/* UTC calendar epochs that correspond to ET. The strings */
/* produced by this routine may vary from the corresponding */
/* UTC epochs by more than 1 minute. */
/* This routine can be used in creating error messages or */
/* in routines and programs in which one prefers to report */
/* times without employing leapseconds to produce exact UTC */
/* epochs. */
/* $ Examples */
/* Suppose you wish to report that no data is */
/* available at a particular ephemeris epoch ET. The following */
/* code shows how you might accomplish this task. */
/* CALL DPSTRF ( ET, 6, 'F', ETSTR ) */
/* CALL ETCAL ( ET, STRING ) */
/* E1 = RTRIM ( STRING ) */
/* E2 = RTRIM ( ETSTR ) */
/* WRITE (*,*) 'There is no data available for the body ' */
/* WRITE (*,*) 'at requested time: ' */
/* WRITE (*,*) ' ', STRING(1:E1), ' (', ETSTR(1:E2), ')' */
/* $ Restrictions */
/* One must keep in mind when using this routine that */
/* ancient times are not based upon the Gregorian */
/* calendar. For example the 0 point of the Julian */
/* Date system is 4713 B.C. Jan 1, 12:00:00 on the Julian */
/* Calendar. If one formalized the Gregorian calendar */
/* and extended it indefinitely, the zero point of the Julian */
/* date system corresponds to 4714 B.C. NOV 24 12:00:00 on */
/* the Gregorian calendar. There are several reasons for this. */
/* Leap years in the Julian calendar occur every */
/* 4 years (including *all* centuries). Moreover, the */
/* Gregorian calendar "effectively" begins on 15 Oct, 1582 A.D. */
/* which is 5 Oct, 1582 A.D. in the Julian Calendar. */
/* Therefore you must be careful in your interpretation */
/* of ancient dates produced by this routine. */
/* $ Literature_References */
/* 1. "From Sundial to Atomic Clocks---Understanding Time and */
/* Frequency" by James Jespersen and Jane Fitz-Randolph */
/* Dover Publications, Inc. New York (1982). */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* K.R. Gehringer (JPL) */
/* $ Version */
/* - SPICELIB Version 2.2.0, 05-MAR-1998 (WLT) */
/* The documentation concerning the appearance of the output */
/* time string was corrected so that it does not suggest */
/* a comma is inserted after the day of the month. The */
/* comma was removed from the output string in Version 2.0.0 */
/* (see the note below) but the documentation was not upgraded */
/* accordingly. */
/* - SPICELIB Version 2.1.0, 20-MAY-1996 (WLT) */
/* Two arrays that were initialized but never used were */
/* removed. */
/* - SPICELIB Version 2.0.0, 16-AUG-1995 (KRG) */
/* If the day number was less than 10, the spacing was off for */
/* the rest of the time by one space, that for the "tens" digit. */
/* This has been fixed by using a leading zero when the number of */
/* days is < 10. */
/* Also, the comma that appeared between the month/day/year */
/* and the hour:minute:seconds tokens has been removed. This was */
/* done in order to make the calendar date format of ETCAL */
/* consistent with the calendar date format of ET2UTC. */
/* - SPICELIB Version 1.0.0, 14-DEC-1993 (WLT) */
/* -& */
/* $ Index_Entries */
/* Convert ephemeris time to a formal calendar date */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.1.0, 20-MAY-1996 (WLT) */
/* Two arrays that were initialized but never used were */
/* removed. */
/* - SPICELIB Version 2.0.0, 16-AUG-1995 (KRG) */
/* If the day number was less than 10, the spacing was off for */
/* the rest of the time by one space, that for the "tens" digit. */
/* This has been fixed byusing a leading zero when the number of */
/* days is < 10. */
/* Also, the comma that appeared between the month/day/year */
/* and the hour:minute:seconds tokens has been removed. This was */
/* done in order to make the calendar date format of ETCAL */
/* consistent with the calendar date format of ET2UTC. */
/* - SPICELIB Version 1.0.0, 14-DEC-1993 (WLT) */
/* -& */
/* Spicelib Functions. */
/* We declare the variables that contain the number of days in */
/* 400 years, 100 years, 4 years and 1 year. */
/* The following integers give the number of days during the */
/* associated month of a non-leap year. */
/* The integers that follow give the number of days in a normal */
/* year that precede the first of the month. */
/* The integers that follow give the number of days in a leap */
/* year that precede the first of the month. */
/* The variables below hold the components of the output string */
/* before they are put together. */
/* We will construct our string using the local variable DATE */
/* and transfer the results to the output STRING when we are */
/* done. */
/* MONTHS contains 3-letter abbreviations for the months of the year */
/* The array EXTRA contains the number of additional days that */
/* appear before the first of a month during a leap year (as opposed */
/* to a non-leap year). */
/* DPJAN0(I) gives the number of days that occur before the I'th */
/* month of a normal year. */
/* Definitions of statement functions. */
/* The number of days elapsed since Jan 1, of year 1 A.D. to */
/* Jan 1 of YEAR is given by: */
/* The number of leap days in a year is given by: */
/* To compute the day of the year we */
/* look up the number of days to the beginning of the month, */
/* add on the number leap days that occurred prior to that */
/* time */
/* add on the number of days into the month */
/* The number of days since 1 Jan 1 A.D. is given by: */
if (first) {
first = FALSE_;
halfd = spd_() / 2.;
secspd = spd_();
dn2000 = (c__2000 - 1) * 365 + (c__2000 - 1) / 4 - (c__2000 - 1) /
100 + (c__2000 - 1) / 400 + (dpjan0[(i__1 = c__1 - 1) < 12 &&
0 <= i__1 ? i__1 : s_rnge("dpjan0", i__1, "etcal_", (ftnlen)
571)] + extra[(i__2 = c__1 - 1) < 12 && 0 <= i__2 ? i__2 :
s_rnge("extra", i__2, "etcal_", (ftnlen)571)] * ((c__2000 / 4
<< 2) / c__2000 - c__2000 / 100 * 100 / c__2000 + c__2000 /
400 * 400 / c__2000) + c__1) - 1;
dmxint = (doublereal) intmax_();
dmnint = (doublereal) intmin_();
}
/* Now we "in-line" compute the following call. */
/* call rmaind ( et + halfd, secspd, dp2000, secs ) */
/* because we can't make a call to rmaind. */
/* The reader may wonder why we use et + halfd. The value */
/* et is seconds past the ephemeris epoch of J2000 which */
/* is at 2000 Jan 1, 12:00:00. We want to compute days past */
/* 2000 Jan 1, 00:00:00. The seconds past THAT epoch is et + halfd. */
/* We add on 0.0005 seconds so that the string produced will be */
/* rounded to the nearest millisecond. */
mydnom = secspd;
mynum = *et + halfd;
d__1 = mynum / mydnom;
q = d_int(&d__1);
remd = mynum - q * mydnom;
if (remd < 0.) {
q += -1.;
remd += mydnom;
}
secs = remd;
dp2000 = q;
/* Do something about the problem when ET is vastly */
/* out of range. (Day number outside MAX and MIN integer). */
if (dp2000 + dn2000 < dmnint + 1) {
dp2000 = dmnint - dn2000 + 1;
s_copy(messge, "Epoch before ", (ftnlen)16, (ftnlen)13);
secs = 0.;
} else if (dp2000 + dn2000 > dmxint - 1) {
dp2000 = dmxint - dn2000 - 1;
s_copy(messge, "Epoch after ", (ftnlen)16, (ftnlen)12);
secs = 0.;
} else {
s_copy(messge, " ", (ftnlen)16, (ftnlen)1);
}
/* Compute the number of days since 1 .A.D. Jan 1, 00:00:00. */
/* From the tests in the previous IF-ELSE IF-ELSE block this */
/* addition is guaranteed not to overflow. */
daynum = (integer) (dp2000 + (doublereal) dn2000);
/* If the number of days is negative, we need to do a little */
/* work so that we can represent the date in the B.C. era. */
/* We add enough multiples of 400 years so that the year will */
/* be positive and then we subtract off the appropriate multiple */
/* of 400 years later. */
if (daynum < 0) {
/* Since we can't make the call below and remain */
/* error free, we compute it ourselves. */
/* call rmaini ( daynum, dp400y, offset, daynum ) */
iq = daynum / 146097;
rem = daynum - iq * 146097;
if (rem < 0) {
--iq;
rem += 146097;
}
offset = iq;
daynum = rem;
adjust = TRUE_;
} else {
adjust = FALSE_;
}
/* Next we compute the year. Divide out multiples of 400, 100 */
/* 4 and 1 year. Finally combine these to get the correct */
/* value for year. (Note this is all integer arithmetic.) */
/* Recall that DP1Y = 365 */
/* DP4Y = 4*DPY + 1 */
/* DP100Y = 25*DP4Y - 1 */
/* DP400Y = 4*DP100Y + 1 */
yr400 = daynum / 146097;
rem = daynum - yr400 * 146097;
/* Computing MIN */
i__1 = 3, i__2 = rem / 36524;
yr100 = min(i__1,i__2);
rem -= yr100 * 36524;
/* Computing MIN */
i__1 = 24, i__2 = rem / 1461;
yr4 = min(i__1,i__2);
rem -= yr4 * 1461;
/* Computing MIN */
i__1 = 3, i__2 = rem / 365;
yr1 = min(i__1,i__2);
rem -= yr1 * 365;
dofyr = rem + 1;
year = yr400 * 400 + yr100 * 100 + (yr4 << 2) + yr1 + 1;
/* Get the month, and day of month (depending upon whether */
/* we have a leap year or not). */
if ((year / 4 << 2) / year - year / 100 * 100 / year + year / 400 * 400 /
year == 0) {
month = lstlti_(&dofyr, &c__12, dpjan0);
day = dofyr - dpjan0[(i__1 = month - 1) < 12 && 0 <= i__1 ? i__1 :
s_rnge("dpjan0", i__1, "etcal_", (ftnlen)698)];
} else {
month = lstlti_(&dofyr, &c__12, dpbegl);
day = dofyr - dpbegl[(i__1 = month - 1) < 12 && 0 <= i__1 ? i__1 :
s_rnge("dpbegl", i__1, "etcal_", (ftnlen)701)];
}
/* If we had to adjust the year to make it positive, we now */
/* need to correct it and then convert it to a B.C. year. */
if (adjust) {
year += offset * 400;
year = -year + 1;
s_copy(era, " B.C. ", (ftnlen)16, (ftnlen)6);
} else {
/* If the year is less than 1000, we can't just write it */
/* out. We need to add the era. If we don't do this */
/* the dates look very confusing. */
if (year < 1000) {
s_copy(era, " A.D. ", (ftnlen)16, (ftnlen)6);
} else {
s_copy(era, " ", (ftnlen)16, (ftnlen)1);
}
}
/* Convert Seconds to Hours, Minute and Seconds. */
/* We work with thousandths of a second in integer arithmetic */
/* so that all of the truncation work with seconds will already */
/* be done. (Note that we already know that SECS is greater than */
/* or equal to zero so we'll have no problems with HOURS, MINS */
/* or SECS becoming negative.) */
tsecs = (integer) (secs * 1e3);
frac = secs - (doublereal) tsecs;
hours = tsecs / 3600000;
tsecs -= hours * 3600000;
mins = tsecs / 60000;
tsecs -= mins * 60000;
secs = (doublereal) tsecs / 1e3;
/* We round seconds if we can do so without getting seconds to be */
/* bigger than 60. */
if (secs + 5e-4 < 60.) {
secs += 5e-4;
}
/* Finally, get the components of our date string. */
intstr_(&year, ystr, (ftnlen)16);
if (day >= 10) {
intstr_(&day, dstr, (ftnlen)16);
} else {
s_copy(dstr, "0", (ftnlen)16, (ftnlen)1);
intstr_(&day, dstr + 1, (ftnlen)15);
}
/* We want to zero pad the hours minutes and seconds. */
if (hours < 10) {
bh = 2;
} else {
bh = 1;
}
if (mins < 10) {
bm = 2;
} else {
bm = 1;
}
s_copy(mstr, "00", (ftnlen)16, (ftnlen)2);
s_copy(hstr, "00", (ftnlen)16, (ftnlen)2);
s_copy(sstr, " ", (ftnlen)16, (ftnlen)1);
/* Now construct the string components for hours, minutes and */
/* seconds. */
secs = (integer) (secs * 1e3) / 1e3;
intstr_(&hours, hstr + (bh - 1), 16 - (bh - 1));
intstr_(&mins, mstr + (bm - 1), 16 - (bm - 1));
dpstrf_(&secs, &c__6, "F", sstr, (ftnlen)1, (ftnlen)16);
/* The form of the output for SSTR has a leading blank followed by */
/* the first significant digit. If a decimal point is in the */
/* third slot, then SSTR is of the form ' x.xxxxx' and we need */
/* to insert a leading zero. */
if (*(unsigned char *)&sstr[2] == '.') {
*(unsigned char *)sstr = '0';
}
/* We don't want any leading spaces in SSTR, (HSTR and MSTR don't */
/* have leading spaces by construction. */
ljust_(sstr, sstr, (ftnlen)16, (ftnlen)16);
/* Now form the date string, squeeze out extra spaces and */
/* left justify the whole thing. */
/* Writing concatenation */
i__3[0] = 16, a__1[0] = messge;
i__3[1] = 16, a__1[1] = ystr;
i__3[2] = 16, a__1[2] = era;
i__3[3] = 3, a__1[3] = months + ((i__1 = month - 1) < 12 && 0 <= i__1 ?
i__1 : s_rnge("months", i__1, "etcal_", (ftnlen)810)) * 3;
i__3[4] = 1, a__1[4] = " ";
i__3[5] = 3, a__1[5] = dstr;
i__3[6] = 1, a__1[6] = " ";
i__3[7] = 2, a__1[7] = hstr;
i__3[8] = 1, a__1[8] = ":";
i__3[9] = 2, a__1[9] = mstr;
i__3[10] = 1, a__1[10] = ":";
i__3[11] = 6, a__1[11] = sstr;
s_cat(date, a__1, i__3, &c__12, (ftnlen)180);
cmprss_(" ", &c__1, date, date, (ftnlen)1, (ftnlen)180, (ftnlen)180);
ljust_(date, date, (ftnlen)180, (ftnlen)180);
s_copy(string, date, string_len, (ftnlen)180);
return 0;
} /* etcal_ */
/* ----------------------------------------------------------------------| */
/* Subroutine */ int zgexpv(integer *n, integer *m, doublereal *t,
doublecomplex *v, doublecomplex *w, doublereal *tol, doublereal *
anorm, doublecomplex *wsp, integer *lwsp, integer *iwsp, integer *
liwsp, S_fp matvec, void *matvecdata, integer *itrace, integer *iflag)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
complex q__1;
doublecomplex z__1;
/* Builtin functions */
/* Subroutine */ int s_stop(char *, ftnlen);
double sqrt(doublereal), d_sign(doublereal *, doublereal *), pow_di(
doublereal *, integer *), pow_dd(doublereal *, doublereal *),
d_lg10(doublereal *);
integer i_dnnt(doublereal *);
double d_int(doublereal *);
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle();
double z_abs(doublecomplex *);
/* Local variables */
static integer ibrkflag;
static doublereal step_min__, step_max__;
static integer i__, j;
static doublereal break_tol__;
static integer k1;
static doublereal p1, p2, p3;
static integer ih, mh, iv, ns, mx;
static doublereal xm;
static integer j1v;
static doublecomplex hij;
static doublereal sgn, eps, hj1j, sqr1, beta, hump;
static integer ifree, lfree;
static doublereal t_old__;
static integer iexph;
static doublereal t_new__;
static integer nexph;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal t_now__;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, ftnlen);
static integer nstep;
static doublereal t_out__;
static integer nmult;
static doublereal vnorm;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
static integer nscale;
static doublereal rndoff;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *), zgpadm_(integer *, integer *,
doublereal *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *, integer *, integer *, integer *), znchbv_(
integer *, doublereal *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *);
static doublereal t_step__, avnorm;
static integer ireject;
static doublereal err_loc__;
static integer nreject, mbrkdwn;
static doublereal tbrkdwn, s_error__, x_error__;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 6, 0, 0, 0 };
static cilist io___48 = { 0, 6, 0, 0, 0 };
static cilist io___49 = { 0, 6, 0, 0, 0 };
static cilist io___50 = { 0, 6, 0, 0, 0 };
static cilist io___51 = { 0, 6, 0, 0, 0 };
static cilist io___52 = { 0, 6, 0, 0, 0 };
static cilist io___53 = { 0, 6, 0, 0, 0 };
static cilist io___54 = { 0, 6, 0, 0, 0 };
static cilist io___55 = { 0, 6, 0, 0, 0 };
static cilist io___56 = { 0, 6, 0, 0, 0 };
static cilist io___57 = { 0, 6, 0, 0, 0 };
static cilist io___58 = { 0, 6, 0, 0, 0 };
static cilist io___59 = { 0, 6, 0, 0, 0 };
/* -----Purpose----------------------------------------------------------| */
/* --- ZGEXPV computes w = exp(t*A)*v */
/* for a Zomplex (i.e., complex double precision) matrix A */
/* It does not compute the matrix exponential in isolation but */
/* instead, it computes directly the action of the exponential */
/* operator on the operand vector. This way of doing so allows */
/* for addressing large sparse problems. */
/* The method used is based on Krylov subspace projection */
/* techniques and the matrix under consideration interacts only */
/* via the external routine `matvec' performing the matrix-vector */
/* product (matrix-free method). */
/* -----Arguments--------------------------------------------------------| */
/* n : (input) order of the principal matrix A. */
/* m : (input) maximum size for the Krylov basis. */
/* t : (input) time at wich the solution is needed (can be < 0). */
/* v(n) : (input) given operand vector. */
/* w(n) : (output) computed approximation of exp(t*A)*v. */
/* tol : (input/output) the requested accuracy tolerance on w. */
/* If on input tol=0.0d0 or tol is too small (tol.le.eps) */
/* the internal value sqrt(eps) is used, and tol is set to */
/* sqrt(eps) on output (`eps' denotes the machine epsilon). */
/* (`Happy breakdown' is assumed if h(j+1,j) .le. anorm*tol) */
/* anorm : (input) an approximation of some norm of A. */
/* wsp(lwsp): (workspace) lwsp .ge. n*(m+1)+n+(m+2)^2+4*(m+2)^2+ideg+1 */
/* +---------+-------+---------------+ */
/* (actually, ideg=6) V H wsp for PADE */
/* iwsp(liwsp): (workspace) liwsp .ge. m+2 */
/* matvec : external subroutine for matrix-vector multiplication. */
/* synopsis: matvec( x, y ) */
/* complex*16 x(*), y(*) */
/* computes: y(1:n) <- A*x(1:n) */
/* where A is the principal matrix. */
/* itrace : (input) running mode. 0=silent, 1=print step-by-step info */
/* iflag : (output) exit flag. */
/* <0 - bad input arguments */
/* 0 - no problem */
/* 1 - maximum number of steps reached without convergence */
/* 2 - requested tolerance was too high */
/* -----Accounts on the computation--------------------------------------| */
/* Upon exit, an interested user may retrieve accounts on the */
/* computations. They are located in the workspace arrays wsp and */
/* iwsp as indicated below: */
/* location mnemonic description */
/* -----------------------------------------------------------------| */
/* iwsp(1) = nmult, number of matrix-vector multiplications used */
/* iwsp(2) = nexph, number of Hessenberg matrix exponential evaluated */
/* iwsp(3) = nscale, number of repeated squaring involved in Pade */
/* iwsp(4) = nstep, number of integration steps used up to completion */
/* iwsp(5) = nreject, number of rejected step-sizes */
/* iwsp(6) = ibrkflag, set to 1 if `happy breakdown' and 0 otherwise */
/* iwsp(7) = mbrkdwn, if `happy brkdown', basis-size when it occured */
/* -----------------------------------------------------------------| */
/* wsp(1) = step_min, minimum step-size used during integration */
/* wsp(2) = step_max, maximum step-size used during integration */
/* wsp(3) = x_round, maximum among all roundoff errors (lower bound) */
/* wsp(4) = s_round, sum of roundoff errors (lower bound) */
/* wsp(5) = x_error, maximum among all local truncation errors */
/* wsp(6) = s_error, global sum of local truncation errors */
/* wsp(7) = tbrkdwn, if `happy breakdown', time when it occured */
/* wsp(8) = t_now, integration domain successfully covered */
/* wsp(9) = hump, i.e., max||exp(sA)||, s in [0,t] (or [t,0] if t<0) */
/* wsp(10) = ||w||/||v||, scaled norm of the solution w. */
/* -----------------------------------------------------------------| */
/* The `hump' is a measure of the conditioning of the problem. The */
/* matrix exponential is well-conditioned if hump = 1, whereas it is */
/* poorly-conditioned if hump >> 1. However the solution can still be */
/* relatively fairly accurate even when the hump is large (the hump */
/* is an upper bound), especially when the hump and the scaled norm */
/* of w [this is also computed and returned in wsp(10)] are of the */
/* same order of magnitude (further details in reference below). */
/* ----------------------------------------------------------------------| */
/* -----The following parameters may also be adjusted herein-------------| */
/* mxstep : maximum allowable number of integration steps. */
/* The value 0 means an infinite number of steps. */
/* mxreject: maximum allowable number of rejections at each step. */
/* The value 0 means an infinite number of rejections. */
/* ideg : the Pade approximation of type (ideg,ideg) is used as */
/* an approximation to exp(H). The value 0 switches to the */
/* uniform rational Chebyshev approximation of type (14,14) */
/* delta : local truncation error `safety factor' */
/* gamma : stepsize `shrinking factor' */
/* ----------------------------------------------------------------------| */
/* Roger B. Sidje ([email protected]) */
/* EXPOKIT: Software Package for Computing Matrix Exponentials. */
/* ACM - Transactions On Mathematical Software, 24(1):130-156, 1998 */
/* ----------------------------------------------------------------------| */
/* --- check restrictions on input parameters ... */
/* Parameter adjustments */
--w;
--v;
--wsp;
--iwsp;
/* Function Body */
*iflag = 0;
/* Computing 2nd power */
i__1 = *m + 2;
if (*lwsp < *n * (*m + 2) + i__1 * i__1 * 5 + 7) {
*iflag = -1;
}
if (*liwsp < *m + 2) {
*iflag = -2;
}
if (*m >= *n || *m <= 0) {
*iflag = -3;
}
if (*iflag != 0) {
s_stop("bad sizes (in input of ZGEXPV)", (ftnlen)30);
}
/* --- initialisations ... */
k1 = 2;
mh = *m + 2;
iv = 1;
ih = iv + *n * (*m + 1) + *n;
ifree = ih + mh * mh;
lfree = *lwsp - ifree + 1;
ibrkflag = 0;
mbrkdwn = *m;
nmult = 0;
nreject = 0;
nexph = 0;
nscale = 0;
t_out__ = abs(*t);
tbrkdwn = 0.;
step_min__ = t_out__;
step_max__ = 0.;
nstep = 0;
s_error__ = 0.;
x_error__ = 0.;
t_now__ = 0.;
t_new__ = 0.;
p1 = 1.3333333333333333;
L1:
p2 = p1 - 1.;
p3 = p2 + p2 + p2;
eps = (d__1 = p3 - 1., abs(d__1));
if (eps == 0.) {
goto L1;
}
if (*tol <= eps) {
*tol = sqrt(eps);
}
rndoff = eps * *anorm;
break_tol__ = 1e-7;
/* >>> break_tol = tol */
/* >>> break_tol = anorm*tol */
sgn = d_sign(&c_b6, t);
zcopy_(n, &v[1], &c__1, &w[1], &c__1);
beta = dznrm2_(n, &w[1], &c__1);
vnorm = beta;
hump = beta;
/* --- obtain the very first stepsize ... */
sqr1 = sqrt(.1);
xm = 1. / (doublereal) (*m);
d__1 = (*m + 1) / 2.72;
i__1 = *m + 1;
p2 = *tol * pow_di(&d__1, &i__1) * sqrt((*m + 1) * 6.2800000000000002);
d__1 = p2 / (beta * 4. * *anorm);
t_new__ = 1. / *anorm * pow_dd(&d__1, &xm);
d__1 = d_lg10(&t_new__) - sqr1;
i__1 = i_dnnt(&d__1) - 1;
p1 = pow_di(&c_b10, &i__1);
d__1 = t_new__ / p1 + .55;
t_new__ = d_int(&d__1) * p1;
/* --- step-by-step integration ... */
L100:
if (t_now__ >= t_out__) {
goto L500;
}
++nstep;
/* Computing MIN */
d__1 = t_out__ - t_now__;
t_step__ = min(d__1,t_new__);
p1 = 1. / beta;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iv + i__ - 1;
i__3 = i__;
z__1.r = p1 * w[i__3].r, z__1.i = p1 * w[i__3].i;
wsp[i__2].r = z__1.r, wsp[i__2].i = z__1.i;
}
i__1 = mh * mh;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = ih + i__ - 1;
wsp[i__2].r = 0., wsp[i__2].i = 0.;
}
/* --- Arnoldi loop ... */
j1v = iv + *n;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
++nmult;
(*matvec)(matvecdata, &wsp[j1v - *n], &wsp[j1v]);
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
zdotc_(&z__1, n, &wsp[iv + (i__ - 1) * *n], &c__1, &wsp[j1v], &
c__1);
hij.r = z__1.r, hij.i = z__1.i;
z__1.r = -hij.r, z__1.i = -hij.i;
zaxpy_(n, &z__1, &wsp[iv + (i__ - 1) * *n], &c__1, &wsp[j1v], &
c__1);
i__3 = ih + (j - 1) * mh + i__ - 1;
wsp[i__3].r = hij.r, wsp[i__3].i = hij.i;
}
hj1j = dznrm2_(n, &wsp[j1v], &c__1);
/* --- if `happy breakdown' go straightforward at the end ... */
if (hj1j <= break_tol__) {
s_wsle(&io___40);
do_lio(&c__9, &c__1, "happy breakdown: mbrkdwn =", (ftnlen)26);
do_lio(&c__3, &c__1, (char *)&j, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, " h =", (ftnlen)4);
do_lio(&c__5, &c__1, (char *)&hj1j, (ftnlen)sizeof(doublereal));
e_wsle();
k1 = 0;
ibrkflag = 1;
mbrkdwn = j;
tbrkdwn = t_now__;
t_step__ = t_out__ - t_now__;
goto L300;
}
i__2 = ih + (j - 1) * mh + j;
q__1.r = hj1j, q__1.i = (float)0.;
wsp[i__2].r = q__1.r, wsp[i__2].i = q__1.i;
d__1 = 1. / hj1j;
zdscal_(n, &d__1, &wsp[j1v], &c__1);
j1v += *n;
/* L200: */
}
++nmult;
(*matvec)(matvecdata, &wsp[j1v - *n], &wsp[j1v]);
avnorm = dznrm2_(n, &wsp[j1v], &c__1);
/* --- set 1 for the 2-corrected scheme ... */
L300:
i__1 = ih + *m * mh + *m + 1;
wsp[i__1].r = 1., wsp[i__1].i = 0.;
/* --- loop while ireject<mxreject until the tolerance is reached ... */
ireject = 0;
L401:
/* --- compute w = beta*V*exp(t_step*H)*e1 ... */
++nexph;
mx = mbrkdwn + k1;
if (TRUE_) {
/* --- irreducible rational Pade approximation ... */
d__1 = sgn * t_step__;
zgpadm_(&c__6, &mx, &d__1, &wsp[ih], &mh, &wsp[ifree], &lfree, &iwsp[
1], &iexph, &ns, iflag);
iexph = ifree + iexph - 1;
nscale += ns;
} else {
/* --- uniform rational Chebyshev approximation ... */
iexph = ifree;
i__1 = mx;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iexph + i__ - 1;
wsp[i__2].r = 0., wsp[i__2].i = 0.;
}
i__1 = iexph;
wsp[i__1].r = 1., wsp[i__1].i = 0.;
d__1 = sgn * t_step__;
znchbv_(&mx, &d__1, &wsp[ih], &mh, &wsp[iexph], &wsp[ifree + mx]);
}
/* L402: */
/* --- error estimate ... */
if (k1 == 0) {
err_loc__ = *tol;
} else {
p1 = z_abs(&wsp[iexph + *m]) * beta;
p2 = z_abs(&wsp[iexph + *m + 1]) * beta * avnorm;
if (p1 > p2 * 10.) {
err_loc__ = p2;
xm = 1. / (doublereal) (*m);
} else if (p1 > p2) {
err_loc__ = p1 * p2 / (p1 - p2);
xm = 1. / (doublereal) (*m);
} else {
err_loc__ = p1;
xm = 1. / (doublereal) (*m - 1);
}
}
/* --- reject the step-size if the error is not acceptable ... */
if (k1 != 0 && err_loc__ > t_step__ * 1.2 * *tol) {
t_old__ = t_step__;
d__1 = t_step__ * *tol / err_loc__;
t_step__ = t_step__ * .9 * pow_dd(&d__1, &xm);
d__1 = d_lg10(&t_step__) - sqr1;
i__1 = i_dnnt(&d__1) - 1;
p1 = pow_di(&c_b10, &i__1);
d__1 = t_step__ / p1 + .55;
t_step__ = d_int(&d__1) * p1;
if (*itrace != 0) {
s_wsle(&io___48);
do_lio(&c__9, &c__1, "t_step =", (ftnlen)8);
do_lio(&c__5, &c__1, (char *)&t_old__, (ftnlen)sizeof(doublereal))
;
e_wsle();
s_wsle(&io___49);
do_lio(&c__9, &c__1, "err_loc =", (ftnlen)9);
do_lio(&c__5, &c__1, (char *)&err_loc__, (ftnlen)sizeof(
doublereal));
e_wsle();
s_wsle(&io___50);
do_lio(&c__9, &c__1, "err_required =", (ftnlen)14);
d__1 = t_old__ * 1.2 * *tol;
do_lio(&c__5, &c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsle();
s_wsle(&io___51);
do_lio(&c__9, &c__1, "stepsize rejected, stepping down to:", (
ftnlen)36);
do_lio(&c__5, &c__1, (char *)&t_step__, (ftnlen)sizeof(doublereal)
);
e_wsle();
}
++ireject;
++nreject;
if (FALSE_) {
s_wsle(&io___52);
do_lio(&c__9, &c__1, "Failure in ZGEXPV: ---", (ftnlen)22);
e_wsle();
s_wsle(&io___53);
do_lio(&c__9, &c__1, "The requested tolerance is too high.", (
ftnlen)36);
e_wsle();
s_wsle(&io___54);
do_lio(&c__9, &c__1, "Rerun with a smaller value.", (ftnlen)27);
e_wsle();
*iflag = 2;
return 0;
}
goto L401;
}
/* --- now update w = beta*V*exp(t_step*H)*e1 and the hump ... */
/* Computing MAX */
i__1 = 0, i__2 = k1 - 1;
mx = mbrkdwn + max(i__1,i__2);
q__1.r = beta, q__1.i = (float)0.;
hij.r = q__1.r, hij.i = q__1.i;
zgemv_("n", n, &mx, &hij, &wsp[iv], n, &wsp[iexph], &c__1, &c_b1, &w[1], &
c__1, (ftnlen)1);
beta = dznrm2_(n, &w[1], &c__1);
hump = max(hump,beta);
/* --- suggested value for the next stepsize ... */
d__1 = t_step__ * *tol / err_loc__;
t_new__ = t_step__ * .9 * pow_dd(&d__1, &xm);
d__1 = d_lg10(&t_new__) - sqr1;
i__1 = i_dnnt(&d__1) - 1;
p1 = pow_di(&c_b10, &i__1);
d__1 = t_new__ / p1 + .55;
t_new__ = d_int(&d__1) * p1;
err_loc__ = max(err_loc__,rndoff);
/* --- update the time covered ... */
t_now__ += t_step__;
/* --- display and keep some information ... */
if (*itrace != 0) {
s_wsle(&io___55);
do_lio(&c__9, &c__1, "integration", (ftnlen)11);
do_lio(&c__3, &c__1, (char *)&nstep, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, "---------------------------------", (ftnlen)33);
e_wsle();
s_wsle(&io___56);
do_lio(&c__9, &c__1, "scale-square =", (ftnlen)14);
do_lio(&c__3, &c__1, (char *)&ns, (ftnlen)sizeof(integer));
e_wsle();
s_wsle(&io___57);
do_lio(&c__9, &c__1, "step_size =", (ftnlen)11);
do_lio(&c__5, &c__1, (char *)&t_step__, (ftnlen)sizeof(doublereal));
e_wsle();
s_wsle(&io___58);
do_lio(&c__9, &c__1, "err_loc =", (ftnlen)11);
do_lio(&c__5, &c__1, (char *)&err_loc__, (ftnlen)sizeof(doublereal));
e_wsle();
s_wsle(&io___59);
do_lio(&c__9, &c__1, "next_step =", (ftnlen)11);
do_lio(&c__5, &c__1, (char *)&t_new__, (ftnlen)sizeof(doublereal));
e_wsle();
}
step_min__ = min(step_min__,t_step__);
step_max__ = max(step_max__,t_step__);
s_error__ += err_loc__;
x_error__ = max(x_error__,err_loc__);
if (nstep < 500) {
goto L100;
}
*iflag = 1;
L500:
iwsp[1] = nmult;
iwsp[2] = nexph;
iwsp[3] = nscale;
iwsp[4] = nstep;
iwsp[5] = nreject;
iwsp[6] = ibrkflag;
iwsp[7] = mbrkdwn;
q__1.r = step_min__, q__1.i = (float)0.;
wsp[1].r = q__1.r, wsp[1].i = q__1.i;
q__1.r = step_max__, q__1.i = (float)0.;
wsp[2].r = q__1.r, wsp[2].i = q__1.i;
wsp[3].r = (float)0., wsp[3].i = (float)0.;
wsp[4].r = (float)0., wsp[4].i = (float)0.;
q__1.r = x_error__, q__1.i = (float)0.;
wsp[5].r = q__1.r, wsp[5].i = q__1.i;
q__1.r = s_error__, q__1.i = (float)0.;
wsp[6].r = q__1.r, wsp[6].i = q__1.i;
q__1.r = tbrkdwn, q__1.i = (float)0.;
wsp[7].r = q__1.r, wsp[7].i = q__1.i;
d__1 = sgn * t_now__;
q__1.r = d__1, q__1.i = (float)0.;
wsp[8].r = q__1.r, wsp[8].i = q__1.i;
d__1 = hump / vnorm;
q__1.r = d__1, q__1.i = (float)0.;
wsp[9].r = q__1.r, wsp[9].i = q__1.i;
d__1 = beta / vnorm;
q__1.r = d__1, q__1.i = (float)0.;
wsp[10].r = q__1.r, wsp[10].i = q__1.i;
return 0;
} /* zgexpv_ */
/*< SUBROUTINE CALERF(ARG,RESULT,JINT) >*/
double calerf(double x, const int jint) {
static const double a[5] = { 3.1611237438705656,113.864154151050156,377.485237685302021,3209.37758913846947,.185777706184603153 };
static const double b[4] = { 23.6012909523441209,244.024637934444173,1282.61652607737228,2844.23683343917062 };
static const double c__[9] = { .564188496988670089,8.88314979438837594,66.1191906371416295,298.635138197400131,881.95222124176909,1712.04761263407058,2051.07837782607147,1230.33935479799725,2.15311535474403846e-8 };
static const double d__[8] = { 15.7449261107098347,117.693950891312499,537.181101862009858,1621.38957456669019,3290.79923573345963,4362.61909014324716,3439.36767414372164,1230.33935480374942 };
static const double p[6] = { .305326634961232344,.360344899949804439,.125781726111229246,.0160837851487422766,6.58749161529837803e-4,.0163153871373020978 };
static const double q[5] = { 2.56852019228982242,1.87295284992346047,.527905102951428412,.0605183413124413191,.00233520497626869185 };
static const double zero = 0.;
static const double half = .5;
static const double one = 1.;
static const double two = 2.;
static const double four = 4.;
static const double sqrpi = 0.56418958354775628695;
static const double thresh = .46875;
static const double sixten = 16.;
double y, del, ysq, xden, xnum, result;
/* ------------------------------------------------------------------ */
/* This packet evaluates erf(x), erfc(x), and exp(x*x)*erfc(x) */
/* for a real argument x. It contains three FUNCTION type */
/* subprograms: ERF, ERFC, and ERFCX (or DERF, DERFC, and DERFCX), */
/* and one SUBROUTINE type subprogram, CALERF. The calling */
/* statements for the primary entries are: */
/* Y=ERF(X) (or Y=DERF(X)), */
/* Y=ERFC(X) (or Y=DERFC(X)), */
/* and */
/* Y=ERFCX(X) (or Y=DERFCX(X)). */
/* The routine CALERF is intended for internal packet use only, */
/* all computations within the packet being concentrated in this */
/* routine. The function subprograms invoke CALERF with the */
/* statement */
/* CALL CALERF(ARG,RESULT,JINT) */
/* where the parameter usage is as follows */
/* Function Parameters for CALERF */
/* call ARG Result JINT */
/* ERF(ARG) ANY REAL ARGUMENT ERF(ARG) 0 */
/* ERFC(ARG) ABS(ARG) .LT. XBIG ERFC(ARG) 1 */
/* ERFCX(ARG) XNEG .LT. ARG .LT. XMAX ERFCX(ARG) 2 */
/* The main computation evaluates near-minimax approximations */
/* from "Rational Chebyshev approximations for the error function" */
/* by W. J. Cody, Math. Comp., 1969, PP. 631-638. This */
/* transportable program uses rational functions that theoretically */
/* approximate erf(x) and erfc(x) to at least 18 significant */
/* decimal digits. The accuracy achieved depends on the arithmetic */
/* system, the compiler, the intrinsic functions, and proper */
/* selection of the machine-dependent constants. */
/* ******************************************************************* */
/* ******************************************************************* */
/* Explanation of machine-dependent constants */
/* XMIN = the smallest positive floating-point number. */
/* XINF = the largest positive finite floating-point number. */
/* XNEG = the largest negative argument acceptable to ERFCX; */
/* the negative of the solution to the equation */
/* 2*exp(x*x) = XINF. */
/* XSMALL = argument below which erf(x) may be represented by */
/* 2*x/sqrt(pi) and above which x*x will not underflow. */
/* A conservative value is the largest machine number X */
/* such that 1.0 + X = 1.0 to machine precision. */
/* XBIG = largest argument acceptable to ERFC; solution to */
/* the equation: W(x) * (1-0.5/x**2) = XMIN, where */
/* W(x) = exp(-x*x)/[x*sqrt(pi)]. */
/* XHUGE = argument above which 1.0 - 1/(2*x*x) = 1.0 to */
/* machine precision. A conservative value is */
/* 1/[2*sqrt(XSMALL)] */
/* XMAX = largest acceptable argument to ERFCX; the minimum */
/* of XINF and 1/[sqrt(pi)*XMIN]. */
// The numbers below were preselected for IEEE .
static const double xinf = 1.79e308;
static const double xneg = -26.628;
static const double xsmall = 1.11e-16;
static const double xbig = 26.543;
static const double xhuge = 6.71e7;
static const double xmax = 2.53e307;
/* Approximate values for some important machines are: */
/* XMIN XINF XNEG XSMALL */
/* CDC 7600 (S.P.) 3.13E-294 1.26E+322 -27.220 7.11E-15 */
/* CRAY-1 (S.P.) 4.58E-2467 5.45E+2465 -75.345 7.11E-15 */
/* IEEE (IBM/XT, */
/* SUN, etc.) (S.P.) 1.18E-38 3.40E+38 -9.382 5.96E-8 */
/* IEEE (IBM/XT, */
/* SUN, etc.) (D.P.) 2.23D-308 1.79D+308 -26.628 1.11D-16 */
/* IBM 195 (D.P.) 5.40D-79 7.23E+75 -13.190 1.39D-17 */
/* UNIVAC 1108 (D.P.) 2.78D-309 8.98D+307 -26.615 1.73D-18 */
/* VAX D-Format (D.P.) 2.94D-39 1.70D+38 -9.345 1.39D-17 */
/* VAX G-Format (D.P.) 5.56D-309 8.98D+307 -26.615 1.11D-16 */
/* XBIG XHUGE XMAX */
/* CDC 7600 (S.P.) 25.922 8.39E+6 1.80X+293 */
/* CRAY-1 (S.P.) 75.326 8.39E+6 5.45E+2465 */
/* IEEE (IBM/XT, */
/* SUN, etc.) (S.P.) 9.194 2.90E+3 4.79E+37 */
/* IEEE (IBM/XT, */
/* SUN, etc.) (D.P.) 26.543 6.71D+7 2.53D+307 */
/* IBM 195 (D.P.) 13.306 1.90D+8 7.23E+75 */
/* UNIVAC 1108 (D.P.) 26.582 5.37D+8 8.98D+307 */
/* VAX D-Format (D.P.) 9.269 1.90D+8 1.70D+38 */
/* VAX G-Format (D.P.) 26.569 6.71D+7 8.98D+307 */
/* ******************************************************************* */
/* ******************************************************************* */
/* Error returns */
/* The program returns ERFC = 0 for ARG .GE. XBIG; */
/* ERFCX = XINF for ARG .LT. XNEG; */
/* and */
/* ERFCX = 0 for ARG .GE. XMAX. */
/* Intrinsic functions required are: */
/* ABS, AINT, EXP */
/* Author: W. J. Cody */
/* Mathematics and Computer Science Division */
/* Argonne National Laboratory */
/* Argonne, IL 60439 */
/* Latest modification: March 19, 1990 */
/* ------------------------------------------------------------------ */
/*< INTEGER I,JINT >*/
/* S REAL */
/*< >*/
/*< DIMENSION A(5),B(4),C(9),D(8),P(6),Q(5) >*/
/* ------------------------------------------------------------------ */
/* Mathematical constants */
/* ------------------------------------------------------------------ */
/* S DATA FOUR,ONE,HALF,TWO,ZERO/4.0E0,1.0E0,0.5E0,2.0E0,0.0E0/, */
/* S 1 SQRPI/5.6418958354775628695E-1/,THRESH/0.46875E0/, */
/* S 2 SIXTEN/16.0E0/ */
/*< >*/
/* ------------------------------------------------------------------ */
/* Machine-dependent constants */
/* ------------------------------------------------------------------ */
/* S DATA XINF,XNEG,XSMALL/3.40E+38,-9.382E0,5.96E-8/, */
/* S 1 XBIG,XHUGE,XMAX/9.194E0,2.90E3,4.79E37/ */
/*< >*/
/* ------------------------------------------------------------------ */
/* Coefficients for approximation to erf in first interval */
/* ------------------------------------------------------------------ */
/* S DATA A/3.16112374387056560E00,1.13864154151050156E02, */
/* S 1 3.77485237685302021E02,3.20937758913846947E03, */
/* S 2 1.85777706184603153E-1/ */
/* S DATA B/2.36012909523441209E01,2.44024637934444173E02, */
/* S 1 1.28261652607737228E03,2.84423683343917062E03/ */
/*< >*/
/*< >*/
/* ------------------------------------------------------------------ */
/* Coefficients for approximation to erfc in second interval */
/* ------------------------------------------------------------------ */
/* S DATA C/5.64188496988670089E-1,8.88314979438837594E0, */
/* S 1 6.61191906371416295E01,2.98635138197400131E02, */
/* S 2 8.81952221241769090E02,1.71204761263407058E03, */
/* S 3 2.05107837782607147E03,1.23033935479799725E03, */
/* S 4 2.15311535474403846E-8/ */
/* S DATA D/1.57449261107098347E01,1.17693950891312499E02, */
/* S 1 5.37181101862009858E02,1.62138957456669019E03, */
/* S 2 3.29079923573345963E03,4.36261909014324716E03, */
/* S 3 3.43936767414372164E03,1.23033935480374942E03/ */
/*< >*/
/*< >*/
/* ------------------------------------------------------------------ */
/* Coefficients for approximation to erfc in third interval */
/* ------------------------------------------------------------------ */
/* S DATA P/3.05326634961232344E-1,3.60344899949804439E-1, */
/* S 1 1.25781726111229246E-1,1.60837851487422766E-2, */
/* S 2 6.58749161529837803E-4,1.63153871373020978E-2/ */
/* S DATA Q/2.56852019228982242E00,1.87295284992346047E00, */
/* S 1 5.27905102951428412E-1,6.05183413124413191E-2, */
/* S 2 2.33520497626869185E-3/ */
/*< >*/
/*< >*/
/* ------------------------------------------------------------------ */
/*< X = ARG >*/
// x = *arg;
/*< Y = ABS(X) >*/
y = fabs(x);
/*< IF (Y .LE. THRESH) THEN >*/
if (y <= thresh) {
/* ------------------------------------------------------------------ */
/* Evaluate erf for |X| <= 0.46875 */
/* ------------------------------------------------------------------ */
/*< YSQ = ZERO >*/
ysq = zero;
/*< IF (Y .GT. XSMALL) YSQ = Y * Y >*/
if (y > xsmall) {
ysq = y * y;
}
/*< XNUM = A(5)*YSQ >*/
xnum = a[4] * ysq;
/*< XDEN = YSQ >*/
xden = ysq;
/*< DO 20 I = 1, 3 >*/
for (int i__ = 1; i__ <= 3; ++i__) {
/*< XNUM = (XNUM + A(I)) * YSQ >*/
xnum = (xnum + a[i__ - 1]) * ysq;
/*< XDEN = (XDEN + B(I)) * YSQ >*/
xden = (xden + b[i__ - 1]) * ysq;
/*< 20 CONTINUE >*/
/* L20: */
}
/*< RESULT = X * (XNUM + A(4)) / (XDEN + B(4)) >*/
result = x * (xnum + a[3]) / (xden + b[3]);
/*< IF (JINT .NE. 0) RESULT = ONE - RESULT >*/
if (jint != 0) {
result = one - result;
}
/*< IF (JINT .EQ. 2) RESULT = EXP(YSQ) * RESULT >*/
if (jint == 2) {
result = exp(ysq) * result;
}
/*< GO TO 800 >*/
goto L800;
/* ------------------------------------------------------------------ */
/* Evaluate erfc for 0.46875 <= |X| <= 4.0 */
/* ------------------------------------------------------------------ */
/*< ELSE IF (Y .LE. FOUR) THEN >*/
} else if (y <= four) {
/*< XNUM = C(9)*Y >*/
xnum = c__[8] * y;
/*< XDEN = Y >*/
xden = y;
/*< DO 120 I = 1, 7 >*/
for (int i__ = 1; i__ <= 7; ++i__) {
/*< XNUM = (XNUM + C(I)) * Y >*/
xnum = (xnum + c__[i__ - 1]) * y;
/*< XDEN = (XDEN + D(I)) * Y >*/
xden = (xden + d__[i__ - 1]) * y;
/*< 120 CONTINUE >*/
/* L120: */
}
/*< RESULT = (XNUM + C(8)) / (XDEN + D(8)) >*/
result = (xnum + c__[7]) / (xden + d__[7]);
/*< IF (JINT .NE. 2) THEN >*/
if (jint != 2) {
/*< YSQ = AINT(Y*SIXTEN)/SIXTEN >*/
double d__1 = y * sixten;
ysq = d_int(d__1) / sixten;
/*< DEL = (Y-YSQ)*(Y+YSQ) >*/
del = (y - ysq) * (y + ysq);
/*< RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT >*/
d__1 = exp(-ysq * ysq) * exp(-del);
result = d__1 * result;
/*< END IF >*/
}
/* ------------------------------------------------------------------ */
/* Evaluate erfc for |X| > 4.0 */
/* ------------------------------------------------------------------ */
/*< ELSE >*/
} else {
/*< RESULT = ZERO >*/
result = zero;
/*< IF (Y .GE. XBIG) THEN >*/
if (y >= xbig) {
/*< IF ((JINT .NE. 2) .OR. (Y .GE. XMAX)) GO TO 300 >*/
if (jint != 2 || y >= xmax) {
goto L300;
}
/*< IF (Y .GE. XHUGE) THEN >*/
if (y >= xhuge) {
/*< RESULT = SQRPI / Y >*/
result = sqrpi / y;
/*< GO TO 300 >*/
goto L300;
/*< END IF >*/
}
/*< END IF >*/
}
/*< YSQ = ONE / (Y * Y) >*/
ysq = one / (y * y);
/*< XNUM = P(6)*YSQ >*/
xnum = p[5] * ysq;
/*< XDEN = YSQ >*/
xden = ysq;
/*< DO 240 I = 1, 4 >*/
for (int i__ = 1; i__ <= 4; ++i__) {
/*< XNUM = (XNUM + P(I)) * YSQ >*/
xnum = (xnum + p[i__ - 1]) * ysq;
/*< XDEN = (XDEN + Q(I)) * YSQ >*/
xden = (xden + q[i__ - 1]) * ysq;
/*< 240 CONTINUE >*/
/* L240: */
}
/*< RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5)) >*/
result = ysq * (xnum + p[4]) / (xden + q[4]);
/*< RESULT = (SQRPI - RESULT) / Y >*/
result = (sqrpi - result) / y;
/*< IF (JINT .NE. 2) THEN >*/
if (jint != 2) {
/*< YSQ = AINT(Y*SIXTEN)/SIXTEN >*/
double d__1 = y * sixten;
ysq = d_int(d__1) / sixten;
/*< DEL = (Y-YSQ)*(Y+YSQ) >*/
del = (y - ysq) * (y + ysq);
/*< RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT >*/
d__1 = exp(-ysq * ysq) * exp(-del);
result = d__1 * result;
/*< END IF >*/
}
/*< END IF >*/
}
/* ------------------------------------------------------------------ */
/* Fix up for negative argument, erf, etc. */
/* ------------------------------------------------------------------ */
/*< 300 IF (JINT .EQ. 0) THEN >*/
L300:
if (jint == 0) {
/*< RESULT = (HALF - RESULT) + HALF >*/
result = (half - result) + half;
/*< IF (X .LT. ZERO) RESULT = -RESULT >*/
if (x < zero) {
result = -(result);
}
/*< ELSE IF (JINT .EQ. 1) THEN >*/
} else if (jint == 1) {
/*< IF (X .LT. ZERO) RESULT = TWO - RESULT >*/
if (x < zero) {
result = two - result;
}
/*< ELSE >*/
} else {
/*< IF (X .LT. ZERO) THEN >*/
if (x < zero) {
/*< IF (X .LT. XNEG) THEN >*/
if (x < xneg) {
/*< RESULT = XINF >*/
result = xinf;
/*< ELSE >*/
} else {
/*< YSQ = AINT(X*SIXTEN)/SIXTEN >*/
double d__1 = x * sixten;
ysq = d_int(d__1) / sixten;
/*< DEL = (X-YSQ)*(X+YSQ) >*/
del = (x - ysq) * (x + ysq);
/*< Y = EXP(YSQ*YSQ) * EXP(DEL) >*/
y = exp(ysq * ysq) * exp(del);
/*< RESULT = (Y+Y) - RESULT >*/
result = y + y - result;
/*< END IF >*/
}
/*< END IF >*/
}
/*< END IF >*/
}
/*< 800 RETURN >*/
L800:
return result;
/* ---------- Last card of CALERF ---------- */
/*< END >*/
} /* calerf_ */
/* DECK DGAMR */
doublereal dgamr_(doublereal *x)
{
/* System generated locals */
doublereal ret_val;
/* Builtin functions */
double d_int(doublereal *), exp(doublereal);
/* Local variables */
doublereal alngx;
// integer irold;
// extern /* Subroutine */ int xgetf_(integer *);
doublereal sgngx;
// extern /* Subroutine */ int xsetf_(integer *);
extern doublereal dgamma_(doublereal *);
extern /* Subroutine */ int dlgams_(doublereal *, doublereal *,
doublereal *), xerclr_(void);
/* ***BEGIN PROLOGUE DGAMR */
/* ***PURPOSE Compute the reciprocal of the Gamma function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C7A */
/* ***TYPE DOUBLE PRECISION (GAMR-S, DGAMR-D, CGAMR-C) */
/* ***KEYWORDS FNLIB, RECIPROCAL GAMMA FUNCTION, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* DGAMR(X) calculates the double precision reciprocal of the */
/* complete Gamma function for double precision argument X. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED DGAMMA, DLGAMS, XERCLR, XGETF, XSETF */
/* ***REVISION HISTORY (YYMMDD) */
/* 770701 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890531 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900727 Added EXTERNAL statement. (WRB) */
/* ***END PROLOGUE DGAMR */
/* ***FIRST EXECUTABLE STATEMENT DGAMR */
ret_val = 0.;
if (*x <= 0. && d_int(x) == *x) {
return ret_val;
}
// xgetf_(&irold);
// xsetf_(&c__1);
if (abs(*x) > 10.) {
goto L10;
}
ret_val = 1. / dgamma_(x);
// xerclr_();
// xsetf_(&irold);
return ret_val;
L10:
dlgams_(x, &alngx, &sgngx);
// xerclr_();
// xsetf_(&irold);
ret_val = sgngx * exp(-alngx);
return ret_val;
} /* dgamr_ */
/* DECK DCHU */
doublereal dchu_(doublereal *a, doublereal *b, doublereal *x)
{
/* Initialized data */
static doublereal pi = 3.141592653589793238462643383279503;
static doublereal eps = 0.;
/* System generated locals */
integer i__1;
doublereal ret_val, d__1, d__2, d__3;
/* Local variables */
static integer i__, m, n;
static doublereal t, a0, b0, c0, xi, xn, xi1, sum, beps, alnx, pch1i;
extern doublereal d9chu_(doublereal *, doublereal *, doublereal *);
static doublereal xeps1;
extern doublereal dgamr_(doublereal *);
static doublereal aintb;
extern doublereal dpoch_(doublereal *, doublereal *), d1mach_(integer *);
static doublereal pch1ai;
static integer istrt;
extern doublereal dpoch1_(doublereal *, doublereal *);
static doublereal gamri1;
extern doublereal dgamma_(doublereal *);
static doublereal pochai, gamrni, factor;
extern doublereal dexprl_(doublereal *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
static doublereal xtoeps;
/* ***BEGIN PROLOGUE DCHU */
/* ***PURPOSE Compute the logarithmic confluent hypergeometric function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C11 */
/* ***TYPE DOUBLE PRECISION (CHU-S, DCHU-D) */
/* ***KEYWORDS FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION, */
/* SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* DCHU(A,B,X) calculates the double precision logarithmic confluent */
/* hypergeometric function U(A,B,X) for double precision arguments */
/* A, B, and X. */
/* This routine is not valid when 1+A-B is close to zero if X is small. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED D1MACH, D9CHU, DEXPRL, DGAMMA, DGAMR, DPOCH, */
/* DPOCH1, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770801 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890531 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900727 Added EXTERNAL statement. (WRB) */
/* ***END PROLOGUE DCHU */
/* ***FIRST EXECUTABLE STATEMENT DCHU */
if (eps == 0.) {
eps = d1mach_(&c__3);
}
if (*x == 0.) {
xermsg_("SLATEC", "DCHU", "X IS ZERO SO DCHU IS INFINITE", &c__1, &
c__2, (ftnlen)6, (ftnlen)4, (ftnlen)29);
}
if (*x < 0.) {
xermsg_("SLATEC", "DCHU", "X IS NEGATIVE, USE CCHU", &c__2, &c__2, (
ftnlen)6, (ftnlen)4, (ftnlen)23);
}
/* Computing MAX */
d__2 = abs(*a);
/* Computing MAX */
d__3 = (d__1 = *a + 1. - *b, abs(d__1));
if (max(d__2,1.) * max(d__3,1.) < abs(*x) * .99) {
goto L120;
}
/* THE ASCENDING SERIES WILL BE USED, BECAUSE THE DESCENDING RATIONAL */
/* APPROXIMATION (WHICH IS BASED ON THE ASYMPTOTIC SERIES) IS UNSTABLE. */
if ((d__1 = *a + 1. - *b, abs(d__1)) < sqrt(eps)) {
xermsg_("SLATEC", "DCHU", "ALGORITHMIS BAD WHEN 1+A-B IS NEAR ZERO F"
"OR SMALL X", &c__10, &c__2, (ftnlen)6, (ftnlen)4, (ftnlen)51);
}
if (*b >= 0.) {
d__1 = *b + .5;
aintb = d_int(&d__1);
}
if (*b < 0.) {
d__1 = *b - .5;
aintb = d_int(&d__1);
}
beps = *b - aintb;
n = (integer) aintb;
alnx = log(*x);
xtoeps = exp(-beps * alnx);
/* EVALUATE THE FINITE SUM. ----------------------------------------- */
if (n >= 1) {
goto L40;
}
/* CONSIDER THE CASE B .LT. 1.0 FIRST. */
sum = 1.;
if (n == 0) {
goto L30;
}
t = 1.;
m = -n;
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
xi1 = (doublereal) (i__ - 1);
t = t * (*a + xi1) * *x / ((*b + xi1) * (xi1 + 1.));
sum += t;
/* L20: */
}
L30:
d__1 = *a + 1. - *b;
d__2 = -(*a);
sum = dpoch_(&d__1, &d__2) * sum;
goto L70;
/* NOW CONSIDER THE CASE B .GE. 1.0. */
L40:
sum = 0.;
m = n - 2;
if (m < 0) {
goto L70;
}
t = 1.;
sum = 1.;
if (m == 0) {
goto L60;
}
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
xi = (doublereal) i__;
t = t * (*a - *b + xi) * *x / ((1. - *b + xi) * xi);
sum += t;
/* L50: */
}
L60:
d__1 = *b - 1.;
i__1 = 1 - n;
sum = dgamma_(&d__1) * dgamr_(a) * pow_di(x, &i__1) * xtoeps * sum;
/* NEXT EVALUATE THE INFINITE SUM. ---------------------------------- */
L70:
istrt = 0;
if (n < 1) {
istrt = 1 - n;
}
xi = (doublereal) istrt;
d__1 = *a + 1. - *b;
factor = pow_di(&c_b25, &n) * dgamr_(&d__1) * pow_di(x, &istrt);
if (beps != 0.) {
factor = factor * beps * pi / sin(beps * pi);
}
pochai = dpoch_(a, &xi);
d__1 = xi + 1.;
gamri1 = dgamr_(&d__1);
d__1 = aintb + xi;
gamrni = dgamr_(&d__1);
d__1 = xi - beps;
d__2 = xi + 1. - beps;
b0 = factor * dpoch_(a, &d__1) * gamrni * dgamr_(&d__2);
if ((d__1 = xtoeps - 1., abs(d__1)) > .5) {
goto L90;
}
/* X**(-BEPS) IS CLOSE TO 1.0D0, SO WE MUST BE CAREFUL IN EVALUATING THE */
/* DIFFERENCES. */
d__1 = *a + xi;
d__2 = -beps;
pch1ai = dpoch1_(&d__1, &d__2);
d__1 = xi + 1. - beps;
pch1i = dpoch1_(&d__1, &beps);
d__1 = *b + xi;
d__2 = -beps;
c0 = factor * pochai * gamrni * gamri1 * (-dpoch1_(&d__1, &d__2) + pch1ai
- pch1i + beps * pch1ai * pch1i);
/* XEPS1 = (1.0 - X**(-BEPS))/BEPS = (X**(-BEPS) - 1.0)/(-BEPS) */
d__1 = -beps * alnx;
xeps1 = alnx * dexprl_(&d__1);
ret_val = sum + c0 + xeps1 * b0;
xn = (doublereal) n;
for (i__ = 1; i__ <= 1000; ++i__) {
xi = (doublereal) (istrt + i__);
xi1 = (doublereal) (istrt + i__ - 1);
b0 = (*a + xi1 - beps) * b0 * *x / ((xn + xi1) * (xi - beps));
c0 = (*a + xi1) * c0 * *x / ((*b + xi1) * xi) - ((*a - 1.) * (xn + xi
* 2. - 1.) + xi * (xi - beps)) * b0 / (xi * (*b + xi1) * (*a
+ xi1 - beps));
t = c0 + xeps1 * b0;
ret_val += t;
if (abs(t) < eps * abs(ret_val)) {
goto L130;
}
/* L80: */
}
xermsg_("SLATEC", "DCHU", "NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING"
" SERIES", &c__3, &c__2, (ftnlen)6, (ftnlen)4, (ftnlen)52);
/* X**(-BEPS) IS VERY DIFFERENT FROM 1.0, SO THE STRAIGHTFORWARD */
/* FORMULATION IS STABLE. */
L90:
d__1 = *b + xi;
a0 = factor * pochai * dgamr_(&d__1) * gamri1 / beps;
b0 = xtoeps * b0 / beps;
ret_val = sum + a0 - b0;
for (i__ = 1; i__ <= 1000; ++i__) {
xi = (doublereal) (istrt + i__);
xi1 = (doublereal) (istrt + i__ - 1);
a0 = (*a + xi1) * a0 * *x / ((*b + xi1) * xi);
b0 = (*a + xi1 - beps) * b0 * *x / ((aintb + xi1) * (xi - beps));
t = a0 - b0;
ret_val += t;
if (abs(t) < eps * abs(ret_val)) {
goto L130;
}
/* L100: */
}
xermsg_("SLATEC", "DCHU", "NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING"
" SERIES", &c__3, &c__2, (ftnlen)6, (ftnlen)4, (ftnlen)52);
/* USE LUKE-S RATIONAL APPROXIMATION IN THE ASYMPTOTIC REGION. */
L120:
d__1 = -(*a);
ret_val = pow_dd(x, &d__1) * d9chu_(a, b, x);
L130:
return ret_val;
} /* dchu_ */
/* DECK DGAMIC */
doublereal dgamic_(doublereal *a, doublereal *x)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
doublereal ret_val, d__1;
/* Local variables */
static doublereal e, h__, t, sga, alx, bot, eps, aeps, sgng, ainta, alngs,
gstar, sgngs;
static integer izero;
static doublereal sqeps;
extern doublereal d1mach_(integer *);
static doublereal algap1;
extern doublereal d9lgic_(doublereal *, doublereal *, doublereal *),
d9gmic_(doublereal *, doublereal *, doublereal *), d9lgit_(
doublereal *, doublereal *, doublereal *), d9gmit_(doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), dlngam_(
doublereal *);
extern /* Subroutine */ int dlgams_(doublereal *, doublereal *,
doublereal *);
static doublereal sgngam, alneps;
extern /* Subroutine */ int xerclr_(void), xermsg_(char *, char *, char *,
integer *, integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE DGAMIC */
/* ***PURPOSE Calculate the complementary incomplete Gamma function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C7E */
/* ***TYPE DOUBLE PRECISION (GAMIC-S, DGAMIC-D) */
/* ***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, */
/* SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* Evaluate the complementary incomplete Gamma function */
/* DGAMIC = integral from X to infinity of EXP(-T) * T**(A-1.) . */
/* DGAMIC is evaluated for arbitrary real values of A and for non- */
/* negative values of X (even though DGAMIC is defined for X .LT. */
/* 0.0), except that for X = 0 and A .LE. 0.0, DGAMIC is undefined. */
/* DGAMIC, A, and X are DOUBLE PRECISION. */
/* A slight deterioration of 2 or 3 digits accuracy will occur when */
/* DGAMIC is very large or very small in absolute value, because log- */
/* arithmic variables are used. Also, if the parameter A is very close */
/* to a negative INTEGER (but not a negative integer), there is a loss */
/* of accuracy, which is reported if the result is less than half */
/* machine precision. */
/* ***REFERENCES W. Gautschi, A computational procedure for incomplete */
/* gamma functions, ACM Transactions on Mathematical */
/* Software 5, 4 (December 1979), pp. 466-481. */
/* W. Gautschi, Incomplete gamma functions, Algorithm 542, */
/* ACM Transactions on Mathematical Software 5, 4 */
/* (December 1979), pp. 482-489. */
/* ***ROUTINES CALLED D1MACH, D9GMIC, D9GMIT, D9LGIC, D9LGIT, DLGAMS, */
/* DLNGAM, XERCLR, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770701 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890531 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 920528 DESCRIPTION and REFERENCES sections revised. (WRB) */
/* ***END PROLOGUE DGAMIC */
/* ***FIRST EXECUTABLE STATEMENT DGAMIC */
if (first) {
eps = d1mach_(&c__3) * .5;
sqeps = sqrt(d1mach_(&c__4));
alneps = -log(d1mach_(&c__3));
bot = log(d1mach_(&c__1));
}
first = FALSE_;
if (*x < 0.) {
xermsg_("SLATEC", "DGAMIC", "X IS NEGATIVE", &c__2, &c__2, (ftnlen)6,
(ftnlen)6, (ftnlen)13);
}
if (*x > 0.) {
goto L20;
}
if (*a <= 0.) {
xermsg_("SLATEC", "DGAMIC", "X = 0 AND A LE 0 SO DGAMIC IS UNDEFINED",
&c__3, &c__2, (ftnlen)6, (ftnlen)6, (ftnlen)39);
}
d__1 = *a + 1.;
ret_val = exp(dlngam_(&d__1) - log(*a));
return ret_val;
L20:
alx = log(*x);
sga = 1.;
if (*a != 0.) {
sga = d_sign(&c_b17, a);
}
d__1 = *a + sga * .5;
ainta = d_int(&d__1);
aeps = *a - ainta;
izero = 0;
if (*x >= 1.) {
goto L40;
}
if (*a > .5 || abs(aeps) > .001) {
goto L30;
}
e = 2.;
if (-ainta > 1.) {
e = (-ainta + 2.) * 2. / (ainta * ainta - 1.);
}
e -= alx * pow_dd(x, &c_b20);
if (e * abs(aeps) > eps) {
goto L30;
}
ret_val = d9gmic_(a, x, &alx);
return ret_val;
L30:
d__1 = *a + 1.;
dlgams_(&d__1, &algap1, &sgngam);
gstar = d9gmit_(a, x, &algap1, &sgngam, &alx);
if (gstar == 0.) {
izero = 1;
}
if (gstar != 0.) {
alngs = log((abs(gstar)));
}
if (gstar != 0.) {
sgngs = d_sign(&c_b17, &gstar);
}
goto L50;
L40:
if (*a < *x) {
ret_val = exp(d9lgic_(a, x, &alx));
}
if (*a < *x) {
return ret_val;
}
sgngam = 1.;
d__1 = *a + 1.;
algap1 = dlngam_(&d__1);
sgngs = 1.;
alngs = d9lgit_(a, x, &algap1);
/* EVALUATION OF DGAMIC(A,X) IN TERMS OF TRICOMI-S INCOMPLETE GAMMA FN. */
L50:
h__ = 1.;
if (izero == 1) {
goto L60;
}
t = *a * alx + alngs;
if (t > alneps) {
goto L70;
}
if (t > -alneps) {
h__ = 1. - sgngs * exp(t);
}
if (abs(h__) < sqeps) {
xerclr_();
}
if (abs(h__) < sqeps) {
xermsg_("SLATEC", "DGAMIC", "RESULT LT HALF PRECISION", &c__1, &c__1,
(ftnlen)6, (ftnlen)6, (ftnlen)24);
}
L60:
sgng = d_sign(&c_b17, &h__) * sga * sgngam;
t = log((abs(h__))) + algap1 - log((abs(*a)));
if (t < bot) {
xerclr_();
}
ret_val = sgng * exp(t);
return ret_val;
L70:
sgng = -sgngs * sga * sgngam;
t = t + algap1 - log((abs(*a)));
if (t < bot) {
xerclr_();
}
ret_val = sgng * exp(t);
return ret_val;
} /* dgamic_ */
/* Subroutine */ int geout_(integer *mode1)
{
/* Format strings */
static char fmt_40[] = "(/4x,\002ATOM\002,3x,\002CHEMICAL\002,a,\002BOND"
" LENGTH\002,4x,\002BOND ANGLE\002,4x,\002 TWIST ANGLE\002,/3x"
",\002NUMBER\002,2x,\002SYMBOL\002,a,\002(ANGSTROMS)\002,5x,\002("
"DEGREES)\002,5x,\002 (DEGREES)\002,/4x,\002(I)\002,a,\002NA:I"
"\002,10x,\002NB:NA:I\002,5x,\002 NC:NB:NA:I\002,5x,\002NA\002,3x,"
"\002NB\002,3x,\002NC\002,/)";
/* System generated locals */
address a__1[3];
integer i__1, i__2, i__3, i__4, i__5, i__6, i__7[3];
doublereal d__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
double d_int(doublereal *), d_sign(doublereal *, doublereal *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_wsle(cilist *), e_wsle(void);
/* Local variables */
static integer i__, j, k, l, n;
static char q[2*3];
static doublereal w, x, q2[120];
static integer ia, ii, mode;
static logical cart;
static integer iprt;
static char flag0[2], flag1[2], flagn[2], blank[80];
extern /* Subroutine */ int chrge_(doublereal *, doublereal *);
static doublereal coord[360] /* was [3][120] */, degree;
static integer loctmp[720] /* was [2][360] */, nvartm, maxtxt;
extern /* Subroutine */ int xyzint_(doublereal *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *), wrttxt_(
integer *);
/* Fortran I/O blocks */
static cilist io___15 = { 0, 6, 0, fmt_40, 0 };
static cilist io___25 = { 0, 0, 0, "(1X,A,F11.7,1X,A2,F14.6,1X,A2,F14.6,"
"1X, A2,3I5,A,F7.4)", 0 };
static cilist io___26 = { 0, 0, 0, "(1X,A,F11.7,1X,A2,F14.6,1X,A2,F14.6,"
"1X, A2,3I5)", 0 };
static cilist io___27 = { 0, 6, 0, "(3X,I4 ,5X,A,F9.5,1X,A2,F14.5,1X,A2,"
"F11.5,1X, A2,I4,2I5)", 0 };
static cilist io___28 = { 0, 6, 0, "(' 3',5X,A,F9.5,1X,A2,F14.5,1X,"
"A2,13X, 2I5)", 0 };
static cilist io___29 = { 0, 6, 0, "(' 2',5X,A,F9.5,1X,A2,30X,I5)",
0 };
static cilist io___30 = { 0, 6, 0, "(' 1',5X,A)", 0 };
static cilist io___31 = { 0, 0, 0, 0, 0 };
static cilist io___32 = { 0, 0, 0, "(I4,I3,I5,15I4)", 0 };
static cilist io___33 = { 0, 0, 0, "(I4,I3,I5,15I4)", 0 };
/* ********************************************************************* */
/* GEOUT PRINTS THE CURRENT GEOMETRY. IT CAN BE CALLED ANY TIME, */
/* FROM ANY POINT IN THE PROGRAM AND DOES NOT AFFECT ANYTHING. */
/* ********************************************************************* */
/* COMDECK SIZES */
/* *********************************************************************** */
/* THIS FILE CONTAINS ALL THE ARRAY SIZES FOR USE IN MOPAC. */
/* THERE ARE ONLY 5 PARAMETERS THAT THE PROGRAMMER NEED SET: */
/* MAXHEV = MAXIMUM NUMBER OF HEAVY ATOMS (HEAVY: NON-HYDROGEN ATOMS) */
/* MAXLIT = MAXIMUM NUMBER OF HYDROGEN ATOMS. */
/* MAXTIM = DEFAULT TIME FOR A JOB. (SECONDS) */
/* MAXDMP = DEFAULT TIME FOR AUTOMATIC RESTART FILE GENERATION (SECS) */
/* ISYBYL = 1 IF MOPAC IS TO BE USED IN THE SYBYL PACKAGE, =0 OTHERWISE */
/* SEE ALSO NMECI, NPULAY AND MESP AT THE END OF THIS FILE */
/* *********************************************************************** */
/* THE FOLLOWING CODE DOES NOT NEED TO BE ALTERED BY THE PROGRAMMER */
/* *********************************************************************** */
/* ALL OTHER PARAMETERS ARE DERIVED FUNCTIONS OF THESE TWO PARAMETERS */
/* NAME DEFINITION */
/* NUMATM MAXIMUM NUMBER OF ATOMS ALLOWED. */
/* MAXORB MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXPAR MAXIMUM NUMBER OF PARAMETERS FOR OPTIMISATION. */
/* N2ELEC MAXIMUM NUMBER OF TWO ELECTRON INTEGRALS ALLOWED. */
/* MPACK AREA OF LOWER HALF TRIANGLE OF DENSITY MATRIX. */
/* MORB2 SQUARE OF THE MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXHES AREA OF HESSIAN MATRIX */
/* MAXALL LARGER THAN MAXORB OR MAXPAR. */
/* *********************************************************************** */
/* *********************************************************************** */
/* DECK MOPAC */
mode = *mode1;
if (mode == 1) {
s_copy(flag1, " *", (ftnlen)2, (ftnlen)2);
s_copy(flag0, " ", (ftnlen)2, (ftnlen)2);
s_copy(flagn, " +", (ftnlen)2, (ftnlen)2);
iprt = 6;
} else {
s_copy(flag1, " 1", (ftnlen)2, (ftnlen)2);
s_copy(flag0, " 0", (ftnlen)2, (ftnlen)2);
s_copy(flagn, "-1", (ftnlen)2, (ftnlen)2);
iprt = abs(mode);
}
/* *** OUTPUT THE PARAMETER DATA. */
cart = FALSE_;
if (geokst_1.na[0] != 0) {
cart = TRUE_;
xyzint_(geom_1.geo, &geokst_1.natoms, geokst_1.na, geokst_1.nb,
geokst_1.nc, &c_b8, coord);
loctmp[0] = 2;
loctmp[1] = 1;
loctmp[2] = 3;
loctmp[3] = 1;
loctmp[4] = 3;
loctmp[5] = 2;
nvartm = 0;
i__1 = geokst_1.natoms;
for (i__ = 4; i__ <= i__1; ++i__) {
nvartm += 3;
for (j = 1; j <= 3; ++j) {
loctmp[(nvartm + j << 1) - 2] = i__;
/* L10: */
loctmp[(nvartm + j << 1) - 1] = j;
}
}
nvartm += 3;
} else {
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
loctmp[(i__ << 1) - 2] = geovar_1.loc[(i__ << 1) - 2];
/* L20: */
loctmp[(i__ << 1) - 1] = geovar_1.loc[(i__ << 1) - 1];
}
nvartm = geovar_1.nvar;
for (j = 1; j <= 3; ++j) {
/* $DOUT VBEST */
i__1 = geokst_1.natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L30: */
coord[j + i__ * 3 - 4] = geom_1.geo[j + i__ * 3 - 4];
}
}
}
degree = 57.29577951;
maxtxt = *(unsigned char *)atomtx_1.ltxt;
s_copy(blank, " ", (ftnlen)80, (ftnlen)1);
if (mode == 1) {
s_wsfe(&io___15);
/* Computing MAX */
i__1 = 2, i__2 = maxtxt - 4;
do_fio(&c__1, blank, (max(i__1,i__2)));
/* Computing MAX */
i__3 = 4, i__4 = maxtxt - 2;
do_fio(&c__1, blank, (max(i__3,i__4)));
/* Computing MAX */
i__5 = 18, i__6 = maxtxt + 12;
do_fio(&c__1, blank, (max(i__5,i__6)));
e_wsfe();
} else {
if (mode > 0) {
wrttxt_(&iprt);
}
}
if (mode != 1) {
chrge_(densty_1.p, q2);
i__1 = molkst_1.numat;
for (i__ = 1; i__ <= i__1; ++i__) {
l = molkst_1.nat[i__ - 1];
/* L50: */
q2[i__ - 1] = core_1.core[l - 1] - q2[i__ - 1];
}
}
n = 1;
ia = loctmp[0];
ii = 0;
i__1 = geokst_1.natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
s_copy(q + (j - 1 << 1), flag0, (ftnlen)2, (ftnlen)2);
if (ia != i__) {
goto L60;
}
if (j != loctmp[(n << 1) - 1] || n > nvartm) {
goto L60;
}
s_copy(q + (j - 1 << 1), flag1, (ftnlen)2, (ftnlen)2);
++n;
ia = loctmp[(n << 1) - 2];
L60:
;
}
w = coord[i__ * 3 - 2] * degree;
x = coord[i__ * 3 - 1] * degree;
/* CONSTRAIN ANGLE TO DOMAIN 0 - 180 DEGREES */
d__1 = w / 360.;
w -= d_int(&d__1) * 360.;
if (w < 0.) {
w += 360.;
}
if (w > 180.) {
x += 180.;
w = 360. - w;
}
/* CONSTRAIN DIHEDRAL TO DOMAIN -180 - 180 DEGREES */
d__1 = x / 360. + d_sign(&c_b21, &x) - 1e-9;
x -= d_int(&d__1) * 360.;
if (path_1.latom != i__) {
goto L70;
}
j = path_1.lparam;
s_copy(q + (j - 1 << 1), flagn, (ftnlen)2, (ftnlen)2);
L70:
/* Writing concatenation */
i__7[0] = 2, a__1[0] = elemts_1.elemnt + (geokst_1.labels[i__ - 1] -
1 << 1);
i__7[1] = 8, a__1[1] = atomtx_1.txtatm + (i__ - 1 << 3);
i__7[2] = 2, a__1[2] = " ";
s_cat(blank, a__1, i__7, &c__3, (ftnlen)80);
if (mode != 1) {
/* Computing MAX */
i__2 = 4, i__3 = maxtxt + 2;
j = max(i__2,i__3);
/* Computing MAX */
i__2 = 0, i__3 = 8 - j;
k = max(i__2,i__3);
} else {
/* Computing MAX */
i__2 = 9, i__3 = maxtxt + 3;
j = max(i__2,i__3);
}
if (geokst_1.labels[i__ - 1] != 0) {
if (mode != 1) {
if (geokst_1.labels[i__ - 1] != 99 && geokst_1.labels[i__ - 1]
!= 107) {
++ii;
io___25.ciunit = iprt;
s_wsfe(&io___25);
do_fio(&c__1, blank, j);
do_fio(&c__1, (char *)&coord[i__ * 3 - 3], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, q, (ftnlen)2);
do_fio(&c__1, (char *)&w, (ftnlen)sizeof(doublereal));
do_fio(&c__1, q + 2, (ftnlen)2);
do_fio(&c__1, (char *)&x, (ftnlen)sizeof(doublereal));
do_fio(&c__1, q + 4, (ftnlen)2);
do_fio(&c__1, (char *)&geokst_1.na[i__ - 1], (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&geokst_1.nb[i__ - 1], (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&geokst_1.nc[i__ - 1], (ftnlen)
sizeof(integer));
do_fio(&c__1, blank + 19, k + 1);
do_fio(&c__1, (char *)&q2[ii - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
} else {
io___26.ciunit = iprt;
s_wsfe(&io___26);
do_fio(&c__1, blank, j);
do_fio(&c__1, (char *)&coord[i__ * 3 - 3], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, q, (ftnlen)2);
do_fio(&c__1, (char *)&w, (ftnlen)sizeof(doublereal));
do_fio(&c__1, q + 2, (ftnlen)2);
do_fio(&c__1, (char *)&x, (ftnlen)sizeof(doublereal));
do_fio(&c__1, q + 4, (ftnlen)2);
do_fio(&c__1, (char *)&geokst_1.na[i__ - 1], (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&geokst_1.nb[i__ - 1], (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&geokst_1.nc[i__ - 1], (ftnlen)
sizeof(integer));
e_wsfe();
}
} else if (i__ > 3) {
s_wsfe(&io___27);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, blank, j);
do_fio(&c__1, (char *)&coord[i__ * 3 - 3], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, q, (ftnlen)2);
do_fio(&c__1, (char *)&w, (ftnlen)sizeof(doublereal));
do_fio(&c__1, q + 2, (ftnlen)2);
do_fio(&c__1, (char *)&x, (ftnlen)sizeof(doublereal));
do_fio(&c__1, q + 4, (ftnlen)2);
do_fio(&c__1, (char *)&geokst_1.na[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&geokst_1.nb[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&geokst_1.nc[i__ - 1], (ftnlen)sizeof(
integer));
e_wsfe();
} else if (i__ == 3) {
s_wsfe(&io___28);
do_fio(&c__1, blank, j);
do_fio(&c__1, (char *)&coord[6], (ftnlen)sizeof(doublereal));
do_fio(&c__1, q, (ftnlen)2);
do_fio(&c__1, (char *)&w, (ftnlen)sizeof(doublereal));
do_fio(&c__1, q + 2, (ftnlen)2);
do_fio(&c__1, (char *)&geokst_1.na[2], (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&geokst_1.nb[2], (ftnlen)sizeof(integer)
);
e_wsfe();
} else if (i__ == 2) {
s_wsfe(&io___29);
do_fio(&c__1, blank, j);
do_fio(&c__1, (char *)&coord[3], (ftnlen)sizeof(doublereal));
do_fio(&c__1, q, (ftnlen)2);
do_fio(&c__1, (char *)&geokst_1.na[1], (ftnlen)sizeof(integer)
);
e_wsfe();
} else {
s_wsfe(&io___30);
do_fio(&c__1, blank, j);
e_wsfe();
}
}
/* L80: */
}
if (cart) {
geokst_1.na[0] = 99;
}
if (mode == 1) {
return 0;
}
io___31.ciunit = iprt;
s_wsle(&io___31);
e_wsle();
if (geosym_1.ndep == 0) {
return 0;
}
/* OUTPUT SYMMETRY DATA. */
i__ = 1;
L90:
j = i__;
L100:
if (j == geosym_1.ndep) {
goto L110;
}
if (geosym_1.locpar[j - 1] == geosym_1.locpar[j] && geosym_1.idepfn[j - 1]
== geosym_1.idepfn[j] && j - i__ < 15) {
++j;
goto L100;
} else {
io___32.ciunit = iprt;
s_wsfe(&io___32);
do_fio(&c__1, (char *)&geosym_1.locpar[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&geosym_1.idepfn[i__ - 1], (ftnlen)sizeof(
integer));
i__1 = j;
for (k = i__; k <= i__1; ++k) {
do_fio(&c__1, (char *)&geosym_1.locdep[k - 1], (ftnlen)sizeof(
integer));
}
e_wsfe();
}
i__ = j + 1;
goto L90;
L110:
io___33.ciunit = iprt;
s_wsfe(&io___33);
do_fio(&c__1, (char *)&geosym_1.locpar[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&geosym_1.idepfn[i__ - 1], (ftnlen)sizeof(integer));
i__1 = j;
for (k = i__; k <= i__1; ++k) {
do_fio(&c__1, (char *)&geosym_1.locdep[k - 1], (ftnlen)sizeof(integer)
);
}
e_wsfe();
return 0;
} /* geout_ */
