Пример #1
0
/* 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_ */
Пример #2
0
/* 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_ */
Пример #3
0
/* $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_ */
Пример #4
0
/* ----------------------------------------------------------------------| */
/* 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_ */
Пример #5
0
/*<       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_ */
Пример #7
0
/* 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_ */
Пример #8
0
/* 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_ */
Пример #9
0
/* 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_ */