示例#1
0
文件: spke21.c 项目: Dbelsa/coft
/* $Procedure      SPKE21 ( S/P Kernel, evaluate, type 21 ) */
/* Subroutine */ int spke21_(doublereal *et, doublereal *record, doublereal *
	state)
{
    /* Initialized data */

    static doublereal fc[25] = { 1. };

    /* System generated locals */
    integer i__1, i__2, i__3, i__4, i__5, i__6;

    /* Builtin functions */
    integer i_dnnt(doublereal *), s_rnge(char *, integer, char *, integer);

    /* Local variables */
    static doublereal g[25];
    static integer i__, j;
    static doublereal w[27], delta;
    extern /* Subroutine */ int chkin_(char *, ftnlen), moved_(doublereal *, 
	    integer *, doublereal *);
    static integer kqmax1;
    static doublereal dt[75]	/* was [25][3] */, wc[24];
    static integer kq[3], ks;
    static doublereal tl;
    static integer jx;
    static doublereal tp;
    static integer maxdim;
    static doublereal refvel[3];
    extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen);
    static doublereal refpos[3];
    extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *, 
	    integer *, ftnlen);
    extern logical return_(void);
    static integer mq2, ks1, kqq;
    static doublereal sum;

/* $ Abstract */

/*     Evaluate a single SPK data record from a segment of type 21 */
/*     (Extended Difference Lines). */

/* $ 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 */

/*     SPK */
/*     TIME */

/* $ Keywords */

/*     EPHEMERIS */

/* $ Declarations */
/* $ Abstract */

/*     Declare parameters specific to SPK type 21. */

/* $ 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 */

/*     SPK */

/* $ Keywords */

/*     SPK */

/* $ Restrictions */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman      (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 25-DEC-2013 (NJB) */

/* -& */

/*     MAXTRM      is the maximum number of terms allowed in each */
/*                 component of the difference table contained in a type */
/*                 21 SPK difference line. MAXTRM replaces the fixed */
/*                 table parameter value of 15 used in SPK type 1 */
/*                 segments. */

/*                 Type 21 segments have variable size. Let MAXDIM be */
/*                 the dimension of each component of the difference */
/*                 table within each difference line. Then the size */
/*                 DLSIZE of the difference line is */

/*                    ( 4 * MAXDIM ) + 11 */

/*                 MAXTRM is the largest allowed value of MAXDIM. */



/*     End of include file spk21.inc. */

/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     ET         I   Evaluation epoch. */
/*     RECORD     I   Data record. */
/*     STATE      O   State (position and velocity). */
/*     MAXTRM     P   Maximum number of terms per difference table */
/*                    component. */

/* $ Detailed_Input */

/*     ET          is an epoch at which a state vector is to be */
/*                 computed. The epoch is represented as seconds past */
/*                 J2000 TDB. */

/*     RECORD      is a data record which, when evaluated at epoch ET, */
/*                 will give the state (position and velocity) of an */
/*                 ephemeris object, relative to its center of motion, */
/*                 in an inertial reference frame. */

/*                 The contents of RECORD are as follows: */

/*                    RECORD(1):         The difference table size per */
/*                                       Cartesian component. Call this */
/*                                       size MAXDIM; then the difference */
/*                                       line (MDA) size DLSIZE is */

/*                                         ( 4 * MAXDIM ) + 11 */

/*                    RECORD(2) */
/*                       ... */
/*                    RECORD(1+DLSIZE):  An extended difference line. */
/*                                       The contents are: */

/*                       Dimension  Description */
/*                       ---------  ---------------------------------- */
/*                       1          Reference epoch of difference line */
/*                       MAXDIM     Stepsize function vector */
/*                       1          Reference position vector,  x */
/*                       1          Reference velocity vector,  x */
/*                       1          Reference position vector,  y */
/*                       1          Reference velocity vector,  y */
/*                       1          Reference position vector,  z */
/*                       1          Reference velocity vector,  z */
/*                       MAXDIM,3   Modified divided difference */
/*                                  arrays (MDAs) */
/*                       1          Maximum integration order plus 1 */
/*                       3          Integration order array */

/* $ Detailed_Output */

/*     STATE       is the state resulting from evaluation of the input */
/*                 record at ET. Units are km and km/sec. */

/* $ Parameters */

/*     MAXTRM      is the maximum number of terms allowed in */
/*                 each component of the difference table */
/*                 contained in the input argument RECORD. */
/*                 See the INCLUDE file spk21.inc for the value */
/*                 of MAXTRM. */

/* $ Exceptions */

/*     1) If the maximum table size of the input record exceeds */
/*        MAXTRM, the error SPICE(DIFFLINETOOLARGE) is signaled. */

/* $ Files */

/*     None. */

/* $ Particulars */

/*     The exact format and structure of type 21 (difference lines) */
/*     segments are described in the SPK Required Reading file. */

/*     SPKE21 is a modified version of SPKE01. The routine has been */
/*     generalized to support variable size difference lines. */

/* $ Examples */

/*     None. */

/* $ Restrictions */

/*     Unknown. */

/* $ Literature_References */

/*     NAIF Document 168.0, "S- and P- Kernel (SPK) Specification and */
/*     User's Guide" */

/* $ Author_and_Institution */

/*     N.J. Bachman    (JPL) */
/*     F.T. Krogh      (JPL) */
/*     W.L. Taber      (JPL) */
/*     I.M. Underwood  (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 03-FEB-2014 (NJB) (FTK) (WLT) (IMU) */

/* -& */
/* $ Index_Entries */

/*     evaluate type_21 spk segment */

/* -& */

/*     SPICELIB functions */


/*     Local parameters */


/*     Local variables */

/*     The names below are original to the routine. They correspond */
/*     roughly to the original memos written by Fred Krogh to explain */
/*     how all this stuff really works. */


/*     Save everything between calls. */


/*     Initial values */


/*     Use discovery check-in. */

/*     If the RETURN function is set, don't even bother with this. */

    if (return_()) {
	return 0;
    }

/*     The first element of the input record is the dimension */
/*     of the difference table MAXDIM. */

    maxdim = i_dnnt(record);
    if (maxdim > 25) {
	chkin_("SPKE21", (ftnlen)6);
	setmsg_("The input record has a maximum table dimension of #, while "
		"the maximum supported by this routine is #. It is possible t"
		"hat this problem is due to your SPICE Toolkit being out of d"
		"ate.", (ftnlen)183);
	errint_("#", &maxdim, (ftnlen)1);
	errint_("#", &c__25, (ftnlen)1);
	sigerr_("SPICE(DIFFLINETOOLARGE)", (ftnlen)23);
	chkout_("SPKE21", (ftnlen)6);
	return 0;
    }

/*     Unpack the contents of the MDA array. */

/*        Name     Dimension  Description */
/*        ------   ---------  ------------------------------- */
/*        TL               1  Reference epoch of record */
/*        G           MAXDIM  Stepsize function vector */
/*        REFPOS           3  Reference position vector */
/*        REFVEL           3  Reference velocity vector */
/*        DT      MAXDIM,NTE  Modified divided difference arrays */
/*        KQMAX1           1  Maximum integration order plus 1 */
/*        KQ             NTE  Integration order array */

/*     For our purposes, NTE is always 3. */

    moved_(&record[1], &c__1, &tl);
    moved_(&record[2], &maxdim, g);

/*     Collect the reference position and velocity. */

    refpos[0] = record[maxdim + 2];
    refvel[0] = record[maxdim + 3];
    refpos[1] = record[maxdim + 4];
    refvel[1] = record[maxdim + 5];
    refpos[2] = record[maxdim + 6];
    refvel[2] = record[maxdim + 7];

/*     Initializing the difference table is one aspect of this routine */
/*     that's a bit different from SPKE01. Here the first dimension of */
/*     the table in the input record can be smaller than MAXTRM. So, we */
/*     must transfer separately the portions of the table corresponding */
/*     to each component. */

    for (i__ = 1; i__ <= 3; ++i__) {
	moved_(&record[i__ * maxdim + 8], &maxdim, &dt[(i__1 = i__ * 25 - 25) 
		< 75 && 0 <= i__1 ? i__1 : s_rnge("dt", i__1, "spke21_", (
		ftnlen)289)]);
    }
    kqmax1 = (integer) record[(maxdim << 2) + 8];
    kq[0] = (integer) record[(maxdim << 2) + 9];
    kq[1] = (integer) record[(maxdim << 2) + 10];
    kq[2] = (integer) record[(maxdim << 2) + 11];

/*     Next we set up for the computation of the various differences */

    delta = *et - tl;
    tp = delta;
    mq2 = kqmax1 - 2;
    ks = kqmax1 - 1;

/*     This is clearly collecting some kind of coefficients. */
/*     The problem is that we have no idea what they are... */

/*     The G coefficients are supposed to be some kind of step size */
/*     vector. */

/*     TP starts out as the delta t between the request time and the */
/*     difference line's reference epoch. We then change it from DELTA */
/*     by the components of the stepsize vector G. */

    i__1 = mq2;
    for (j = 1; j <= i__1; ++j) {

/*        Make sure we're not about to attempt division by zero. */

	if (g[(i__2 = j - 1) < 25 && 0 <= i__2 ? i__2 : s_rnge("g", i__2, 
		"spke21_", (ftnlen)320)] == 0.) {
	    chkin_("SPKE21", (ftnlen)6);
	    setmsg_("A  value of zero was found at index # of the step size "
		    "vector.", (ftnlen)62);
	    errint_("#", &j, (ftnlen)1);
	    sigerr_("SPICE(ZEROSTEP)", (ftnlen)15);
	    chkout_("SPKE21", (ftnlen)6);
	    return 0;
	}
	fc[(i__2 = j) < 25 && 0 <= i__2 ? i__2 : s_rnge("fc", i__2, "spke21_",
		 (ftnlen)332)] = tp / g[(i__3 = j - 1) < 25 && 0 <= i__3 ? 
		i__3 : s_rnge("g", i__3, "spke21_", (ftnlen)332)];
	wc[(i__2 = j - 1) < 24 && 0 <= i__2 ? i__2 : s_rnge("wc", i__2, "spk"
		"e21_", (ftnlen)333)] = delta / g[(i__3 = j - 1) < 25 && 0 <= 
		i__3 ? i__3 : s_rnge("g", i__3, "spke21_", (ftnlen)333)];
	tp = delta + g[(i__2 = j - 1) < 25 && 0 <= i__2 ? i__2 : s_rnge("g", 
		i__2, "spke21_", (ftnlen)334)];
    }

/*     Collect KQMAX1 reciprocals. */

    i__1 = kqmax1;
    for (j = 1; j <= i__1; ++j) {
	w[(i__2 = j - 1) < 27 && 0 <= i__2 ? i__2 : s_rnge("w", i__2, "spke2"
		"1_", (ftnlen)342)] = 1. / (doublereal) j;
    }

/*     Compute the W(K) terms needed for the position interpolation */
/*     (Note,  it is assumed throughout this routine that KS, which */
/*     starts out as KQMAX1-1 (the ``maximum integration'') */
/*     is at least 2. */

    jx = 0;
    ks1 = ks - 1;
    while(ks >= 2) {
	++jx;
	i__1 = jx;
	for (j = 1; j <= i__1; ++j) {
	    w[(i__2 = j + ks - 1) < 27 && 0 <= i__2 ? i__2 : s_rnge("w", i__2,
		     "spke21_", (ftnlen)359)] = fc[(i__3 = j) < 25 && 0 <= 
		    i__3 ? i__3 : s_rnge("fc", i__3, "spke21_", (ftnlen)359)] 
		    * w[(i__4 = j + ks1 - 1) < 27 && 0 <= i__4 ? i__4 : 
		    s_rnge("w", i__4, "spke21_", (ftnlen)359)] - wc[(i__5 = j 
		    - 1) < 24 && 0 <= i__5 ? i__5 : s_rnge("wc", i__5, "spke"
		    "21_", (ftnlen)359)] * w[(i__6 = j + ks - 1) < 27 && 0 <= 
		    i__6 ? i__6 : s_rnge("w", i__6, "spke21_", (ftnlen)359)];
	}
	ks = ks1;
	--ks1;
    }

/*     Perform position interpolation: (Note that KS = 1 right now. */
/*     We don't know much more than that.) */

    for (i__ = 1; i__ <= 3; ++i__) {
	kqq = kq[(i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("kq", i__1,
		 "spke21_", (ftnlen)373)];
	sum = 0.;
	for (j = kqq; j >= 1; --j) {
	    sum += dt[(i__1 = j + i__ * 25 - 26) < 75 && 0 <= i__1 ? i__1 : 
		    s_rnge("dt", i__1, "spke21_", (ftnlen)377)] * w[(i__2 = j 
		    + ks - 1) < 27 && 0 <= i__2 ? i__2 : s_rnge("w", i__2, 
		    "spke21_", (ftnlen)377)];
	}
	state[(i__1 = i__ - 1) < 6 && 0 <= i__1 ? i__1 : s_rnge("state", i__1,
		 "spke21_", (ftnlen)380)] = refpos[(i__2 = i__ - 1) < 3 && 0 
		<= i__2 ? i__2 : s_rnge("refpos", i__2, "spke21_", (ftnlen)
		380)] + delta * (refvel[(i__3 = i__ - 1) < 3 && 0 <= i__3 ? 
		i__3 : s_rnge("refvel", i__3, "spke21_", (ftnlen)380)] + 
		delta * sum);
    }

/*     Again we need to compute the W(K) coefficients that are */
/*     going to be used in the velocity interpolation. */
/*     (Note, at this point, KS = 1, KS1 = 0.) */

    i__1 = jx;
    for (j = 1; j <= i__1; ++j) {
	w[(i__2 = j + ks - 1) < 27 && 0 <= i__2 ? i__2 : s_rnge("w", i__2, 
		"spke21_", (ftnlen)390)] = fc[(i__3 = j) < 25 && 0 <= i__3 ? 
		i__3 : s_rnge("fc", i__3, "spke21_", (ftnlen)390)] * w[(i__4 =
		 j + ks1 - 1) < 27 && 0 <= i__4 ? i__4 : s_rnge("w", i__4, 
		"spke21_", (ftnlen)390)] - wc[(i__5 = j - 1) < 24 && 0 <= 
		i__5 ? i__5 : s_rnge("wc", i__5, "spke21_", (ftnlen)390)] * w[
		(i__6 = j + ks - 1) < 27 && 0 <= i__6 ? i__6 : s_rnge("w", 
		i__6, "spke21_", (ftnlen)390)];
    }
    --ks;

/*     Perform velocity interpolation: */

    for (i__ = 1; i__ <= 3; ++i__) {
	kqq = kq[(i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("kq", i__1,
		 "spke21_", (ftnlen)400)];
	sum = 0.;
	for (j = kqq; j >= 1; --j) {
	    sum += dt[(i__1 = j + i__ * 25 - 26) < 75 && 0 <= i__1 ? i__1 : 
		    s_rnge("dt", i__1, "spke21_", (ftnlen)404)] * w[(i__2 = j 
		    + ks - 1) < 27 && 0 <= i__2 ? i__2 : s_rnge("w", i__2, 
		    "spke21_", (ftnlen)404)];
	}
	state[(i__1 = i__ + 2) < 6 && 0 <= i__1 ? i__1 : s_rnge("state", i__1,
		 "spke21_", (ftnlen)407)] = refvel[(i__2 = i__ - 1) < 3 && 0 
		<= i__2 ? i__2 : s_rnge("refvel", i__2, "spke21_", (ftnlen)
		407)] + delta * sum;
    }
    return 0;
} /* spke21_ */
示例#2
0
/* $Procedure      SPKR21 ( Read SPK record from segment, type 21 ) */
/* Subroutine */ int spkr21_(integer *handle, doublereal *descr, doublereal *
	et, doublereal *record)
{
    /* System generated locals */
    integer i__1, i__2, i__3;

    /* Builtin functions */
    integer i_dnnt(doublereal *);

    /* Local variables */
    doublereal data[100];
    integer offd, offe, nrec, ndir, offr, i__, begin;
    extern /* Subroutine */ int chkin_(char *, ftnlen), dafus_(doublereal *, 
	    integer *, integer *, doublereal *, integer *);
    integer recno;
    extern /* Subroutine */ int dafgda_(integer *, integer *, integer *, 
	    doublereal *);
    doublereal dc[2];
    integer ic[6], maxdim, dflsiz;
    extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *, 
	    ftnlen);
    extern integer lstltd_(doublereal *, integer *, doublereal *);
    extern logical return_(void);
    integer end, off;

/* $ Abstract */

/*     Read a single SPK data record from a segment of type 21 */
/*     (Extended Difference Lines). */

/* $ 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 */

/*     SPK */
/*     TIME */

/* $ Keywords */

/*     EPHEMERIS */

/* $ Declarations */
/* $ Abstract */

/*     Declare parameters specific to SPK type 21. */

/* $ 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 */

/*     SPK */

/* $ Keywords */

/*     SPK */

/* $ Restrictions */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman      (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 25-DEC-2013 (NJB) */

/* -& */

/*     MAXTRM      is the maximum number of terms allowed in each */
/*                 component of the difference table contained in a type */
/*                 21 SPK difference line. MAXTRM replaces the fixed */
/*                 table parameter value of 15 used in SPK type 1 */
/*                 segments. */

/*                 Type 21 segments have variable size. Let MAXDIM be */
/*                 the dimension of each component of the difference */
/*                 table within each difference line. Then the size */
/*                 DLSIZE of the difference line is */

/*                    ( 4 * MAXDIM ) + 11 */

/*                 MAXTRM is the largest allowed value of MAXDIM. */



/*     End of include file spk21.inc. */

/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     HANDLE     I   File handle. */
/*     DESCR      I   Segment descriptor. */
/*     ET         I   Evaluation epoch. */
/*     RECORD     O   Data record. */

/* $ Detailed_Input */

/*     HANDLE, */
/*     DESCR       are the file handle and segment descriptor for */
/*                 a SPK segment of type 21. */

/*     ET          is an epoch for which a data record from a specific */
/*                 segment is required. The epoch is represented as */
/*                 seconds past J2000 TDB. */

/* $ Detailed_Output */

/*     RECORD      is a data record which, when evaluated at epoch ET, */
/*                 will give the state (position and velocity) of an */
/*                 ephemeris object, relative to its center of motion, */
/*                 in an inertial reference frame. */

/*                 The contents of RECORD are as follows: */

/*                    RECORD(1):         The difference table size per */
/*                                       Cartesian component. Call this */
/*                                       size MAXDIM; then the difference */
/*                                       line (MDA) size DLSIZE is */

/*                                         ( 4 * MAXDIM ) + 11 */

/*                    RECORD(2) */
/*                       ... */
/*                    RECORD(1+DLSIZE):  An extended difference line. */
/*                                       The contents are: */

/*                       Dimension  Description */
/*                       ---------  ---------------------------------- */
/*                       1          Reference epoch of difference line */
/*                       MAXDIM     Stepsize function vector */
/*                       1          Reference position vector,  x */
/*                       1          Reference velocity vector,  x */
/*                       1          Reference position vector,  y */
/*                       1          Reference velocity vector,  y */
/*                       1          Reference position vector,  z */
/*                       1          Reference velocity vector,  z */
/*                       MAXDIM,3   Modified divided difference */
/*                                  arrays (MDAs) */
/*                       1          Maximum integration order plus 1 */
/*                       3          Integration order array */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     1) If the maximum table size of the input record exceeds */
/*        MAXTRM, the error SPICE(DIFFLINETOOLARGE) is signaled. */

/*     2) Any errors that occur while reading SPK data will be */
/*        diagnosed by routines in the call tree of this routine. */

/* $ Files */

/*     See argument HANDLE. */

/* $ Particulars */

/*     See the SPK Required Reading file for a description of the */
/*     structure of a data type 21 segment. */

/* $ Examples */

/*     The data returned by the SPKRnn routine is in its rawest form, */
/*     taken directly from the segment.  As such, it will be meaningless */
/*     to a user unless he/she understands the structure of the data type */
/*     completely.  Given that understanding, however, the SPKRxx */
/*     routines might be used to "dump" and check segment data for a */
/*     particular epoch. */


/*     C */
/*     C     Get a segment applicable to a specified body and epoch. */
/*     C */
/*           CALL SPKSFS ( BODY, ET, HANDLE, DESCR, IDENT, FOUND ) */

/*     C */
/*     C     Look at parts of the descriptor. */
/*     C */
/*           CALL DAFUS ( DESCR, 2, 6, DCD, ICD ) */
/*           CENTER = ICD( 2 ) */
/*           REF    = ICD( 3 ) */
/*           TYPE   = ICD( 4 ) */

/*           IF ( TYPE .EQ. 1 ) THEN */
/*              CALL SPKR21 ( HANDLE, DESCR, ET, RECORD ) */
/*                  . */
/*                  .  Look at the RECORD data. */
/*                  . */
/*           END IF */

/* $ Restrictions */

/*     None. */

/* $ Literature_References */

/*     NAIF Document 168.0, "S- and P- Kernel (SPK) Specification and */
/*     User's Guide" */

/* $ Author_and_Institution */

/*     N.J. Bachman    (JPL) */
/*     I.M. Underwood  (JPL) */
/*     E.D. Wright     (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 16-JAN-2014 (NJB) (FTK) (WLT) (IMU) */

/* -& */
/* $ Index_Entries */

/*     read record from type_21 spk segment */

/* -& */

/*     SPICELIB functions */


/*     Local parameters */


/*     Local variables */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    }
    chkin_("SPKR21", (ftnlen)6);

/*     Unpack the segment descriptor. */

    dafus_(descr, &c__2, &c__6, dc, ic);
    begin = ic[4];
    end = ic[5];

/*     Get the number of records in the segment. From that, we can */
/*     compute */

/*        NDIR      The number of directory epochs. */

/*        OFFD      The offset of the first directory epoch. */

/*        OFFE      The offset of the first epoch. */


/*     the number of directory epochs. */

/*     We'll fetch the difference table dimension as well. */

    i__1 = end - 1;
    dafgda_(handle, &i__1, &end, data);
    nrec = i_dnnt(&data[1]);
    ndir = nrec / 100;
    offd = end - ndir - 2;
    offe = offd - nrec;
    maxdim = i_dnnt(data);
    if (maxdim > 25) {
	setmsg_("The input record has a maximum table dimension of #, while "
		"the maximum supported by this routine is #. It is possible t"
		"hat this problem is due to your SPICE Toolkit being out of d"
		"ate.", (ftnlen)183);
	errint_("#", &maxdim, (ftnlen)1);
	errint_("#", &c__25, (ftnlen)1);
	sigerr_("SPICE(DIFFLINETOOLARGE)", (ftnlen)23);
	chkout_("SPKR21", (ftnlen)6);
	return 0;
    }

/*     The difference line dimension per component is the */
/*     first element of the output record. */

    record[0] = (doublereal) maxdim;

/*     Set the difference line size. */

    dflsiz = (maxdim << 2) + 11;

/*     What we want is the record number: once we have that, we can */
/*     compute the offset of the record from the beginning of the */
/*     segment, grab it, and go. But how to find it? */

/*     Ultimately, we want the first record whose epoch is greater */
/*     than or equal to ET. If there are BUFSIZ or fewer records, all */
/*     the record epochs can be examined in a single group. */

    if (nrec <= 100) {
	i__1 = offe + 1;
	i__2 = offe + nrec;
	dafgda_(handle, &i__1, &i__2, data);
	recno = lstltd_(et, &nrec, data) + 1;
	offr = begin - 1 + (recno - 1) * dflsiz;
	i__1 = offr + 1;
	i__2 = offr + dflsiz;
	dafgda_(handle, &i__1, &i__2, &record[1]);
	chkout_("SPKR21", (ftnlen)6);
	return 0;
    }

/*     Searching directories is a little more difficult. */

/*     The directory contains epochs BUFSIZ, 2*BUFSIZ, and so on. Once */
/*     we find the first directory epoch greater than or equal to ET, we */
/*     can grab the corresponding set of BUFSIZ record epochs, and */
/*     search them. */

    i__1 = ndir;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i__2 = offd + i__;
	i__3 = offd + i__;
	dafgda_(handle, &i__2, &i__3, data);
	if (data[0] >= *et) {
	    off = offe + (i__ - 1) * 100;
	    i__2 = off + 1;
	    i__3 = off + 100;
	    dafgda_(handle, &i__2, &i__3, data);
	    recno = (i__ - 1) * 100 + lstltd_(et, &c__100, data) + 1;
	    offr = begin - 1 + (recno - 1) * dflsiz;
	    i__2 = offr + 1;
	    i__3 = offr + dflsiz;
	    dafgda_(handle, &i__2, &i__3, &record[1]);
	    chkout_("SPKR21", (ftnlen)6);
	    return 0;
	}
    }

/*     If ET is greater than the final directory epoch, we want one */
/*     of the final records. */

    i__ = nrec % 100;
    i__1 = end - ndir - i__ - 1;
    i__2 = end - ndir - 2;
    dafgda_(handle, &i__1, &i__2, data);
    recno = ndir * 100 + lstltd_(et, &i__, data) + 1;
    offr = begin - 1 + (recno - 1) * dflsiz;
    i__1 = offr + 1;
    i__2 = offr + dflsiz;
    dafgda_(handle, &i__1, &i__2, &record[1]);
    chkout_("SPKR21", (ftnlen)6);
    return 0;
} /* spkr21_ */
示例#3
0
/* $Procedure      SPKE08 ( S/P Kernel, evaluate, type 8 ) */
/* Subroutine */ int spke08_(doublereal *et, doublereal *record, doublereal *
	state)
{
    /* System generated locals */
    integer i__1;

    /* Builtin functions */
    integer i_dnnt(doublereal *), s_rnge(char *, integer, char *, integer);

    /* Local variables */
    integer i__, n;
    extern /* Subroutine */ int moved_(doublereal *, integer *, doublereal *);
    doublereal locrec[129];
    extern doublereal lgresp_(integer *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *);
    extern /* Subroutine */ int xposeg_(doublereal *, integer *, integer *, 
	    doublereal *);
    extern logical return_(void);
    integer ystart;

/* $ Abstract */

/*     Evaluate a single SPK data record from a segment of type 8 */
/*     (equally spaced discrete states, interpolated by Lagrange */
/*     polynomials). */

/* $ 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 */

/*     SPK */
/*     TIME */

/* $ Keywords */

/*     EPHEMERIS */

/* $ Declarations */
/* $ Abstract */

/*     Declare SPK data record size.  This record is declared in */
/*     SPKPVN and is passed to SPK reader (SPKRxx) and evaluator */
/*     (SPKExx) routines. */

/* $ 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 */

/*     SPK */

/* $ Keywords */

/*     SPK */

/* $ Restrictions */

/*     1) If new SPK types are added, it may be necessary to */
/*        increase the size of this record.  The header of SPKPVN */
/*        should be updated as well to show the record size */
/*        requirement for each data type. */

/* $ Author_and_Institution */

/*     N.J. Bachman      (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 16-AUG-2002 (NJB) */

/* -& */

/*     End include file spkrec.inc */

/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     ET         I   Target epoch. */
/*     RECORD    I-O  Data record. */
/*     STATE      O   State (position and velocity). */

/* $ Detailed_Input */

/*     ET          is a target epoch, at which a state vector is to */
/*                 be computed. */

/*     RECORD      is a data record which, when evaluated at epoch ET, */
/*                 will give the state (position and velocity) of some */
/*                 body, relative to some center, in some inertial */
/*                 reference frame.  Normally, the caller of this routine */
/*                 will obtain RECORD by calling SPKR08. */

/*                 The structure of the record is as follows: */

/*                    +----------------------+ */
/*                    | number of states (n) | */
/*                    +----------------------+ */
/*                    | start epoch          | */
/*                    +----------------------+ */
/*                    | step size            | */
/*                    +----------------------+ */
/*                    | state 1 (6 elts.)    | */
/*                    +----------------------+ */
/*                    | state 2 (6 elts.)    | */
/*                    +----------------------+ */
/*                                . */
/*                                . */
/*                                . */
/*                    +----------------------+ */
/*                    | state n (6 elts.)    | */
/*                    +----------------------+ */

/* $ Detailed_Output */

/*     RECORD      is the input record, modified by use as a work area. */
/*                 On output, RECORD no longer contains useful */
/*                 information. */

/*     STATE       is the state. In order, the elements are */

/*                    X, Y, Z, X', Y', and Z' */

/*                 Units are km and km/sec. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     1)  The caller of this routine must ensure that the input record */
/*         is appropriate for the supplied ET value.  Otherwise, */
/*         arithmetic overflow may result. */

/* $ Files */

/*     None. */

/* $ Particulars */

/*     The exact format and structure of type 8 (equally spaced discrete */
/*     states, interpolated by Lagrange polynomials) segments are */
/*     described in the SPK Required Reading file. */

/* $ Examples */

/*     The SPKEnn routines are almost always used in conjunction with */
/*     the corresponding SPKRnn routines, which read the records from */
/*     SPK files. */

/*     The data returned by the SPKRnn routine is in its rawest form, */
/*     taken directly from the segment.  As such, it will be meaningless */
/*     to a user unless he/she understands the structure of the data type */
/*     completely.  Given that understanding, however, the SPKRnn */
/*     routines might be used to examine raw segment data before */
/*     evaluating it with the SPKEnn routines. */


/*     C */
/*     C     Get a segment applicable to a specified body and epoch. */
/*     C */
/*           CALL SPKSFS ( BODY, ET, HANDLE, DESCR, IDENT, FOUND ) */

/*     C */
/*     C     Look at parts of the descriptor. */
/*     C */
/*           CALL DAFUS ( DESCR, 2, 6, DCD, ICD ) */
/*           CENTER = ICD( 2 ) */
/*           REF    = ICD( 3 ) */
/*           TYPE   = ICD( 4 ) */

/*           IF ( TYPE .EQ. 8 ) THEN */

/*              CALL SPKR08 ( HANDLE, DESCR, ET, RECORD ) */
/*                  . */
/*                  .  Look at the RECORD data. */
/*                  . */
/*              CALL SPKE08 ( ET, RECORD, STATE ) */
/*                  . */
/*                  .  Check out the evaluated state. */
/*                  . */
/*           END IF */

/* $ Restrictions */

/*     None. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman   (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.1.0, 25-AUG-2005 (NJB) */

/*        Updated to remove non-standard use of duplicate arguments */
/*        in XPOSEG and LGRESP calls. */

/* -    SPICELIB Version 1.0.0, 14-AUG-1993 (NJB) */

/* -& */
/* $ Index_Entries */

/*     evaluate type_8 spk segment */

/* -& */
/* $ Revisions */

/* -    SPICELIB Version 1.1.0, 25-AUG-2005 (NJB) */

/*        Updated to remove non-standard use of duplicate arguments */
/*        in XPOSEG and LGRESP calls. */

/* -& */

/*     SPICELIB functions */


/*     Local parameters */


/*     Size of a state vector: */


/*     Indices of input record elements: */

/*        -- size */
/*        -- start epoch */
/*        -- step size */
/*        -- start of state information */


/*     Local variables */


/*     Use discovery check-in. */

    if (return_()) {
	return 0;
    }

/*     We'll transpose the state information in the input record */
/*     so that contiguous pieces of it can be shoved directly into the */
/*     interpolation routine LGRESP. */

    n = i_dnnt(record);
    xposeg_(&record[3], &c__6, &n, locrec);
    i__1 = n * 6;
    moved_(locrec, &i__1, &record[3]);

/*     We interpolate each state component in turn. */

    for (i__ = 1; i__ <= 6; ++i__) {
	ystart = n * (i__ - 1) + 4;
	state[(i__1 = i__ - 1) < 6 && 0 <= i__1 ? i__1 : s_rnge("state", i__1,
		 "spke08_", (ftnlen)274)] = lgresp_(&n, &record[1], &record[2]
		, &record[ystart - 1], locrec, et);
    }
    return 0;
} /* spke08_ */
示例#4
0
/* Subroutine */ int zlaqps_(integer *m, integer *n, integer *offset, integer 
	*nb, integer *kb, doublecomplex *a, integer *lda, integer *jpvt, 
	doublecomplex *tau, doublereal *vn1, doublereal *vn2, doublecomplex *
	auxv, doublecomplex *f, integer *ldf)
{
    /* System generated locals */
    integer a_dim1, a_offset, f_dim1, f_offset, i__1, i__2, i__3;
    doublereal d__1, d__2;
    doublecomplex z__1;

    /* Builtin functions */
    double sqrt(doublereal);
    void d_cnjg(doublecomplex *, doublecomplex *);
    double z_abs(doublecomplex *);
    integer i_dnnt(doublereal *);

    /* Local variables */
    integer j, k, rk;
    doublecomplex akk;
    integer pvt;
    doublereal temp, temp2, tol3z;
    integer itemp;
    extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, 
	    integer *, doublecomplex *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *), zgemv_(char *, integer *, integer *, 
	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
	    integer *, doublecomplex *, doublecomplex *, integer *), 
	    zswap_(integer *, doublecomplex *, integer *, doublecomplex *, 
	    integer *);
    extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
	    char *);
    extern integer idamax_(integer *, doublereal *, integer *);
    integer lsticc;
    extern /* Subroutine */ int zlarfp_(integer *, doublecomplex *, 
	    doublecomplex *, integer *, doublecomplex *);
    integer lastrk;


/*  -- LAPACK auxiliary routine (version 3.2) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  ZLAQPS computes a step of QR factorization with column pivoting */
/*  of a complex M-by-N matrix A by using Blas-3.  It tries to factorize */
/*  NB columns from A starting from the row OFFSET+1, and updates all */
/*  of the matrix with Blas-3 xGEMM. */

/*  In some cases, due to catastrophic cancellations, it cannot */
/*  factorize NB columns.  Hence, the actual number of factorized */
/*  columns is returned in KB. */

/*  Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */

/*  Arguments */
/*  ========= */

/*  M       (input) INTEGER */
/*          The number of rows of the matrix A. M >= 0. */

/*  N       (input) INTEGER */
/*          The number of columns of the matrix A. N >= 0 */

/*  OFFSET  (input) INTEGER */
/*          The number of rows of A that have been factorized in */
/*          previous steps. */

/*  NB      (input) INTEGER */
/*          The number of columns to factorize. */

/*  KB      (output) INTEGER */
/*          The number of columns actually factorized. */

/*  A       (input/output) COMPLEX*16 array, dimension (LDA,N) */
/*          On entry, the M-by-N matrix A. */
/*          On exit, block A(OFFSET+1:M,1:KB) is the triangular */
/*          factor obtained and block A(1:OFFSET,1:N) has been */
/*          accordingly pivoted, but no factorized. */
/*          The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has */
/*          been updated. */

/*  LDA     (input) INTEGER */
/*          The leading dimension of the array A. LDA >= max(1,M). */

/*  JPVT    (input/output) INTEGER array, dimension (N) */
/*          JPVT(I) = K <==> Column K of the full matrix A has been */
/*          permuted into position I in AP. */

/*  TAU     (output) COMPLEX*16 array, dimension (KB) */
/*          The scalar factors of the elementary reflectors. */

/*  VN1     (input/output) DOUBLE PRECISION array, dimension (N) */
/*          The vector with the partial column norms. */

/*  VN2     (input/output) DOUBLE PRECISION array, dimension (N) */
/*          The vector with the exact column norms. */

/*  AUXV    (input/output) COMPLEX*16 array, dimension (NB) */
/*          Auxiliar vector. */

/*  F       (input/output) COMPLEX*16 array, dimension (LDF,NB) */
/*          Matrix F' = L*Y'*A. */

/*  LDF     (input) INTEGER */
/*          The leading dimension of the array F. LDF >= max(1,N). */

/*  Further Details */
/*  =============== */

/*  Based on contributions by */
/*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
/*    X. Sun, Computer Science Dept., Duke University, USA */

/*  ===================================================================== */

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. Executable Statements .. */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --jpvt;
    --tau;
    --vn1;
    --vn2;
    --auxv;
    f_dim1 = *ldf;
    f_offset = 1 + f_dim1;
    f -= f_offset;

    /* Function Body */
/* Computing MIN */
    i__1 = *m, i__2 = *n + *offset;
    lastrk = min(i__1,i__2);
    lsticc = 0;
    k = 0;
    tol3z = sqrt(dlamch_("Epsilon"));

/*     Beginning of while loop. */

L10:
    if (k < *nb && lsticc == 0) {
	++k;
	rk = *offset + k;

/*        Determine ith pivot column and swap if necessary */

	i__1 = *n - k + 1;
	pvt = k - 1 + idamax_(&i__1, &vn1[k], &c__1);
	if (pvt != k) {
	    zswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
	    i__1 = k - 1;
	    zswap_(&i__1, &f[pvt + f_dim1], ldf, &f[k + f_dim1], ldf);
	    itemp = jpvt[pvt];
	    jpvt[pvt] = jpvt[k];
	    jpvt[k] = itemp;
	    vn1[pvt] = vn1[k];
	    vn2[pvt] = vn2[k];
	}

/*        Apply previous Householder reflectors to column K: */
/*        A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'. */

	if (k > 1) {
	    i__1 = k - 1;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = k + j * f_dim1;
		d_cnjg(&z__1, &f[k + j * f_dim1]);
		f[i__2].r = z__1.r, f[i__2].i = z__1.i;
/* L20: */
	    }
	    i__1 = *m - rk + 1;
	    i__2 = k - 1;
	    z__1.r = -1., z__1.i = -0.;
	    zgemv_("No transpose", &i__1, &i__2, &z__1, &a[rk + a_dim1], lda, 
		    &f[k + f_dim1], ldf, &c_b2, &a[rk + k * a_dim1], &c__1);
	    i__1 = k - 1;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = k + j * f_dim1;
		d_cnjg(&z__1, &f[k + j * f_dim1]);
		f[i__2].r = z__1.r, f[i__2].i = z__1.i;
/* L30: */
	    }
	}

/*        Generate elementary reflector H(k). */

	if (rk < *m) {
	    i__1 = *m - rk + 1;
	    zlarfp_(&i__1, &a[rk + k * a_dim1], &a[rk + 1 + k * a_dim1], &
		    c__1, &tau[k]);
	} else {
	    zlarfp_(&c__1, &a[rk + k * a_dim1], &a[rk + k * a_dim1], &c__1, &
		    tau[k]);
	}

	i__1 = rk + k * a_dim1;
	akk.r = a[i__1].r, akk.i = a[i__1].i;
	i__1 = rk + k * a_dim1;
	a[i__1].r = 1., a[i__1].i = 0.;

/*        Compute Kth column of F: */

/*        Compute  F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K). */

	if (k < *n) {
	    i__1 = *m - rk + 1;
	    i__2 = *n - k;
	    zgemv_("Conjugate transpose", &i__1, &i__2, &tau[k], &a[rk + (k + 
		    1) * a_dim1], lda, &a[rk + k * a_dim1], &c__1, &c_b1, &f[
		    k + 1 + k * f_dim1], &c__1);
	}

/*        Padding F(1:K,K) with zeros. */

	i__1 = k;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = j + k * f_dim1;
	    f[i__2].r = 0., f[i__2].i = 0.;
/* L40: */
	}

/*        Incremental updating of F: */
/*        F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)' */
/*                    *A(RK:M,K). */

	if (k > 1) {
	    i__1 = *m - rk + 1;
	    i__2 = k - 1;
	    i__3 = k;
	    z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
	    zgemv_("Conjugate transpose", &i__1, &i__2, &z__1, &a[rk + a_dim1]
, lda, &a[rk + k * a_dim1], &c__1, &c_b1, &auxv[1], &c__1);

	    i__1 = k - 1;
	    zgemv_("No transpose", n, &i__1, &c_b2, &f[f_dim1 + 1], ldf, &
		    auxv[1], &c__1, &c_b2, &f[k * f_dim1 + 1], &c__1);
	}

/*        Update the current row of A: */
/*        A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'. */

	if (k < *n) {
	    i__1 = *n - k;
	    z__1.r = -1., z__1.i = -0.;
	    zgemm_("No transpose", "Conjugate transpose", &c__1, &i__1, &k, &
		    z__1, &a[rk + a_dim1], lda, &f[k + 1 + f_dim1], ldf, &
		    c_b2, &a[rk + (k + 1) * a_dim1], lda);
	}

/*        Update partial column norms. */

	if (rk < lastrk) {
	    i__1 = *n;
	    for (j = k + 1; j <= i__1; ++j) {
		if (vn1[j] != 0.) {

/*                 NOTE: The following 4 lines follow from the analysis in */
/*                 Lapack Working Note 176. */

		    temp = z_abs(&a[rk + j * a_dim1]) / vn1[j];
/* Computing MAX */
		    d__1 = 0., d__2 = (temp + 1.) * (1. - temp);
		    temp = max(d__1,d__2);
/* Computing 2nd power */
		    d__1 = vn1[j] / vn2[j];
		    temp2 = temp * (d__1 * d__1);
		    if (temp2 <= tol3z) {
			vn2[j] = (doublereal) lsticc;
			lsticc = j;
		    } else {
			vn1[j] *= sqrt(temp);
		    }
		}
/* L50: */
	    }
	}

	i__1 = rk + k * a_dim1;
	a[i__1].r = akk.r, a[i__1].i = akk.i;

/*        End of while loop. */

	goto L10;
    }
    *kb = k;
    rk = *offset + *kb;

/*     Apply the block reflector to the rest of the matrix: */
/*     A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - */
/*                         A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'. */

/* Computing MIN */
    i__1 = *n, i__2 = *m - *offset;
    if (*kb < min(i__1,i__2)) {
	i__1 = *m - rk;
	i__2 = *n - *kb;
	z__1.r = -1., z__1.i = -0.;
	zgemm_("No transpose", "Conjugate transpose", &i__1, &i__2, kb, &z__1, 
		 &a[rk + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b2, &
		a[rk + 1 + (*kb + 1) * a_dim1], lda);
    }

/*     Recomputation of difficult columns. */

L60:
    if (lsticc > 0) {
	itemp = i_dnnt(&vn2[lsticc]);
	i__1 = *m - rk;
	vn1[lsticc] = dznrm2_(&i__1, &a[rk + 1 + lsticc * a_dim1], &c__1);

/*        NOTE: The computation of VN1( LSTICC ) relies on the fact that */
/*        SNRM2 does not fail on vectors with norm below the value of */
/*        SQRT(DLAMCH('S')) */

	vn2[lsticc] = vn1[lsticc];
	lsticc = itemp;
	goto L60;
    }

    return 0;

/*     End of ZLAQPS */

} /* zlaqps_ */
示例#5
0
文件: zzekille.c 项目: Dbelsa/coft
/* $Procedure    ZZEKILLE ( EK, indirect, last elt less than or equal to ) */
integer zzekille_(integer *handle, integer *segdsc, integer *coldsc, integer *
	nrows, integer *dtype, char *cval, doublereal *dval, integer *ival, 
	ftnlen cval_len)
{
    /* System generated locals */
    integer ret_val;

    /* Builtin functions */
    integer i_dnnt(doublereal *);

    /* Local variables */
    doublereal dnum;
    integer inum;
    extern /* Subroutine */ int zzekllec_(integer *, integer *, integer *, 
	    char *, integer *, integer *, ftnlen), zzeklled_(integer *, 
	    integer *, integer *, doublereal *, integer *, integer *), 
	    zzekllei_(integer *, integer *, integer *, integer *, integer *, 
	    integer *), chkin_(char *, ftnlen);
    extern logical return_(void);
    integer coltyp;
    extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *, 
	    integer *, ftnlen), sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen);
    integer rec;

/* $ Abstract */

/*     Find the ordinal position of the row, in an specified EK segment, */
/*     whose value in a specified column is the last last element less */
/*     than or equal to a specified value, where the order relation is */
/*     given by an order vector in a specified DAS file. */

/* $ 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 */

/*     DAS */
/*     EK */

/* $ Keywords */

/*     ARRAY */
/*     FILES */
/*     SORT */
/*     UTILITY */

/* $ Declarations */
/* $ 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. */


/*     Include Section:  EK Column Descriptor Parameters */

/*        ekcoldsc.inc Version 6    23-AUG-1995 (NJB) */


/*     Note:  The column descriptor size parameter CDSCSZ  is */
/*     declared separately in the include section CDSIZE$INC.FOR. */

/*     Offset of column descriptors, relative to start of segment */
/*     integer address range.  This number, when added to the last */
/*     integer address preceding the segment, yields the DAS integer */
/*     base address of the first column descriptor.  Currently, this */
/*     offset is exactly the size of a segment descriptor.  The */
/*     parameter SDSCSZ, which defines the size of a segment descriptor, */
/*     is declared in the include file eksegdsc.inc. */


/*     Size of column descriptor */


/*     Indices of various pieces of column descriptors: */


/*     CLSIDX is the index of the column's class code.  (We use the */
/*     word `class' to distinguish this item from the column's data */
/*     type.) */


/*     TYPIDX is the index of the column's data type code (CHR, INT, DP, */
/*     or TIME).  The type is actually implied by the class, but it */
/*     will frequently be convenient to look up the type directly. */



/*     LENIDX is the index of the column's string length value, if the */
/*     column has character type.  A value of IFALSE in this element of */
/*     the descriptor indicates that the strings have variable length. */


/*     SIZIDX is the index of the column's element size value.  This */
/*     descriptor element is meaningful for columns with fixed-size */
/*     entries.  For variable-sized columns, this value is IFALSE. */


/*     NAMIDX is the index of the base address of the column's name. */


/*     IXTIDX is the data type of the column's index.  IXTIDX */
/*     contains a type value only if the column is indexed. For columns */
/*     that are not indexed, the location IXTIDX contains the boolean */
/*     value IFALSE. */


/*     IXPIDX is a pointer to the column's index.  IXTPDX contains a */
/*     meaningful value only if the column is indexed.  The */
/*     interpretation of the pointer depends on the data type of the */
/*     index. */


/*     NFLIDX is the index of a flag indicating whether nulls are */
/*     permitted in the column.  The value at location NFLIDX is */
/*     ITRUE if nulls are permitted and IFALSE otherwise. */


/*     ORDIDX is the index of the column's ordinal position in the */
/*     list of columns belonging to the column's parent segment. */


/*     METIDX is the index of the column's integer metadata pointer. */
/*     This pointer is a DAS integer address. */


/*     The last position in the column descriptor is reserved.  No */
/*     parameter is defined to point to this location. */


/*     End Include Section:  EK Column Descriptor Parameters */

/* $ 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. */


/*     Include Section:  EK Operator Codes */

/*        ekopcd.inc  Version 1  30-DEC-1994 (NJB) */


/*     Within the EK system, operators used in EK queries are */
/*     represented by integer codes.  The codes and their meanings are */
/*     listed below. */

/*     Relational expressions in EK queries have the form */

/*        <column name> <operator> <value> */

/*     For columns containing numeric values, the operators */

/*        EQ,  GE,  GT,  LE,  LT,  NE */

/*     may be used; these operators have the same meanings as their */
/*     Fortran counterparts.  For columns containing character values, */
/*     the list of allowed operators includes those in the above list, */
/*     and in addition includes the operators */

/*        LIKE,  UNLIKE */

/*     which are used to compare strings to a template.  In the character */
/*     case, the meanings of the parameters */

/*        GE,  GT,  LE,  LT */

/*     match those of the Fortran lexical functions */

/*        LGE, LGT, LLE, LLT */


/*     The additional unary operators */

/*        ISNULL, NOTNUL */

/*     are used to test whether a value of any type is null. */



/*     End Include Section:  EK Operator Codes */

/* $ 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. */


/*     Include Section:  EK Segment Descriptor Parameters */

/*        eksegdsc.inc  Version 8  06-NOV-1995 (NJB) */


/*     All `base addresses' referred to below are the addresses */
/*     *preceding* the item the base applies to.  This convention */
/*     enables simplied address calculations in many cases. */

/*     Size of segment descriptor.  Note:  the include file ekcoldsc.inc */
/*     must be updated if this parameter is changed.  The parameter */
/*     CDOFF in that file should be kept equal to SDSCSZ. */


/*     Index of the segment type code: */


/*     Index of the segment's number.  This number is the segment's */
/*     index in the list of segments contained in the EK to which */
/*     the segment belongs. */


/*     Index of the DAS integer base address of the segment's integer */
/*     meta-data: */


/*     Index of the DAS character base address of the table name: */


/*     Index of the segment's column count: */


/*     Index of the segment's record count: */


/*     Index of the root page number of the record tree: */


/*     Index of the root page number of the character data page tree: */


/*     Index of the root page number of the double precision data page */
/*     tree: */


/*     Index of the root page number of the integer data page tree: */


/*     Index of the `modified' flag: */


/*     Index of the `initialized' flag: */


/*     Index of the shadowing flag: */


/*     Index of the companion file handle: */


/*     Index of the companion segment number: */


/*     The next three items are, respectively, the page numbers of the */
/*     last character, d.p., and integer data pages allocated by the */
/*     segment: */


/*     The next three items are, respectively, the page-relative */
/*     indices of the last DAS word in use in the segment's */
/*     last character, d.p., and integer data pages: */


/*     Index of the DAS character base address of the column name list: */


/*     The last descriptor element is reserved for future use.  No */
/*     parameter is defined to point to this location. */


/*     End Include Section:  EK Segment Descriptor Parameters */

/* $ 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. */


/*     Include Section:  EK Data Types */

/*        ektype.inc Version 1  27-DEC-1994 (NJB) */


/*     Within the EK system, data types of EK column contents are */
/*     represented by integer codes.  The codes and their meanings */
/*     are listed below. */

/*     Integer codes are also used within the DAS system to indicate */
/*     data types; the EK system makes no assumptions about compatibility */
/*     between the codes used here and those used in the DAS system. */


/*     Character type: */


/*     Double precision type: */


/*     Integer type: */


/*     `Time' type: */

/*     Within the EK system, time values are represented as ephemeris */
/*     seconds past J2000 (TDB), and double precision numbers are used */
/*     to store these values.  However, since time values require special */
/*     treatment both on input and output, and since the `TIME' column */
/*     has a special role in the EK specification and code, time values */
/*     are identified as a type distinct from double precision numbers. */


/*     End Include Section:  EK Data Types */

/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     HANDLE     I   HANDLE of EK file. */
/*     SEGDSC     I   Segment descriptor. */
/*     COLDSC     I   Descriptor of column to be searched. */
/*     NROWS      I   Number of rows in column. */
/*     DTYPE      I   Data type of input value. */
/*     CVAL       I   Character string value. */
/*     DVAL       I   Double precision value. */
/*     IVAL       I   Integer value. */

/*     The function returns the index of the last order vector element */
/*     that points to an array element that is less than or equal to */
/*     the input value of the same data type as the column. */

/* $ Detailed_Input */

/*     HANDLE         is the file handle of the EK containing the */
/*                    segment of interest. */

/*     SEGDSC         is the segment descriptor of the EK */
/*                    segment of interest. */

/*     COLDSC         is a column descriptor for the column whose */
/*                    entries are to be compared with an input scalar */
/*                    value.  The column must be indexed. */

/*     NROWS          is the number of rows in the segment of interest. */

/*     DTYPE          is the data type of the input scalar value. */

/*     CVAL, */
/*     DVAL, */
/*     IVAL           are a set of scalar variables of character, */
/*                    double precision, and integer type.  Whichever */
/*                    of these has the same data type as the column */
/*                    indicated by COLDSC is used to compare rows */
/*                    against.  If COLDSC has data type TIME, DVAL */
/*                    is used in the comparison. */

/* $ Detailed_Output */

/*     The function returns the index of the last order vector element */
/*     that points to a column entry that is less than or equal to */
/*     whichever of CVAL, DVAL, or IVAL has the same data type as the */
/*     input column.  If the least element of the column is greater than */
/*     the input value of the matching type, the function returns the */
/*     value zero. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     1)  If the array size NROWS is non-positive, the error */
/*         SPICE(INVALIDSIZE) will be signalled. */

/*     2)  If HANDLE is invalid, the error will be diagnosed by routines */
/*         called by this routine. */

/*     3)  If an I/O error occurs during any access to the file */
/*         specified by HANDLE, the error will be diagnosed by routines */
/*         called by this routine. */

/*     4)  If any of SEGBAS, COLDSC, or NROWS are invalid, this routine */
/*         may fail in unpredictable, but possibly spectacular, ways. */
/*         Except as described in this header section, no attempt is */
/*         made to handle these errors. */

/* $ Files */

/*     See the description of the argument HANDLE in $Detailed_Input. */

/* $ Particulars */

/*     This routine supports allow rapid look-up of elements in indexed */
/*     EK columns. */

/* $ Examples */

/*     See ZZEKKEY. */

/* $ Restrictions */

/*     None. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman   (JPL) */

/* $ Version */

/* -    Beta Version 1.0.0, 10-OCT-1995 (NJB) */

/* -& */

/*     SPICELIB functions */


/*     Local variables */


/*     Initialize the function's return value. */

    ret_val = 0;

/*     Standard SPICE error handling. */

    if (return_()) {
	return ret_val;
    } else {
	chkin_("ZZEKILLE", (ftnlen)8);
    }

/*     Validate the number of rows in the column. */

    if (*nrows < 1) {

/*        There's nobody home---that is, there is nothing in the array */
/*        to compare against.  Zero is the only sensible thing to return. */

	ret_val = 0;
	setmsg_("Number of rows must be positive; was #.", (ftnlen)39);
	errint_("#", nrows, (ftnlen)1);
	sigerr_("SPICE(INVALIDSIZE)", (ftnlen)18);
	chkout_("ZZEKILLE", (ftnlen)8);
	return ret_val;
    }

/*     Hand off the problem to the LLE routine of the correct type. */

    coltyp = coldsc[1];
    if (coltyp == 1) {
	zzekllec_(handle, segdsc, coldsc, cval, &ret_val, &rec, cval_len);
    } else if (coltyp == 2) {
	if (*dtype == 2) {
	    dnum = *dval;
	} else {
	    dnum = (doublereal) (*ival);
	}
	zzeklled_(handle, segdsc, coldsc, &dnum, &ret_val, &rec);
    } else if (coltyp == 4) {
	zzeklled_(handle, segdsc, coldsc, dval, &ret_val, &rec);
    } else if (coltyp == 3) {
	if (*dtype == 2) {
	    inum = i_dnnt(dval);
	} else {
	    inum = *ival;
	}
	zzekllei_(handle, segdsc, coldsc, &inum, &ret_val, &rec);
    } else {
	setmsg_("The data type # is not supported.", (ftnlen)33);
	errint_("#", &coltyp, (ftnlen)1);
	sigerr_("SPICE(INVALIDSIZE)", (ftnlen)18);
	chkout_("ZZEKILLE", (ftnlen)8);
	return ret_val;
    }
    chkout_("ZZEKILLE", (ftnlen)8);
    return ret_val;
} /* zzekille_ */
示例#6
0
文件: dlacon.c 项目: BishopWolf/ITK
/*<       SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) >*/
/* Subroutine */ int dlacon_(integer *n, doublereal *v, doublereal *x,
        integer *isgn, doublereal *est, integer *kase)
{
    /* System generated locals */
    integer i__1;
    doublereal d__1;

    /* Builtin functions */
    double d_sign(doublereal *, doublereal *);
    integer i_dnnt(doublereal *);

    /* Local variables */
    static integer i__, j, iter;
    static doublereal temp;
    static integer jump;
    extern doublereal dasum_(integer *, doublereal *, integer *);
    static integer jlast;
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
            doublereal *, integer *);
    extern integer idamax_(integer *, doublereal *, integer *);
    static doublereal altsgn, estold;

    fprintf(stderr,
            "WARNING: dlacon_ has not been converted for thread safety "
            "because the vnl test suite does not manage to call it "
            "through dgges.  Please send the case for which you get this "
            "message to the vxl-users mailing list:\n"
            "https://lists.sourceforge.net/lists/listinfo/vxl-users\n\n");

/*  -- LAPACK auxiliary routine (version 3.0) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/*     Courant Institute, Argonne National Lab, and Rice University */
/*     February 29, 1992 */

/*     .. Scalar Arguments .. */
/*<       INTEGER            KASE, N >*/
/*<       DOUBLE PRECISION   EST >*/
/*     .. */
/*     .. Array Arguments .. */
/*<       INTEGER            ISGN( * ) >*/
/*<       DOUBLE PRECISION   V( * ), X( * ) >*/
/*     .. */

/*  Purpose */
/*  ======= */

/*  DLACON estimates the 1-norm of a square, real matrix A. */
/*  Reverse communication is used for evaluating matrix-vector products. */

/*  Arguments */
/*  ========= */

/*  N      (input) INTEGER */
/*         The order of the matrix.  N >= 1. */

/*  V      (workspace) DOUBLE PRECISION array, dimension (N) */
/*         On the final return, V = A*W,  where  EST = norm(V)/norm(W) */
/*         (W is not returned). */

/*  X      (input/output) DOUBLE PRECISION array, dimension (N) */
/*         On an intermediate return, X should be overwritten by */
/*               A * X,   if KASE=1, */
/*               A' * X,  if KASE=2, */
/*         and DLACON must be re-called with all the other parameters */
/*         unchanged. */

/*  ISGN   (workspace) INTEGER array, dimension (N) */

/*  EST    (output) DOUBLE PRECISION */
/*         An estimate (a lower bound) for norm(A). */

/*  KASE   (input/output) INTEGER */
/*         On the initial call to DLACON, KASE should be 0. */
/*         On an intermediate return, KASE will be 1 or 2, indicating */
/*         whether X should be overwritten by A * X  or A' * X. */
/*         On the final return from DLACON, KASE will again be 0. */

/*  Further Details */
/*  ======= ======= */

/*  Contributed by Nick Higham, University of Manchester. */
/*  Originally named SONEST, dated March 16, 1988. */

/*  Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */
/*  a real or complex matrix, with applications to condition estimation", */
/*  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */

/*  ===================================================================== */

/*     .. Parameters .. */
/*<       INTEGER            ITMAX >*/
/*<       PARAMETER          ( ITMAX = 5 ) >*/
/*<       DOUBLE PRECISION   ZERO, ONE, TWO >*/
/*<       PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) >*/
/*     .. */
/*     .. Local Scalars .. */
/*<       INTEGER            I, ITER, J, JLAST, JUMP >*/
/*<       DOUBLE PRECISION   ALTSGN, ESTOLD, TEMP >*/
/*     .. */
/*     .. External Functions .. */
/*<       INTEGER            IDAMAX >*/
/*<       DOUBLE PRECISION   DASUM >*/
/*<       EXTERNAL           IDAMAX, DASUM >*/
/*     .. */
/*     .. External Subroutines .. */
/*<       EXTERNAL           DCOPY >*/
/*     .. */
/*     .. Intrinsic Functions .. */
/*<       INTRINSIC          ABS, DBLE, NINT, SIGN >*/
/*     .. */
/*     .. Save statement .. */
/*<       SAVE >*/
/*     .. */
/*     .. Executable Statements .. */

/*<       IF( KASE.EQ.0 ) THEN >*/
    /* Parameter adjustments */
    --isgn;
    --x;
    --v;

    /* Function Body */
    if (*kase == 0) {
/*<          DO 10 I = 1, N >*/
        i__1 = *n;
        for (i__ = 1; i__ <= i__1; ++i__) {
/*<             X( I ) = ONE / DBLE( N ) >*/
            x[i__] = 1. / (doublereal) (*n);
/*<    10    CONTINUE >*/
/* L10: */
        }
/*<          KASE = 1 >*/
        *kase = 1;
/*<          JUMP = 1 >*/
        jump = 1;
/*<          RETURN >*/
        return 0;
/*<       END IF >*/
    }

/*<       GO TO ( 20, 40, 70, 110, 140 )JUMP >*/
    switch (jump) {
        case 1:  goto L20;
        case 2:  goto L40;
        case 3:  goto L70;
        case 4:  goto L110;
        case 5:  goto L140;
    }

/*     ................ ENTRY   (JUMP = 1) */
/*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY A*X. */

/*<    20 CONTINUE >*/
L20:
/*<       IF( N.EQ.1 ) THEN >*/
    if (*n == 1) {
/*<          V( 1 ) = X( 1 ) >*/
        v[1] = x[1];
/*<          EST = ABS( V( 1 ) ) >*/
        *est = abs(v[1]);
/*        ... QUIT */
/*<          GO TO 150 >*/
        goto L150;
/*<       END IF >*/
    }
/*<       EST = DASUM( N, X, 1 ) >*/
    *est = dasum_(n, &x[1], &c__1);

/*<       DO 30 I = 1, N >*/
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
/*<          X( I ) = SIGN( ONE, X( I ) ) >*/
        x[i__] = d_sign(&c_b11, &x[i__]);
/*<          ISGN( I ) = NINT( X( I ) ) >*/
        isgn[i__] = i_dnnt(&x[i__]);
/*<    30 CONTINUE >*/
/* L30: */
    }
/*<       KASE = 2 >*/
    *kase = 2;
/*<       JUMP = 2 >*/
    jump = 2;
/*<       RETURN >*/
    return 0;

/*     ................ ENTRY   (JUMP = 2) */
/*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */

/*<    40 CONTINUE >*/
L40:
/*<       J = IDAMAX( N, X, 1 ) >*/
    j = idamax_(n, &x[1], &c__1);
/*<       ITER = 2 >*/
    iter = 2;

/*     MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */

/*<    50 CONTINUE >*/
L50:
/*<       DO 60 I = 1, N >*/
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
/*<          X( I ) = ZERO >*/
        x[i__] = 0.;
/*<    60 CONTINUE >*/
/* L60: */
    }
/*<       X( J ) = ONE >*/
    x[j] = 1.;
/*<       KASE = 1 >*/
    *kase = 1;
/*<       JUMP = 3 >*/
    jump = 3;
/*<       RETURN >*/
    return 0;

/*     ................ ENTRY   (JUMP = 3) */
/*     X HAS BEEN OVERWRITTEN BY A*X. */

/*<    70 CONTINUE >*/
L70:
/*<       CALL DCOPY( N, X, 1, V, 1 ) >*/
    dcopy_(n, &x[1], &c__1, &v[1], &c__1);
/*<       ESTOLD = EST >*/
    estold = *est;
/*<       EST = DASUM( N, V, 1 ) >*/
    *est = dasum_(n, &v[1], &c__1);
/*<       DO 80 I = 1, N >*/
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
/*<    >*/
        d__1 = d_sign(&c_b11, &x[i__]);
        if (i_dnnt(&d__1) != isgn[i__]) {
            goto L90;
        }
/*<    80 CONTINUE >*/
/* L80: */
    }
/*     REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
/*<       GO TO 120 >*/
    goto L120;

/*<    90 CONTINUE >*/
L90:
/*     TEST FOR CYCLING. */
/*<    >*/
    if (*est <= estold) {
        goto L120;
    }

/*<       DO 100 I = 1, N >*/
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
/*<          X( I ) = SIGN( ONE, X( I ) ) >*/
        x[i__] = d_sign(&c_b11, &x[i__]);
/*<          ISGN( I ) = NINT( X( I ) ) >*/
        isgn[i__] = i_dnnt(&x[i__]);
/*<   100 CONTINUE >*/
/* L100: */
    }
/*<       KASE = 2 >*/
    *kase = 2;
/*<       JUMP = 4 >*/
    jump = 4;
/*<       RETURN >*/
    return 0;

/*     ................ ENTRY   (JUMP = 4) */
/*     X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */

/*<   110 CONTINUE >*/
L110:
/*<       JLAST = J >*/
    jlast = j;
/*<       J = IDAMAX( N, X, 1 ) >*/
    j = idamax_(n, &x[1], &c__1);
/*<       IF( ( X( JLAST ).NE.ABS( X( J ) ) ) .AND. ( ITER.LT.ITMAX ) ) THEN >*/
    if (x[jlast] != (d__1 = x[j], abs(d__1)) && iter < 5) {
/*<          ITER = ITER + 1 >*/
        ++iter;
/*<          GO TO 50 >*/
        goto L50;
/*<       END IF >*/
    }

/*     ITERATION COMPLETE.  FINAL STAGE. */

/*<   120 CONTINUE >*/
L120:
/*<       ALTSGN = ONE >*/
    altsgn = 1.;
/*<       DO 130 I = 1, N >*/
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
/*<          X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) >*/
        x[i__] = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) +
                1.);
/*<          ALTSGN = -ALTSGN >*/
        altsgn = -altsgn;
/*<   130 CONTINUE >*/
/* L130: */
    }
/*<       KASE = 1 >*/
    *kase = 1;
/*<       JUMP = 5 >*/
    jump = 5;
/*<       RETURN >*/
    return 0;

/*     ................ ENTRY   (JUMP = 5) */
/*     X HAS BEEN OVERWRITTEN BY A*X. */

/*<   140 CONTINUE >*/
L140:
/*<       TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) ) >*/
    temp = dasum_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.;
/*<       IF( TEMP.GT.EST ) THEN >*/
    if (temp > *est) {
/*<          CALL DCOPY( N, X, 1, V, 1 ) >*/
        dcopy_(n, &x[1], &c__1, &v[1], &c__1);
/*<          EST = TEMP >*/
        *est = temp;
/*<       END IF >*/
    }

/*<   150 CONTINUE >*/
L150:
/*<       KASE = 0 >*/
    *kase = 0;
/*<       RETURN >*/
    return 0;

/*     End of DLACON */

/*<       END >*/
} /* dlacon_ */
示例#7
0
/* $Procedure      CKR03 ( C-kernel, read pointing record, data type 3 ) */
/* Subroutine */ int ckr03_(integer *handle, doublereal *descr, doublereal *
	sclkdp, doublereal *tol, logical *needav, doublereal *record, logical 
	*found)
{
    /* Initialized data */

    static doublereal prevs = -1.;
    static doublereal prevn = -1.;
    static integer lhand = 0;
    static integer lbeg = -1;
    static integer lend = -1;

    /* System generated locals */
    integer i__1, i__2;

    /* Builtin functions */
    integer i_dnnt(doublereal *), s_rnge(char *, integer, char *, integer);

    /* Local variables */
    integer addr__, skip, psiz, i__, n;
    doublereal ldiff;
    integer laddr;
    doublereal rdiff;
    integer raddr;
    extern /* Subroutine */ int chkin_(char *, ftnlen), dafus_(doublereal *, 
	    integer *, integer *, doublereal *, integer *);
    integer nidir;
    doublereal lsclk;
    extern doublereal dpmax_(void);
    extern /* Subroutine */ int moved_(doublereal *, integer *, doublereal *);
    integer nrdir;
    doublereal rsclk;
    integer group;
    doublereal start;
    extern /* Subroutine */ int dafgda_(integer *, integer *, integer *, 
	    doublereal *);
    extern logical failed_(void);
    integer grpadd;
    doublereal buffer[100];
    integer remain, dirloc;
    extern integer lstled_(doublereal *, integer *, doublereal *);
    integer numrec;
    extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *, 
	    ftnlen);
    extern integer lstltd_(doublereal *, integer *, doublereal *);
    integer numint;
    doublereal nstart;
    extern logical return_(void);
    doublereal dcd[2];
    integer beg, icd[6], end;
    logical fnd;

/* $ Abstract */

/*     Read a pointing record from a CK segment, data type 3. */

/* $ 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 */

/*     CK */
/*     DAF */

/* $ Keywords */

/*     POINTING */

/* $ Declarations */
/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     HANDLE     I   File handle. */
/*     DESCR      I   Segment descriptor. */
/*     SCLKDP     I   Pointing request time. */
/*     TOL        I   Time tolerance. */
/*     NEEDAV     I   Angular velocity request flag. */
/*     RECORD     O   Pointing data record. */
/*     FOUND      O   True when data is found. */

/* $ Detailed_Input */

/*     HANDLE     is the integer handle of the CK file containing the */
/*                segment. */

/*     DESCR      is the descriptor of the segment. */

/*     SCLKDP     is the encoded spacecraft clock time for which */
/*                pointing is being requested. */

/*     TOL        is a time tolerance, measured in the same units as */
/*                encoded spacecraft clock. */

/*                When SCLKDP falls within the bounds of one of the */
/*                interpolation intervals then the tolerance has no */
/*                effect because pointing will be returned at the */
/*                request time. */

/*                However, if the request time is not in one of the */
/*                intervals, then the tolerance is used to determine */
/*                if pointing at one of the interval endpoints should */
/*                be returned. */

/*     NEEDAV     is true if angular velocity is requested. */

/* $ Detailed_Output */

/*     RECORD     is the record that CKE03 will evaluate to determine */
/*                the pointing. */

/*                When the request time falls within an interval for */
/*                which linear interpolation is valid, the values of */
/*                the two pointing instances that bracket the request */
/*                time are returned in RECORD as follows: */

/*                   RECORD( 1  ) = Left bracketing SCLK time. */

/*                   RECORD( 2  ) = lq0  \ */
/*                   RECORD( 3  ) = lq1   \    Left bracketing */
/*                   RECORD( 4  ) = lq2   /      quaternion. */
/*                   RECORD( 5  ) = lq3  / */

/*                   RECORD( 6  ) = lav1 \     Left bracketing */
/*                   RECORD( 7  ) = lav2       angular velocity */
/*                   RECORD( 8  ) = lav3 /       ( optional ) */

/*                   RECORD( 9  ) = Right bracketing SCLK time. */

/*                   RECORD( 10 ) = rq0  \ */
/*                   RECORD( 11 ) = rq1   \    Right bracketing */
/*                   RECORD( 12 ) = rq2   /       quaternion. */
/*                   RECORD( 13 ) = rq3  / */

/*                   RECORD( 14 ) = rav1 \     Right bracketing */
/*                   RECORD( 15 ) = rav2       angular velocity */
/*                   RECORD( 16 ) = rav3 /       ( optional ) */

/*                   RECORD( 17 ) = pointing request time, SCLKDP. */

/*                The quantities lq0 - lq3 and rq0 - rq3 are the */
/*                components of the quaternions that represent the */
/*                C-matrices associated with the times that bracket */
/*                the requested time. */

/*                The quantities lav1, lav2, lav3 and rav1, rav2, rav3 */
/*                are the components of the angular velocity vectors at */
/*                the respective bracketing times. The components of the */
/*                angular velocity vectors are specified relative to */
/*                the inertial reference frame of the segment. */

/*                If the request time does not fall within an */
/*                interpolation interval, but is within TOL of an */
/*                interval endpoint, the values of that pointing */
/*                instance are returned in both parts of RECORD */
/*                ( i.e. RECORD(1-9) and RECORD(10-16) ). */

/*     FOUND      is true if a record was found to satisfy the pointing */
/*                request.  This occurs when the time for which pointing */
/*                is requested falls inside one of the interpolation */
/*                intervals, or when the request time is within the */
/*                tolerance of an interval endpoint. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     1)  If the specified handle does not belong to an open DAF file, */
/*         an error is diagnosed by a routine that this routine calls. */

/*     2)  If DESCR is not a valid descriptor of a segment in the CK */
/*         file specified by HANDLE, the results of this routine are */
/*         unpredictable. */

/*     3)  If the segment is not of data type 3, as specified in the */
/*         third integer component of the segment descriptor, then */
/*         the error SPICE(WRONGDATATYPE) is signalled. */

/*     4)  If angular velocity data was requested but the segment */
/*         contains no such data, the error SPICE(NOAVDATA) is signalled. */

/* $ Files */

/*     The file containing the segment is specified by its handle and */
/*     should be opened for read or write access, either by CKLPF, */
/*     DAFOPR, or DAFOPW. */

/* $ Particulars */

/*     See the CK Required Reading file for a detailed description of */
/*     the structure of a type 3 pointing segment. */

/*     When the time for which pointing was requested falls within an */
/*     interpolation interval, then FOUND will be true and RECORD will */
/*     contain the pointing instances in the segment that bracket the */
/*     request time.  CKE03 will evaluate RECORD to give pointing at */
/*     the request time. */

/*     However, when the request time is not within any of the */
/*     interpolation intervals, then FOUND will be true only if the */
/*     interval endpoint closest to the request time is within the */
/*     tolerance specified by the user.  In this case both parts of */
/*     RECORD will contain this closest pointing instance, and CKE03 */
/*     will evaluate RECORD to give pointing at the time associated */
/*     with the returned pointing instance. */

/* $ Examples */

/*     The CKRnn routines are usually used in tandem with the CKEnn */
/*     routines, which evaluate the record returned by CKRnn to give */
/*     the pointing information and output time. */

/*     The following code fragment searches through all of the segments */
/*     in a file applicable to the Mars Observer spacecraft bus that */
/*     are of data type 3, for a particular spacecraft clock time. */
/*     It then evaluates the pointing for that epoch and prints the */
/*     result. */

/*           CHARACTER*(20)        SCLKCH */
/*           CHARACTER*(20)        SCTIME */
/*           CHARACTER*(40)        IDENT */

/*           INTEGER               I */
/*           INTEGER               SC */
/*           INTEGER               INST */
/*           INTEGER               HANDLE */
/*           INTEGER               DTYPE */
/*           INTEGER               ICD      (    6 ) */

/*           DOUBLE PRECISION      SCLKDP */
/*           DOUBLE PRECISION      TOL */
/*           DOUBLE PRECISION      CLKOUT */
/*           DOUBLE PRECISION      DESCR    (    5 ) */
/*           DOUBLE PRECISION      DCD      (    2 ) */
/*           DOUBLE PRECISION      RECORD   (   17 ) */
/*           DOUBLE PRECISION      CMAT     ( 3, 3 ) */
/*           DOUBLE PRECISION      AV       (    3 ) */

/*           LOGICAL               NEEDAV */
/*           LOGICAL               FND */
/*           LOGICAL               SFND */


/*           SC     = -94 */
/*           INST   = -94000 */
/*           DTYPE  =  3 */
/*           NEEDAV = .FALSE. */

/*     C */
/*     C     Load the MO SCLK kernel and the C-kernel. */
/*     C */
/*           CALL FURNSH ( 'MO_SCLK.TSC'       ) */
/*           CALL DAFOPR ( 'MO_CK.BC',  HANDLE ) */
/*     C */
/*     C     Get the spacecraft clock time. Then encode it for use */
/*     C     in the C-kernel. */
/*     C */
/*           WRITE (*,*) 'Enter spacecraft clock time string:' */
/*           READ (*,FMT='(A)') SCLKCH */

/*           CALL SCENCD ( SC, SCLKCH, SCLKDP ) */
/*     C */
/*     C     Use a tolerance of 2 seconds ( half of the nominal */
/*     C     separation between MO pointing instances ). */
/*     C */
/*           CALL SCTIKS ( SC, '0000000002:000', TOL ) */

/*     C */
/*     C     Search from the beginning of the CK file through all */
/*     C     of the segments. */
/*     C */
/*           CALL DAFBFS ( HANDLE ) */
/*           CALL DAFFNA ( SFND   ) */

/*           FND    = .FALSE. */

/*           DO WHILE ( ( SFND ) .AND. ( .NOT. FND ) ) */

/*     C */
/*     C        Get the segment identifier and descriptor. */
/*     C */

/*              CALL DAFGN ( IDENT                 ) */
/*              CALL DAFGS ( DESCR                 ) */
/*     C */
/*     C        Unpack the segment descriptor into its integer and */
/*     C        double precision components. */
/*     C */
/*              CALL DAFUS ( DESCR, 2, 6, DCD, ICD ) */

/*     C */
/*     C        Determine if this segment should be processed. */
/*     C */
/*              IF ( ( INST          .EQ. ICD( 1 ) ) .AND. */
/*          .        ( SCLKDP + TOL  .GE. DCD( 1 ) ) .AND. */
/*          .        ( SCLKDP - TOL  .LE. DCD( 2 ) ) .AND. */
/*          .        ( DTYPE         .EQ. ICD( 3 ) )      ) THEN */


/*                 CALL CKR03 ( HANDLE, DESCR, SCLKDP, TOL, NEEDAV, */
/*          .                   RECORD, FND ) */

/*                 IF ( FND ) THEN */

/*                    CALL CKE03 (NEEDAV,RECORD,CMAT,AV,CLKOUT) */

/*                    CALL SCDECD ( SC, CLKOUT, SCTIME ) */

/*                    WRITE (*,*) */
/*                    WRITE (*,*) 'Segment identifier: ', IDENT */
/*                    WRITE (*,*) */
/*                    WRITE (*,*) 'Pointing returned for time: ', */
/*          .                      SCTIME */
/*                    WRITE (*,*) */
/*                    WRITE (*,*) 'C-matrix:' */
/*                    WRITE (*,*) */
/*                    WRITE (*,*) ( CMAT(1,I), I = 1, 3 ) */
/*                    WRITE (*,*) ( CMAT(2,I), I = 1, 3 ) */
/*                    WRITE (*,*) ( CMAT(3,I), I = 1, 3 ) */
/*                    WRITE (*,*) */

/*                 END IF */

/*              END IF */

/*              CALL DAFFNA ( SFND ) */

/*           END DO */

/* $ Restrictions */

/*     1) The file containing the segment should be opened for read */
/*        or write access either by CKLPF, DAFOPR, or DAFOPW. */

/*     2) The record returned by this routine is intended to be */
/*        evaluated by CKE03. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     J.M. Lynch     (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.1.1, 22-AUG-2006 (EDW) */

/*        Replaced references to LDPOOL with references */
/*        to FURNSH. */

/* -    SPICELIB Version 1.1.0, 07-SEP-2001 (EDW) */

/*        Replaced DAFRDA call with DAFGDA. */
/*        Added IMPLICIT NONE. */

/* -    SPICELIB Version 1.0.0, 25-NOV-1992 (JML) */

/* -& */
/* $ Index_Entries */

/*     read ck type_3 pointing data record */

/* -& */

/*     SPICELIB functions */


/*     Local parameters */

/*        DIRSIZ     is the directory size. */

/*        BUFSIZ     is the maximum number of double precision numbers */
/*                   that we will read from the DAF file at one time. */
/*                   BUFSIZ is normally set equal to DIRSIZ. */

/*        ND         is the number of double precision components in an */
/*                   unpacked C-kernel segment descriptor. */

/*        NI         is the number of integer components in an unpacked */
/*                   C-kernel segment descriptor. */

/*        QSIZ       is the number of double precision numbers making up */
/*                   the quaternion portion of a pointing record. */

/*        QAVSIZ     is the number of double precision numbers making up */
/*                   the quaternion and angular velocity portion of a */
/*                   pointing record. */

/*        DTYPE      is the data type of the segment that this routine */
/*                   operates on. */



/*     Local variables */


/*     Saved variables. */


/*     Initial values. */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    } else {
	chkin_("CKR03", (ftnlen)5);
    }

/*     Start off with FOUND equal to false just in case a SPICELIB error */
/*     is signalled and the return mode is not set to ABORT. */

    *found = FALSE_;

/*     We need to look at a few of the descriptor components. */

/*     The unpacked descriptor contains the following information */
/*     about the segment: */

/*        DCD(1)  Initial encoded SCLK */
/*        DCD(2)  Final encoded SCLK */
/*        ICD(1)  Instrument */
/*        ICD(2)  Inertial reference frame */
/*        ICD(3)  Data type */
/*        ICD(4)  Angular velocity flag */
/*        ICD(5)  Initial address of segment data */
/*        ICD(6)  Final address of segment data */

    dafus_(descr, &c__2, &c__6, dcd, icd);

/*     Check to make sure that the segment is type 3. */

    if (icd[2] != 3) {
	setmsg_("The segment is not a type 3 segment.  Type is #", (ftnlen)47)
		;
	errint_("#", &icd[2], (ftnlen)1);
	sigerr_("SPICE(WRONGDATATYPE)", (ftnlen)20);
	chkout_("CKR03", (ftnlen)5);
	return 0;
    }

/*     Does this segment contain angular velocity? */

    if (icd[3] == 1) {
	psiz = 7;
    } else {
	psiz = 4;
	if (*needav) {
	    setmsg_("Segment does not contain angular velocity data.", (
		    ftnlen)47);
	    sigerr_("SPICE(NOAVDATA)", (ftnlen)15);
	    chkout_("CKR03", (ftnlen)5);
	    return 0;
	}
    }

/*     The beginning and ending addresses of the segment are in the */
/*     descriptor. */

    beg = icd[4];
    end = icd[5];

/*     The procedure used in finding a record to satisfy the request */
/*     for pointing is as follows: */

/*        1) Find the two pointing instances in the segment that bracket */
/*           the request time. */

/*           The pointing instance that brackets the request time on the */
/*           left is defined to be the one associated with the largest */
/*           time in the segment that is less than or equal to SCLKDP. */

/*           The pointing instance that brackets the request time on the */
/*           right is defined to be the one associated with the first */
/*           time in the segment greater than SCLKDP. */

/*           Since the times in the segment are strictly increasing the */
/*           left and right bracketing pointing instances are always */
/*           adjacent. */

/*        2) Determine if the bracketing times are in the same */
/*           interpolation interval. */

/*        3) If they are, then pointing at the request time may be */
/*           linearly interpolated from the bracketing times. */

/*        4) If the times that bracket the request time are not in the */
/*           same interval then, since they are adjacent in the segment */
/*           and since intervals begin and end at actual times, they must */
/*           both be interval endpoints.  Return the pointing instance */
/*           associated with the endpoint closest to the request time, */
/*           provided that it is within the tolerance. */


/*     Get the number of intervals and pointing instances ( records ) */
/*     in this segment, and from that determine the number of respective */
/*     directory epochs. */

    i__1 = end - 1;
    dafgda_(handle, &i__1, &end, buffer);
    numint = i_dnnt(buffer);
    numrec = i_dnnt(&buffer[1]);
    nidir = (numint - 1) / 100;
    nrdir = (numrec - 1) / 100;

/*     Check the FAILED flag just in case HANDLE is not attached to */
/*     any DAF file and the error action is not set to ABORT. You need */
/*     need to do this only after the first call to DAFGDA. */

    if (failed_()) {
	chkout_("CKR03", (ftnlen)5);
	return 0;
    }

/*     To find the times that bracket the request time we will first */
/*     find the greatest directory time less than the request time. */
/*     This will narrow down the search to a group of DIRSIZ or fewer */
/*     times where the Jth group is defined to contain SCLK times */
/*     ((J-1)*DIRSIZ + 1) through (J*DIRSIZ). */

/*     For example if DIRSIZ = 100 then: */

/*                         group   first time #     last time # */
/*                         -----  ---------------   ------------ */
/*                           1            1             100 */
/*                           2          101             200 */
/*                           .            .               . */
/*                           .            .               . */
/*                          10          901            1000 */
/*                           .            .               . */
/*                           .            .               . */
/*                     NRDIR+1     (NRDIR)*100+1     NUMREC */


/*     Thus if the Ith directory time is the largest one less than */
/*     our request time SCLKDP, then we know that: */

/*       SCLKS ( DIRSIZ * I ) <  SCLKDP  <= SCLKS ( DIRSIZ * (I+1) ) */

/*     where SCLKS is taken to be the array of NUMREC times associated */
/*     with the pointing instances. */

/*     Therefore, at least one of the bracketing times will come from */
/*     the (I+1)th group. */


/*     There is only one group if there are no directory epochs. */

    if (nrdir == 0) {
	group = 1;
    } else {

/*        Compute the location of the first directory epoch.  From the */
/*        beginning of the segment, we need to go through all of the */
/*        pointing numbers (PSIZ*NUMREC of them) and then through all of */
/*        the NUMREC SCLK times. */

	dirloc = beg + (psiz + 1) * numrec;

/*        Search through the directory times.  Read in as many as BUFSIZ */
/*        directory epochs at a time for comparison. */

	fnd = FALSE_;
	remain = nrdir;
	group = 0;
	while(! fnd) {

/*           The number of records to read into the buffer. */

	    n = min(remain,100);
	    i__1 = dirloc + n - 1;
	    dafgda_(handle, &dirloc, &i__1, buffer);
	    remain -= n;

/*           Determine the last directory element in BUFFER that's less */
/*           than SCLKDP. */

	    i__ = lstltd_(sclkdp, &n, buffer);
	    if (i__ < n) {
		group = group + i__ + 1;
		fnd = TRUE_;
	    } else if (remain == 0) {

/*              The request time is greater than the last directory time */
/*              so we want the last group in the segment. */

		group = nrdir + 1;
		fnd = TRUE_;
	    } else {

/*              Need to read another block of directory times. */

		dirloc += n;
		group += n;
	    }
	}
    }

/*     Now we know which group of DIRSIZ (or less) times to look at. */
/*     Out of the NUMREC SCLK times, the number that we should skip over */
/*     to get to the proper group is DIRSIZ * ( GROUP - 1 ). */

    skip = (group - 1) * 100;

/*     From this we can compute the address in the segment of the group */
/*     of times we want.  From the beginning, we need to pass through */
/*     PSIZ * NUMREC pointing numbers to get to the first SCLK time. */
/*     Then we skip over the number just computed above. */

    grpadd = beg + numrec * psiz + skip;

/*     The number of times that we have to look at may be less than */
/*     DIRSIZ.  However many there are, go ahead and read them into the */
/*     buffer. */

/* Computing MIN */
    i__1 = 100, i__2 = numrec - skip;
    n = min(i__1,i__2);
    i__1 = grpadd + n - 1;
    dafgda_(handle, &grpadd, &i__1, buffer);

/*     Find the largest time in the group less than or equal to the input */
/*     time. */

    i__ = lstled_(sclkdp, &n, buffer);

/*     Find the pointing instances in the segment that bracket the */
/*     request time and calculate the addresses for the pointing data */
/*     associated with these times. For cases in which the request time */
/*     is equal to one of the times in the segment, that time will be */
/*     the left bracketing time of the returned pair. */

/*     Need to handle the cases when the request time is greater than */
/*     the last or less than the first time in the segment separately. */

    if (i__ == 0) {
	if (group == 1) {

/*           The time occurs before the first time in the segment. Since */
/*           this time cannot possibly be in any of the intervals, the */
/*           first time can satisfy the request for pointing only if it */
/*           is within the tolerance of the request time. */

	    if (buffer[0] - *sclkdp <= *tol) {
		record[0] = buffer[0];
		record[8] = buffer[0];

/*              Calculate the address of the quaternion and angular */
/*              velocity data.  Then read it from the file. */

		i__1 = beg + psiz - 1;
		dafgda_(handle, &beg, &i__1, buffer);
		moved_(buffer, &psiz, &record[1]);
		moved_(buffer, &psiz, &record[9]);
		record[16] = *sclkdp;
		*found = TRUE_;
	    }
	    chkout_("CKR03", (ftnlen)5);
	    return 0;
	} else {

/*           The first time in the current group brackets the request */
/*           time on the right and the last time from the preceding */
/*           group brackets on the left. */

	    rsclk = buffer[0];
	    raddr = beg + skip * psiz;
	    i__1 = grpadd - 1;
	    i__2 = grpadd - 1;
	    dafgda_(handle, &i__1, &i__2, &lsclk);
	    laddr = raddr - psiz;
	}
    } else if (i__ == n) {

/*        There are two possible cases, but the same action can handle */
/*        both. */

/*        1) If this is the last group ( NRDIR + 1 ) then the request */
/*           time occurs on or after the last time in the segment. */
/*           In either case this last time can satisfy the request for */
/*           pointing only if it is within the tolerance of the request */
/*           time. */

/*        2) The request time is greater than or equal to the last time */
/*           in this group. Since this time is the same as the (I+1)th */
/*           directory time, and since the search on the directory times */
/*           used a strictly less than test, we know that the request */
/*           time must be equal to this time.  Just return the pointing */
/*           instance associated with the request time.  ( Note that */
/*           SCLKDP - BUFFER(N) will be zero in this case. ) */

	if (*sclkdp - buffer[(i__1 = n - 1) < 100 && 0 <= i__1 ? i__1 : 
		s_rnge("buffer", i__1, "ckr03_", (ftnlen)826)] <= *tol) {
	    record[0] = buffer[(i__1 = n - 1) < 100 && 0 <= i__1 ? i__1 : 
		    s_rnge("buffer", i__1, "ckr03_", (ftnlen)828)];
	    record[8] = buffer[(i__1 = n - 1) < 100 && 0 <= i__1 ? i__1 : 
		    s_rnge("buffer", i__1, "ckr03_", (ftnlen)829)];

/*           Calculate the address of the quaternion and angular */
/*           velocity data.  Then read it from the file. */

	    addr__ = beg + psiz * (skip + n - 1);
	    i__1 = addr__ + psiz - 1;
	    dafgda_(handle, &addr__, &i__1, buffer);
	    moved_(buffer, &psiz, &record[1]);
	    moved_(buffer, &psiz, &record[9]);
	    record[16] = *sclkdp;
	    *found = TRUE_;
	}
	chkout_("CKR03", (ftnlen)5);
	return 0;
    } else {

/*        The bracketing times are contained in this group. */

	lsclk = buffer[(i__1 = i__ - 1) < 100 && 0 <= i__1 ? i__1 : s_rnge(
		"buffer", i__1, "ckr03_", (ftnlen)855)];
	rsclk = buffer[(i__1 = i__) < 100 && 0 <= i__1 ? i__1 : s_rnge("buff"
		"er", i__1, "ckr03_", (ftnlen)856)];
	laddr = beg + (skip + i__ - 1) * psiz;
	raddr = laddr + psiz;
    }

/*     At this point we have the two times in the segment that bracket */
/*     the request time.  We also have the addresses of the pointing */
/*     data associated with those times. The task now is to determine */
/*     if the bracketing times fall in the same interval.  If so then */
/*     we can interpolate between them.  If they don't then return */
/*     pointing for whichever of the two times is closest to the */
/*     request time, provided that it is within the tolerance. */


/*     Find the interpolation interval that the request time is in and */
/*     determine if the bracketing SCLK's are both in it. */

/*     First check if the request time falls in the same interval as */
/*     it did last time.  We need to make sure that we are dealing */
/*     with the same segment as well as the same time range. */


/*     PREVS      is the start time of the interval that satisfied */
/*                the previous request for pointing. */

/*     PREVN      is the start time of the interval that followed */
/*                the interval specified above. */

/*     LHAND      is the handle of the file that PREVS and PREVN */
/*                were found in. */

/*     LBEG,      are the beginning and ending addresses of the */
/*     LEND       segment in the file LHAND that PREVS and PREVN */
/*                were found in. */

    if (*handle == lhand && beg == lbeg && end == lend && *sclkdp >= prevs && 
	    *sclkdp < prevn) {
	start = prevs;
	nstart = prevn;
    } else {

/*        The START times of all of the intervals are stored in the */
/*        segment and a directory of every hundredth START is also */
/*        stored. The procedure to find the bracketing interval start */
/*        times is identical to the one used above for finding the */
/*        bracketing times. */

/*        The directory epochs narrow down the search for the times that */
/*        bracket the request time to a group of DIRSIZ or fewer records. */


/*        There is only one group if there are no directory epochs. */

	if (nidir == 0) {
	    group = 1;
	} else {

/*           Compute the location of the first directory epoch.  From the */
/*           beginning of the segment, we need to go through all of the */
/*           pointing numbers (PSIZ*NUMREC of them), then through all of */
/*           the NUMREC SCLK times and NRDIR directory times, and then */
/*           finally through the NUMINT interval start times. */

	    dirloc = beg + (psiz + 1) * numrec + nrdir + numint;

/*           Locate the largest directory time less than the */
/*           request time SCLKDP. */

/*           Read in as many as BUFSIZ directory epochs at a time for */
/*           comparison. */

	    fnd = FALSE_;
	    remain = nidir;
	    group = 0;
	    while(! fnd) {

/*              The number of records to read into the buffer. */

		n = min(remain,100);
		i__1 = dirloc + n - 1;
		dafgda_(handle, &dirloc, &i__1, buffer);
		remain -= n;

/*              Determine the last directory element in BUFFER that's */
/*              less than SCLKDP. */

		i__ = lstltd_(sclkdp, &n, buffer);
		if (i__ < n) {
		    group = group + i__ + 1;
		    fnd = TRUE_;
		} else if (remain == 0) {

/*                 The request time is greater than the last directory */
/*                 time so we want the last group in the segment. */

		    group = nidir + 1;
		    fnd = TRUE_;
		} else {

/*                 Need to read another block of directory times. */

		    dirloc += n;
		    group += n;
		}
	    }
	}

/*        Now we know which group of DIRSIZ (or less) times to look at. */
/*        Out of the NUMINT SCLK START times, the number that we should */
/*        skip over to get to the proper group is DIRSIZ * ( GROUP - 1 ). */

	skip = (group - 1) * 100;

/*        From this we can compute the address in the segment of the */
/*        group of times we want.  To get to the first interval start */
/*        time we must pass over PSIZ * NUMREC pointing numbers, NUMREC */
/*        SCLK times, and NRDIR SCLK directory times.  Then we skip */
/*        over the number just computed above. */

	grpadd = beg + (psiz + 1) * numrec + nrdir + skip;

/*        The number of times that we have to look at may be less than */
/*        DIRSIZ.  However many there are, go ahead and read them into */
/*        the buffer. */

/* Computing MIN */
	i__1 = 100, i__2 = numint - skip;
	n = min(i__1,i__2);
	i__1 = grpadd + n - 1;
	dafgda_(handle, &grpadd, &i__1, buffer);

/*        Find the index of the largest time in the group that is less */
/*        than or equal to the input time. */

	i__ = lstled_(sclkdp, &n, buffer);
	if (i__ == 0) {

/*           The first start time in the buffer is the start of the */
/*           interval following the one containing the request time. */

/*           We don't need to check if GROUP = 1 because the case of */
/*           the request time occurring before the first time in the */
/*           segment has already been handled. */

	    nstart = buffer[0];
	    addr__ = grpadd - 1;
	    dafgda_(handle, &addr__, &addr__, &start);
	} else if (i__ == n) {
	    if (group == nidir + 1) {

/*              This is the last interval in the segment. */

		start = buffer[(i__1 = n - 1) < 100 && 0 <= i__1 ? i__1 : 
			s_rnge("buffer", i__1, "ckr03_", (ftnlen)1040)];
		nstart = dpmax_();
	    } else {

/*              The last START time in this group is equal to the */
/*              request time. */

		start = buffer[(i__1 = n - 1) < 100 && 0 <= i__1 ? i__1 : 
			s_rnge("buffer", i__1, "ckr03_", (ftnlen)1049)];
		addr__ = grpadd + n;
		dafgda_(handle, &addr__, &addr__, &nstart);
	    }
	} else {

/*           The bracketing START times are contained in this group. */

	    start = buffer[(i__1 = i__ - 1) < 100 && 0 <= i__1 ? i__1 : 
		    s_rnge("buffer", i__1, "ckr03_", (ftnlen)1061)];
	    nstart = buffer[(i__1 = i__) < 100 && 0 <= i__1 ? i__1 : s_rnge(
		    "buffer", i__1, "ckr03_", (ftnlen)1062)];
	}

/*        Save the information about the interval and segment. */

	lhand = *handle;
	lbeg = beg;
	lend = end;
	prevs = start;
	prevn = nstart;
    }

/*     Check and see if the bracketing pointing instances belong */
/*     to the same interval.  If they do then we can interpolate */
/*     between them, if not then check to see if the closer of */
/*     the two to the request time lies within the tolerance. */

/*     The left bracketing time will always belong to the same */
/*     interval as the request time, therefore we need to check */
/*     only that the right bracketing time is less than the start */
/*     time of the next interval. */

    if (rsclk < nstart) {
	record[0] = lsclk;
	i__1 = laddr + psiz - 1;
	dafgda_(handle, &laddr, &i__1, &record[1]);
	record[8] = rsclk;
	i__1 = raddr + psiz - 1;
	dafgda_(handle, &raddr, &i__1, &record[9]);
	record[16] = *sclkdp;
	*found = TRUE_;
    } else {
	ldiff = *sclkdp - lsclk;
	rdiff = rsclk - *sclkdp;
	if (ldiff <= *tol || rdiff <= *tol) {

/*           Return the pointing instance closest to the request time. */

/*           If the request time is midway between LSCLK and RSCLK then */
/*           grab the pointing instance associated with the greater time. */

	    if (ldiff < rdiff) {
		record[0] = lsclk;
		record[8] = lsclk;
		i__1 = laddr + psiz - 1;
		dafgda_(handle, &laddr, &i__1, buffer);
		moved_(buffer, &psiz, &record[1]);
		moved_(buffer, &psiz, &record[9]);
	    } else {
		record[0] = rsclk;
		record[8] = rsclk;
		i__1 = raddr + psiz - 1;
		dafgda_(handle, &raddr, &i__1, buffer);
		moved_(buffer, &psiz, &record[1]);
		moved_(buffer, &psiz, &record[9]);
	    }
	    record[16] = *sclkdp;
	    *found = TRUE_;
	}
    }
    chkout_("CKR03", (ftnlen)5);
    return 0;
} /* ckr03_ */
示例#8
0
/* Subroutine */ int dlacon_(integer *n, doublereal *v, doublereal *x, 
	integer *isgn, doublereal *est, integer *kase)
{
/*  -- LAPACK auxiliary routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       February 29, 1992   


    Purpose   
    =======   

    DLACON estimates the 1-norm of a square, real matrix A.   
    Reverse communication is used for evaluating matrix-vector products. 
  

    Arguments   
    =========   

    N      (input) INTEGER   
           The order of the matrix.  N >= 1.   

    V      (workspace) DOUBLE PRECISION array, dimension (N)   
           On the final return, V = A*W,  where  EST = norm(V)/norm(W)   
           (W is not returned).   

    X      (input/output) DOUBLE PRECISION array, dimension (N)   
           On an intermediate return, X should be overwritten by   
                 A * X,   if KASE=1,   
                 A' * X,  if KASE=2,   
           and DLACON must be re-called with all the other parameters   
           unchanged.   

    ISGN   (workspace) INTEGER array, dimension (N)   

    EST    (output) DOUBLE PRECISION   
           An estimate (a lower bound) for norm(A).   

    KASE   (input/output) INTEGER   
           On the initial call to DLACON, KASE should be 0.   
           On an intermediate return, KASE will be 1 or 2, indicating   
           whether X should be overwritten by A * X  or A' * X.   
           On the final return from DLACON, KASE will again be 0.   

    Further Details   
    ======= =======   

    Contributed by Nick Higham, University of Manchester.   
    Originally named SONEST, dated March 16, 1988.   

    Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of 
  
    a real or complex matrix, with applications to condition estimation", 
  
    ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.   

    ===================================================================== 
  


    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static integer c__1 = 1;
    static doublereal c_b11 = 1.;
    
    /* System generated locals */
    integer i__1;
    doublereal d__1;
    /* Builtin functions */
    double d_sign(doublereal *, doublereal *);
    integer i_dnnt(doublereal *);
    /* Local variables */
    static integer iter;
    static doublereal temp;
    static integer jump, i, j;
    extern doublereal dasum_(integer *, doublereal *, integer *);
    static integer jlast;
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
	    doublereal *, integer *);
    extern integer idamax_(integer *, doublereal *, integer *);
    static doublereal altsgn, estold;



#define ISGN(I) isgn[(I)-1]
#define X(I) x[(I)-1]
#define V(I) v[(I)-1]


    if (*kase == 0) {
	i__1 = *n;
	for (i = 1; i <= *n; ++i) {
	    X(i) = 1. / (doublereal) (*n);
/* L10: */
	}
	*kase = 1;
	jump = 1;
	return 0;
    }

    switch (jump) {
	case 1:  goto L20;
	case 2:  goto L40;
	case 3:  goto L70;
	case 4:  goto L110;
	case 5:  goto L140;
    }

/*     ................ ENTRY   (JUMP = 1)   
       FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY A*X. */

L20:
    if (*n == 1) {
	V(1) = X(1);
	*est = abs(V(1));
/*        ... QUIT */
	goto L150;
    }
    *est = dasum_(n, &X(1), &c__1);

    i__1 = *n;
    for (i = 1; i <= *n; ++i) {
	X(i) = d_sign(&c_b11, &X(i));
	ISGN(i) = i_dnnt(&X(i));
/* L30: */
    }
    *kase = 2;
    jump = 2;
    return 0;

/*     ................ ENTRY   (JUMP = 2)   
       FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. */

L40:
    j = idamax_(n, &X(1), &c__1);
    iter = 2;

/*     MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */

L50:
    i__1 = *n;
    for (i = 1; i <= *n; ++i) {
	X(i) = 0.;
/* L60: */
    }
    X(j) = 1.;
    *kase = 1;
    jump = 3;
    return 0;

/*     ................ ENTRY   (JUMP = 3)   
       X HAS BEEN OVERWRITTEN BY A*X. */

L70:
    dcopy_(n, &X(1), &c__1, &V(1), &c__1);
    estold = *est;
    *est = dasum_(n, &V(1), &c__1);
    i__1 = *n;
    for (i = 1; i <= *n; ++i) {
	d__1 = d_sign(&c_b11, &X(i));
	if (i_dnnt(&d__1) != ISGN(i)) {
	    goto L90;
	}
/* L80: */
    }
/*     REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
    goto L120;

L90:
/*     TEST FOR CYCLING. */
    if (*est <= estold) {
	goto L120;
    }

    i__1 = *n;
    for (i = 1; i <= *n; ++i) {
	X(i) = d_sign(&c_b11, &X(i));
	ISGN(i) = i_dnnt(&X(i));
/* L100: */
    }
    *kase = 2;
    jump = 4;
    return 0;

/*     ................ ENTRY   (JUMP = 4)   
       X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. */

L110:
    jlast = j;
    j = idamax_(n, &X(1), &c__1);
    if (X(jlast) != (d__1 = X(j), abs(d__1)) && iter < 5) {
	++iter;
	goto L50;
    }

/*     ITERATION COMPLETE.  FINAL STAGE. */

L120:
    altsgn = 1.;
    i__1 = *n;
    for (i = 1; i <= *n; ++i) {
	X(i) = altsgn * ((doublereal) (i - 1) / (doublereal) (*n - 1) + 1.);
	altsgn = -altsgn;
/* L130: */
    }
    *kase = 1;
    jump = 5;
    return 0;

/*     ................ ENTRY   (JUMP = 5)   
       X HAS BEEN OVERWRITTEN BY A*X. */

L140:
    temp = dasum_(n, &X(1), &c__1) / (doublereal) (*n * 3) * 2.;
    if (temp > *est) {
	dcopy_(n, &X(1), &c__1, &V(1), &c__1);
	*est = temp;
    }

L150:
    *kase = 0;
    return 0;

/*     End of DLACON */

} /* dlacon_ */
示例#9
0
/* $Procedure ZZCKCVR2 ( Private --- C-kernel segment coverage, type 02 ) */
/* Subroutine */ int zzckcvr2_(integer *handle, integer *arrbeg, integer *
	arrend, doublereal *schedl)
{
    /* System generated locals */
    integer i__1, i__2, i__3;
    doublereal d__1;

    /* Builtin functions */
    integer i_dnnt(doublereal *), s_rnge(char *, integer, char *, integer);

    /* Local variables */
    integer nrec;
    doublereal last[100];
    integer i__, begat, endat;
    extern /* Subroutine */ int chkin_(char *, ftnlen);
    doublereal first[100];
    extern /* Subroutine */ int dafgda_(integer *, integer *, integer *, 
	    doublereal *), chkout_(char *, ftnlen), wninsd_(doublereal *, 
	    doublereal *, doublereal *);
    integer arrsiz;
    extern logical return_(void);
    integer get, got;

/* $ Abstract */

/*     SPICE Private routine intended solely for the support of SPICE */
/*     routines.  Users should not call this routine directly due */
/*     to the volatile nature of this routine. */

/*     Determine the "window" of coverage of a type 02 C-kernel segment. */

/* $ 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 */

/*     CK */
/*     DAF */

/* $ Keywords */

/*     CK */
/*     UTILITY */
/*     PRIVATE */

/* $ Declarations */
/* $ Brief_I/O */

/*     VARIABLE  I/O  DESCRIPTION */
/*     --------  ---  -------------------------------------------------- */
/*     HANDLE     I   Handle of a C-kernel open for read access */
/*     ARRBEG     I   Beginning DAF address */
/*     ARREND     I   Ending DAF address */
/*     SCHEDL    I/O  An initialized window/schedule of interval */

/* $ Detailed_Input */

/*     HANDLE     is the handle of some DAF that is open for reading. */

/*     ARRBEG     is the beginning address of a type 02 segment */

/*     ARREND     is the ending address of a type 02 segment. */

/*     SCHEDL     is a schedule (window) of intervals, to which the */
/*                intervals of coverage for this segment will be added. */

/* $ Detailed_Output */

/*     SCHEDL     the input schedule updated to include the intervals */
/*                of coverage for this segment. */

/* $ Parameters */

/*     None. */

/* $ Files */

/*     This routine reads the contents of the file associated with */
/*     HANDLE to locate coverage intervals. */

/* $ Exceptions */

/*     Routines in the call tree of this routine may signal errors */
/*     if insufficient room in SCHEDL exists or other error */
/*     conditions relating to file access arise. */

/* $ Particulars */

/*     This is a utility routine that determines the intervals */
/*     of coverage for a type 02 C-kernel segment. */

/* $ Examples */

/*     None. */

/* $ Restrictions */

/*     None. */

/* $ Author_and_Institution */

/*     W.L. Taber      (JPL) */
/*     F.S. Turner     (JPL) */
/*     B.V. Semenov    (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SUPPORT Version 2.1.0, 13-FEB-2003 (BVS) */

/*        Replaced MAX with MIN in the assignment of GET. This bug */
/*        caused the routine either to look beyond the end of the */
/*        start/stop time blocks of the segment (for NREC < BSIZE) or to */
/*        attempt to fill in internal buffers with more data than they */
/*        were declared to hold (for NREC > BSIZE.) */

/* -    SUPPORT Version 2.0.0, 27-AUG-2002 (FST) */

/*        Updated this routine to use DAFGDA instead of DAFRDA. */
/*        This allows the module to process non-native kernels. */

/*        Header and code clean up for delivery to SUPPORT. */

/* -    SUPPORT Version 1.0.0, 14-Feb-2000 (WLT) */

/*        Happy Valentine's Day. */

/* -& */

/*     SPICELIB Functions */


/*     Local Parameters */


/*     Local Variables */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    } else {
	chkin_("ZZCKCVR2", (ftnlen)8);
    }

/*     Determine the size of the array and the number of records */
/*     in it. */

    arrsiz = *arrend - *arrbeg + 1;
    d__1 = ((doublereal) arrsiz * 100. + 1.) / 1001.;
    nrec = i_dnnt(&d__1);

/*     The variable GOT tells us how many time endpoints we've */
/*     gotten so far. */

    got = 0;
    while(got < nrec) {
/* Computing MIN */
	i__1 = 100, i__2 = nrec - got;
	get = min(i__1,i__2);
	begat = *arrbeg + (nrec << 3) + got;
	endat = *arrbeg + (nrec << 3) + nrec + got;

/*        Retrieve the list next list of windows. */

	i__1 = begat + get - 1;
	dafgda_(handle, &begat, &i__1, first);
	i__1 = endat + get - 1;
	dafgda_(handle, &endat, &i__1, last);

/*        Insert the coverage intervals into the schedule. */

	i__1 = get;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    wninsd_(&first[(i__2 = i__ - 1) < 100 && 0 <= i__2 ? i__2 : 
		    s_rnge("first", i__2, "zzckcvr2_", (ftnlen)214)], &last[(
		    i__3 = i__ - 1) < 100 && 0 <= i__3 ? i__3 : s_rnge("last",
		     i__3, "zzckcvr2_", (ftnlen)214)], schedl);
	}
	got += get;
    }
    chkout_("ZZCKCVR2", (ftnlen)8);
    return 0;
} /* zzckcvr2_ */
示例#10
0
/* $Procedure      SPKE18 ( S/P Kernel, evaluate, type 18 ) */
/* Subroutine */ int spke18_(doublereal *et, doublereal *record, doublereal *
	state)
{
    /* System generated locals */
    integer i__1, i__2;

    /* Builtin functions */
    integer i_dnnt(doublereal *), s_rnge(char *, integer, char *, integer);

    /* Local variables */
    integer from;
    extern /* Subroutine */ int vequ_(doublereal *, doublereal *);
    doublereal work[516]	/* was [258][2] */;
    integer i__, j, n;
    extern /* Subroutine */ int chkin_(char *, ftnlen);
    doublereal vbuff[6];
    integer to;
    doublereal locrec[129];
    integer packsz;
    extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen);
    extern doublereal lgrint_(integer *, doublereal *, doublereal *, 
	    doublereal *, doublereal *);
    extern /* Subroutine */ int hrmint_(integer *, doublereal *, doublereal *,
	     doublereal *, doublereal *, doublereal *, doublereal *), setmsg_(
	    char *, ftnlen), errint_(char *, integer *, ftnlen), xpsgip_(
	    integer *, integer *, doublereal *);
    extern logical return_(void);
    integer xstart, subtyp, ystart;

/* $ Abstract */

/*     Evaluate a single data record from a type 18 SPK segment. */

/* $ 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 */

/*     SPK */

/* $ Keywords */

/*     EPHEMERIS */

/* $ Declarations */
/* $ Abstract */

/*     Declare parameters specific to SPK type 18. */

/* $ 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 */

/*     SPK */

/* $ Keywords */

/*     SPK */

/* $ Restrictions */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman      (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 18-AUG-2002 (NJB) */

/* -& */

/*     SPK type 18 subtype codes: */


/*     Subtype 0:  Hermite interpolation, 12-element packets, order */
/*                 reduction at boundaries to preceding number */
/*                 equivalent to 3 mod 4. */


/*     Subtype 1:  Lagrange interpolation, 6-element packets, order */
/*                 reduction at boundaries to preceding odd number. */


/*     Packet sizes associated with the various subtypes: */


/*     End of include file spk18.inc. */

/* $ Abstract */

/*     Declare SPK data record size.  This record is declared in */
/*     SPKPVN and is passed to SPK reader (SPKRxx) and evaluator */
/*     (SPKExx) routines. */

/* $ 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 */

/*     SPK */

/* $ Keywords */

/*     SPK */

/* $ Restrictions */

/*     1) If new SPK types are added, it may be necessary to */
/*        increase the size of this record.  The header of SPKPVN */
/*        should be updated as well to show the record size */
/*        requirement for each data type. */

/* $ Author_and_Institution */

/*     N.J. Bachman      (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 16-AUG-2002 (NJB) */

/* -& */

/*     End include file spkrec.inc */

/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     MAXREC     P   Maximum size of SPK record.  See SPKPVN. */
/*     ET         I   Epoch for which a state is desired. */
/*     RECORD     I   Record from a type 18 SPK segment valid for ET. */
/*     STATE      O   State (position and velocity) at epoch ET. */

/* $ Detailed_Input */

/*     ET             is the epoch for which a state vector is desired. */

/*     RECORD         is a record from a type 18 SPK segment which, when */
/*                    evaluated at epoch ET, will give the state */
/*                    (position and velocity) of some body, relative to */
/*                    some center, in some inertial reference frame. */

/*                    The structure of the record is as follows: */

/*                       +----------------------+ */
/*                       | subtype code         | */
/*                       +----------------------+ */
/*                       | number of packets (n)| */
/*                       +----------------------+ */
/*                       | packet 1             | */
/*                       +----------------------+ */
/*                       | packet 2             | */
/*                       +----------------------+ */
/*                                . */
/*                                . */
/*                                . */
/*                       +----------------------+ */
/*                       | packet n             | */
/*                       +----------------------+ */
/*                       | epochs 1--n          | */
/*                       +----------------------+ */

/* $ Detailed_Output */

/*     STATE    is the state vector at epoch ET. Its contents are, in */
/*              order, X, Y, Z, X', Y', and Z'. Units are km and km/sec. */

/* $ Parameters */

/*     MAXREC   is the maximum size of SPK record.  See the SPICELIB */
/*              routine SPKPVN for details. */

/* $ Exceptions */

/*     None.  This routine assumes that the input record is valid. */

/* $ Files */

/*     None. */

/* $ Particulars */

/*     The exact format and structure of type 18 (MEX/Rosetta Orbit */
/*     file interpolation) SPK segments is described in the SPK */
/*     Required Reading. */

/* $ Examples */

/*     The SPKEnn routines are almost always used in conjunction with */
/*     the corresponding SPKRnn routines, which read the records from */
/*     SPK files. */

/*     The data returned by the SPKRnn routine is in a raw form, taken */
/*     directly from the segment.  As such, it will be not be directly */
/*     useful to a user unless they have a complete understanding of the */
/*     structure of the data type.  Given that understanding, however, */
/*     the SPKRnn routines could be used to "dump" and check segment data */
/*     for a particular epoch before evaluating the record to obtain a */
/*     state vector, as in the example which follows. */


/*     C */
/*     C     Get a segment applicable to a specified body and epoch. */
/*     C */
/*           CALL SPKSFS ( BODY, ET, HANDLE, DESCR, IDENT, FOUND ) */

/*     C */
/*     C     Look at parts of the descriptor. */
/*     C */
/*           CALL DAFUS ( DESCR, 2, 6, DCD, ICD ) */

/*           CENTER = ICD( 2 ) */
/*           REF    = ICD( 3 ) */
/*           TYPE   = ICD( 4 ) */

/*           IF ( TYPE .EQ. 18 ) THEN */

/*              CALL SPKR18 ( HANDLE, DESCR, ET, RECORD ) */
/*                  . */
/*                  .  Look at the RECORD data. */
/*                  . */
/*              CALL SPKE18 ( ET, RECORD, STATE ) */
/*                  . */
/*                  .  Check out the evaluated state. */
/*                  . */
/*           END IF */

/* $ Restrictions */

/*     1)  This routine assumes that the input record is valid.  Any */
/*         checking of the input data is assumed to have been performed */
/*         when the source SPK file was created. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman   (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.1.0, 05-NOV-2005 (NJB) */

/*        Updated to remove non-standard use of duplicate arguments */
/*        in XPOSEG and LGRINT calls. */

/* -    SPICELIB Version 1.0.0, 17-AUG-2002 (NJB) */

/* -& */
/* $ Index_Entries */

/*     evaluate type_18 spk segment */

/* -& */
/* $ Revisions */

/* -    SPICELIB Version 1.1.0, 05-NOV-2005 (NJB) */

/*        Updated to remove non-standard use of duplicate arguments */
/*        in XPOSEG and LGRINT calls. */

/* -& */

/*     SPICELIB functions */


/*     Local parameters */


/*     Index of subtype code in record: */


/*     Index of packet count in record: */


/*     Index at which packets start: */


/*     Maximum polynomial degree: */


/*     Local variables */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    }
    chkin_("SPKE18", (ftnlen)6);

/*     Capture the subtype from the record and set the packet size */
/*     accordingly. */

    subtyp = i_dnnt(record);
    if (subtyp == 0) {
	packsz = 12;
    } else if (subtyp == 1) {
	packsz = 6;
    } else {
	setmsg_("Unexpected SPK type 18 subtype found in type 18 record.", (
		ftnlen)55);
	errint_("#", &subtyp, (ftnlen)1);
	sigerr_("SPICE(INVALIDVALUE)", (ftnlen)19);
	chkout_("SPKE18", (ftnlen)6);
	return 0;
    }

/*     Get the packet count. */

    n = i_dnnt(&record[1]);
    if (subtyp == 1) {

/*        This is the easy case:  we perform Lagrange interpolation */
/*        on each state component. */

/*        We'll transpose the state information in the input record so */
/*        that contiguous pieces of it can be shoved directly into the */
/*        interpolation routine LGRINT. */

	n = i_dnnt(&record[1]);
	xpsgip_(&packsz, &n, &record[2]);

/*        We interpolate each state component in turn. */

	xstart = n * packsz + 3;
	i__1 = packsz;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    ystart = n * (i__ - 1) + 3;
	    state[(i__2 = i__ - 1) < 6 && 0 <= i__2 ? i__2 : s_rnge("state", 
		    i__2, "spke18_", (ftnlen)310)] = lgrint_(&n, &record[
		    xstart - 1], &record[ystart - 1], locrec, et);
	}
    } else {

/*        We interpolate each state component in turn.  Position and */
/*        velocity are interpolated separately. */

	xstart = packsz * n + 3;
	for (i__ = 1; i__ <= 3; ++i__) {
	    i__1 = n;
	    for (j = 1; j <= i__1; ++j) {

/*              For the Jth input packet, copy the Ith position and */
/*              velocity components into the local record buffer LOCREC. */

		from = packsz * (j - 1) + 2 + i__;
		to = (j << 1) - 1;
		locrec[(i__2 = to - 1) < 129 && 0 <= i__2 ? i__2 : s_rnge(
			"locrec", i__2, "spke18_", (ftnlen)335)] = record[
			from - 1];
		locrec[(i__2 = to) < 129 && 0 <= i__2 ? i__2 : s_rnge("locrec"
			, i__2, "spke18_", (ftnlen)336)] = record[from + 2];
	    }

/*           Interpolate the Ith position and velocity components of the */
/*           state.  We'll keep the position and overwrite the velocity. */

	    hrmint_(&n, &record[xstart - 1], locrec, et, work, &state[(i__1 = 
		    i__ - 1) < 6 && 0 <= i__1 ? i__1 : s_rnge("state", i__1, 
		    "spke18_", (ftnlen)344)], &state[(i__2 = i__ + 2) < 6 && 
		    0 <= i__2 ? i__2 : s_rnge("state", i__2, "spke18_", (
		    ftnlen)344)]);
	}

/*        Now interpolate velocity, using separate velocity data and */
/*        acceleration. */

	for (i__ = 1; i__ <= 3; ++i__) {
	    i__1 = n;
	    for (j = 1; j <= i__1; ++j) {

/*              For the Jth input packet, copy the Ith position and */
/*              velocity components into the local record buffer LOCREC. */

		from = packsz * (j - 1) + 2 + packsz / 2 + i__;
		to = (j << 1) - 1;
		locrec[(i__2 = to - 1) < 129 && 0 <= i__2 ? i__2 : s_rnge(
			"locrec", i__2, "spke18_", (ftnlen)368)] = record[
			from - 1];
		locrec[(i__2 = to) < 129 && 0 <= i__2 ? i__2 : s_rnge("locrec"
			, i__2, "spke18_", (ftnlen)369)] = record[from + 2];
	    }

/*           Interpolate the Ith velocity and acceleration components of */
/*           the state.  We'll capture the result in a temporary buffer, */
/*           then transfer the velocity to the output state array. */

	    hrmint_(&n, &record[xstart - 1], locrec, et, work, &vbuff[(i__1 = 
		    i__ - 1) < 6 && 0 <= i__1 ? i__1 : s_rnge("vbuff", i__1, 
		    "spke18_", (ftnlen)378)], &vbuff[(i__2 = i__ + 2) < 6 && 
		    0 <= i__2 ? i__2 : s_rnge("vbuff", i__2, "spke18_", (
		    ftnlen)378)]);
	}

/*        Fill in the velocity in the output state using the results of */
/*        interpolating velocity and acceleration. */

	vequ_(vbuff, &state[3]);
    }
    chkout_("SPKE18", (ftnlen)6);
    return 0;
} /* spke18_ */
示例#11
0
/* $Procedure ZZCKCV02 ( Private --- C-kernel segment coverage, type 02 ) */
/* Subroutine */ int zzckcv02_(integer *handle, integer *arrbeg, integer *
	arrend, integer *sclkid, doublereal *tol, char *timsys, doublereal *
	schedl, ftnlen timsys_len)
{
    /* System generated locals */
    integer i__1, i__2;
    doublereal d__1;

    /* Builtin functions */
    integer i_dnnt(doublereal *), s_rnge(char *, integer, char *, integer);

    /* Local variables */
    integer nrec;
    doublereal last[100];
    extern /* Subroutine */ int sct2e_(integer *, doublereal *, doublereal *);
    integer i__, begat;
    doublereal begin;
    integer endat;
    extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
	     ftnlen, ftnlen);
    logical istdb;
    extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen);
    doublereal first[100];
    extern logical eqstr_(char *, char *, ftnlen, ftnlen);
    extern /* Subroutine */ int dafgda_(integer *, integer *, integer *, 
	    doublereal *);
    doublereal et, finish;
    extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen), setmsg_(char *, ftnlen), wninsd_(doublereal *, 
	    doublereal *, doublereal *);
    integer arrsiz;
    extern logical return_(void);
    integer get, got;

/* $ Abstract */

/*     SPICE Private routine intended solely for the support of SPICE */
/*     routines.  Users should not call this routine directly due */
/*     to the volatile nature of this routine. */

/*     Determine the "window" of coverage of a type 02 C-kernel segment. */

/* $ 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 */

/*     CK */
/*     DAF */

/* $ Keywords */

/*     CK */
/*     UTILITY */
/*     PRIVATE */

/* $ Declarations */
/* $ Brief_I/O */

/*     VARIABLE  I/O  DESCRIPTION */
/*     --------  ---  -------------------------------------------------- */
/*     HANDLE     I   Handle of a C-kernel open for read access */
/*     ARRBEG     I   Beginning DAF address */
/*     ARREND     I   Ending DAF address */
/*     SCLKID     I   ID of SCLK associated with segment. */
/*     TOL        I   Tolerance in ticks. */
/*     TIMSYS     I   Time system used to represent coverage. */
/*     SCHEDL    I/O  An initialized window/schedule of interval */

/* $ Detailed_Input */

/*     HANDLE     is the handle of some DAF that is open for reading. */

/*     ARRBEG     is the beginning address of a type 02 segment */

/*     ARREND     is the ending address of a type 02 segment. */


/*     SCLKID     is the ID code of the spacecraft clock associated with */
/*                the object for which the segment contains pointing. */
/*                This is the ID code used by the SCLK conversion */
/*                routines. */

/*     TOL        is a tolerance value expressed in ticks of the */
/*                spacecraft clock associated with the segment. Before */
/*                each interval is inserted into the coverage window, */
/*                the intervals are expanded by TOL:  the left endpoint */
/*                of each interval is reduced by TOL and the right */
/*                endpoint is increased by TOL.  Any intervals that */
/*                overlap as a result of the expansion are merged. */

/*                The coverage window returned when TOL > 0 indicates */
/*                the coverage provided by the file to the CK readers */
/*                CKGPAV and CKGP when that value of TOL is passed to */
/*                them as an input. */


/*     TIMSYS     is a string indicating the time system used in the */
/*                output coverage window.  TIMSYS may have the values: */

/*                   'SCLK'    Elements of SCHEDL are expressed in */
/*                             encoded SCLK ("ticks"), where the clock */
/*                             is associated with the object designated */
/*                             by IDCODE. */

/*                   'TDB'     Elements of SCHEDL are expressed as */
/*                             seconds past J2000 TDB. */

/*                TIMSYS must be consistent with the system used for */
/*                the contents of SCHEDL on input, if any. */


/*     SCHEDL     is a schedule (window) of intervals, to which the */
/*                intervals of coverage for this segment will be added. */

/* $ Detailed_Output */

/*     SCHEDL     the input schedule updated to include the intervals */
/*                of coverage for this segment. */

/* $ Parameters */

/*     None. */

/* $ Files */

/*     This routine reads the contents of the file associated with */
/*     HANDLE to locate coverage intervals. */

/* $ Exceptions */

/*     1) Routines in the call tree of this routine may signal errors */
/*        if insufficient room in SCHEDL exists or other error */
/*        conditions relating to file access arise. */

/*     2) If TOL is negative, the error SPICE(VALUEOUTOFRANGE) is */
/*        signaled. */

/*     3) If TIMSYS is not recognized, the error SPICE(INVALIDOPTION) */
/*        is signaled. */

/*     4) If a time conversion error occurs, the error will be */
/*        diagnosed by a routine in the call tree of this routine */

/* $ Particulars */

/*     This is a utility routine that determines the intervals */
/*     of coverage for a type 02 C-kernel segment. */

/* $ Examples */

/*     None. */

/* $ Restrictions */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman    (JPL) */
/*     W.L. Taber      (JPL) */
/*     F.S. Turner     (JPL) */
/*     B.V. Semenov    (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 03-JAN-2005 (NJB) (FST) (WLT) (BVS) */

/* -& */

/*     SPICELIB Functions */


/*     Local Parameters */


/*     Local Variables */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    } else {
	chkin_("ZZCKCV02", (ftnlen)8);
    }

/*     Check tolerance value. */

    if (*tol < 0.) {
	setmsg_("Tolerance must be non-negative; actual value was #.", (
		ftnlen)51);
	errdp_("#", tol, (ftnlen)1);
	sigerr_("SPICE(VALUEOUTOFRANGE)", (ftnlen)22);
	chkout_("ZZCKCV02", (ftnlen)8);
	return 0;
    }

/*     Set a logical flag indicating whether the time systm is SCLK. */

    istdb = eqstr_(timsys, "TDB", timsys_len, (ftnlen)3);

/*     Check time system. */

    if (! istdb) {
	if (! eqstr_(timsys, "SCLK", timsys_len, (ftnlen)4)) {
	    setmsg_("Time system spec TIMSYS was #; allowed values are SCLK "
		    "and TDB.", (ftnlen)63);
	    errch_("#", timsys, (ftnlen)1, timsys_len);
	    sigerr_("SPICE(INVALIDOPTION)", (ftnlen)20);
	    chkout_("ZZCKCV02", (ftnlen)8);
	    return 0;
	}
    }

/*     Determine the size of the array and the number of records */
/*     in it. */

    arrsiz = *arrend - *arrbeg + 1;
    d__1 = ((doublereal) arrsiz * 100. + 1.) / 1001.;
    nrec = i_dnnt(&d__1);

/*     The variable GOT tells us how many time endpoints we've */
/*     gotten so far. */

    got = 0;
    while(got < nrec) {
/* Computing MIN */
	i__1 = 100, i__2 = nrec - got;
	get = min(i__1,i__2);
	begat = *arrbeg + (nrec << 3) + got;
	endat = *arrbeg + (nrec << 3) + nrec + got;

/*        Retrieve the list next list of windows. */

	i__1 = begat + get - 1;
	dafgda_(handle, &begat, &i__1, first);
	i__1 = endat + get - 1;
	dafgda_(handle, &endat, &i__1, last);

/*        Insert the coverage intervals into the schedule. */

	i__1 = get;
	for (i__ = 1; i__ <= i__1; ++i__) {

/*           Adjust the interval using the tolerance. */

	    begin = first[(i__2 = i__ - 1) < 100 && 0 <= i__2 ? i__2 : s_rnge(
		    "first", i__2, "zzckcv02_", (ftnlen)295)];
	    finish = last[(i__2 = i__ - 1) < 100 && 0 <= i__2 ? i__2 : s_rnge(
		    "last", i__2, "zzckcv02_", (ftnlen)296)];
	    if (*tol > 0.) {
/* Computing MAX */
		d__1 = begin - *tol;
		begin = max(d__1,0.);
		finish += *tol;
	    }

/*           Convert the time to TDB if necessary. */

	    if (istdb) {
		sct2e_(sclkid, &begin, &et);
		begin = et;
		sct2e_(sclkid, &finish, &et);
		finish = et;
	    }
	    wninsd_(&begin, &finish, schedl);
	}
	got += get;
    }
    chkout_("ZZCKCV02", (ftnlen)8);
    return 0;
} /* zzckcv02_ */
示例#12
0
文件: wofz.c 项目: steveyangrh/pPCA
int wofz(doublereal *xi, 
	  doublereal *yi, 
	  doublereal *u, 
	  doublereal *v, 
	  logical *flag__)
{
    /* System generated locals */
    doublereal d__1, d__2;

    /* Builtin functions */
    double sqrt(doublereal);
    integer i_dnnt(doublereal *);
    double exp(doublereal), cos(doublereal), sin(doublereal), pow_di(
	    doublereal *, integer *);

    /* Local variables */
    static logical a, b;
    static doublereal c__, h__;
    static integer i__, j, n;
    static doublereal x, y, h2, u1, v1, u2, v2, w1;
    static integer nu;
    static doublereal rx, ry, sx, sy, tx, ty;
    static integer np1, kapn;
    static doublereal xabs, yabs, daux, qrho, xaux, xsum, ysum, xabsq, xquad, 
	    yquad, qlambda;


/*  GIVEN A COMPLEX NUMBER Z = (XI,YI), THIS SUBROUTINE COMPUTES */
/*  THE VALUE OF THE FADDEEVA-FUNCTION W(Z) = EXP(-Z**2)*ERFC(-I*Z), */
/*  WHERE ERFC IS THE COMPLEX COMPLEMENTARY ERROR-FUNCTION AND I */
/*  MEANS SQRT(-1). */
/*  THE ACCURACY OF THE ALGORITHM FOR Z IN THE 1ST AND 2ND QUADRANT */
/*  IS 14 SIGNIFICANT DIGITS; IN THE 3RD AND 4TH IT IS 13 SIGNIFICANT */
/*  DIGITS OUTSIDE A CIRCULAR REGION WITH RADIUS 0.126 AROUND A ZERO */
/*  OF THE FUNCTION. */
/*  ALL REAL VARIABLES IN THE PROGRAM ARE DOUBLE PRECISION. */


/*  THE CODE CONTAINS A FEW COMPILER-DEPENDENT PARAMETERS : */
/*     RMAXREAL = THE MAXIMUM VALUE OF RMAXREAL EQUALS THE ROOT OF */
/*                RMAX = THE LARGEST NUMBER WHICH CAN STILL BE */
/*                IMPLEMENTED ON THE COMPUTER IN DOUBLE PRECISION */
/*                FLOATING-POINT ARITHMETIC */
/*     RMAXEXP  = LN(RMAX) - LN(2) */
/*     RMAXGONI = THE LARGEST POSSIBLE ARGUMENT OF A DOUBLE PRECISION */
/*                GONIOMETRIC FUNCTION (DCOS, DSIN, ...) */
/*  THE REASON WHY THESE PARAMETERS ARE NEEDED AS THEY ARE DEFINED WILL */
/*  BE EXPLAINED IN THE CODE BY MEANS OF COMMENTS */


/*  PARAMETER LIST */
/*     XI     = REAL      PART OF Z */
/*     YI     = IMAGINARY PART OF Z */
/*     U      = REAL      PART OF W(Z) */
/*     V      = IMAGINARY PART OF W(Z) */
/*     FLAG   = AN ERROR FLAG INDICATING WHETHER OVERFLOW WILL */
/*              OCCUR OR NOT; TYPE LOGICAL; */
/*              THE VALUES OF THIS VARIABLE HAVE THE FOLLOWING */
/*              MEANING : */
/*              FLAG=.FALSE. : NO ERROR CONDITION */
/*              FLAG=.TRUE.  : OVERFLOW WILL OCCUR, THE ROUTINE */
/*                             BECOMES INACTIVE */
/*  XI, YI      ARE THE INPUT-PARAMETERS */
/*  U, V, FLAG  ARE THE OUTPUT-PARAMETERS */

/*  FURTHERMORE THE PARAMETER FACTOR EQUALS 2/SQRT(PI) */

/*  THE ROUTINE IS NOT UNDERFLOW-PROTECTED BUT ANY VARIABLE CAN BE */
/*  PUT TO 0 UPON UNDERFLOW; */

/*  REFERENCE - GPM POPPE, CMJ WIJERS; MORE EFFICIENT COMPUTATION OF */
/*  THE COMPLEX ERROR-FUNCTION, ACM TRANS. MATH. SOFTWARE. */







    *flag__ = FALSE_;

    xabs = abs(*xi);
    yabs = abs(*yi);
    x = xabs / 6.3f;
    y = yabs / 4.4f;


/*     THE FOLLOWING IF-STATEMENT PROTECTS */
/*     QRHO = (X**2 + Y**2) AGAINST OVERFLOW */

    if (xabs > 5e153 || yabs > 5e153) {
	goto L100;
    }

/* Computing 2nd power */
    d__1 = x;
/* Computing 2nd power */
    d__2 = y;
    qrho = d__1 * d__1 + d__2 * d__2;

/* Computing 2nd power */
    d__1 = xabs;
    xabsq = d__1 * d__1;
/* Computing 2nd power */
    d__1 = yabs;
    xquad = xabsq - d__1 * d__1;
    yquad = xabs * 2 * yabs;

    a = qrho < .085264;

    if (a) {

/*  IF (QRHO.LT.0.085264D0) THEN THE FADDEEVA-FUNCTION IS EVALUATED */
/*  USING A POWER-SERIES (ABRAMOWITZ/STEGUN, EQUATION (7.1.5), P.297) */
/*  N IS THE MINIMUM NUMBER OF TERMS NEEDED TO OBTAIN THE REQUIRED */
/*  ACCURACY */

	qrho = (1 - y * .85f) * sqrt(qrho);
	d__1 = qrho * 72 + 6;
	n = i_dnnt(&d__1);
	j = (n << 1) + 1;
	xsum = 1.f / j;
	ysum = 0.;
	for (i__ = n; i__ >= 1; --i__) {
	    j += -2;
	    xaux = (xsum * xquad - ysum * yquad) / i__;
	    ysum = (xsum * yquad + ysum * xquad) / i__;
	    xsum = xaux + 1.f / j;
/* L10: */
	}
	u1 = (xsum * yabs + ysum * xabs) * -1.12837916709551257388 + 1.f;
	v1 = (xsum * xabs - ysum * yabs) * 1.12837916709551257388;
	daux = exp(-xquad);
	u2 = daux * cos(yquad);
	v2 = -daux * sin(yquad);

	*u = u1 * u2 - v1 * v2;
	*v = u1 * v2 + v1 * u2;

    } else {

/*  IF (QRHO.GT.1.O) THEN W(Z) IS EVALUATED USING THE LAPLACE */
/*  CONTINUED FRACTION */
/*  NU IS THE MINIMUM NUMBER OF TERMS NEEDED TO OBTAIN THE REQUIRED */
/*  ACCURACY */

/*  IF ((QRHO.GT.0.085264D0).AND.(QRHO.LT.1.0)) THEN W(Z) IS EVALUATED */
/*  BY A TRUNCATED TAYLOR EXPANSION, WHERE THE LAPLACE CONTINUED FRACTION */
/*  IS USED TO CALCULATE THE DERIVATIVES OF W(Z) */
/*  KAPN IS THE MINIMUM NUMBER OF TERMS IN THE TAYLOR EXPANSION NEEDED */
/*  TO OBTAIN THE REQUIRED ACCURACY */
/*  NU IS THE MINIMUM NUMBER OF TERMS OF THE CONTINUED FRACTION NEEDED */
/*  TO CALCULATE THE DERIVATIVES WITH THE REQUIRED ACCURACY */


	if (qrho > 1.f) {
	    h__ = 0.;
	    kapn = 0;
	    qrho = sqrt(qrho);
	    nu = (integer) (1442 / (qrho * 26 + 77) + 3);
	} else {
	    qrho = (1 - y) * sqrt(1 - qrho);
	    h__ = qrho * 1.88f;
	    h2 = h__ * 2;
	    d__1 = qrho * 34 + 7;
	    kapn = i_dnnt(&d__1);
	    d__1 = qrho * 26 + 16;
	    nu = i_dnnt(&d__1);
	}

	b = h__ > 0.f;

	if (b) {
	    qlambda = pow_di(&h2, &kapn);
	}

	rx = 0.f;
	ry = 0.f;
	sx = 0.f;
	sy = 0.f;

	for (n = nu; n >= 0; --n) {
	    np1 = n + 1;
	    tx = yabs + h__ + np1 * rx;
	    ty = xabs - np1 * ry;
/* Computing 2nd power */
	    d__1 = tx;
/* Computing 2nd power */
	    d__2 = ty;
	    c__ = .5f / (d__1 * d__1 + d__2 * d__2);
	    rx = c__ * tx;
	    ry = c__ * ty;
	    if (b && n <= kapn) {
		tx = qlambda + sx;
		sx = rx * tx - ry * sy;
		sy = ry * tx + rx * sy;
		qlambda /= h2;
	    }
/* L11: */
	}

	if (h__ == 0.f) {
	    *u = rx * 1.12837916709551257388;
	    *v = ry * 1.12837916709551257388;
	} else {
	    *u = sx * 1.12837916709551257388;
	    *v = sy * 1.12837916709551257388;
	}

	if (yabs == 0.f) {
/* Computing 2nd power */
	    d__1 = xabs;
	    *u = exp(-(d__1 * d__1));
	}

    }



/*  EVALUATION OF W(Z) IN THE OTHER QUADRANTS */


    if (*yi < 0.f) {

	if (a) {
	    u2 *= 2;
	    v2 *= 2;
	} else {
	    xquad = -xquad;


/*         THE FOLLOWING IF-STATEMENT PROTECTS 2*EXP(-Z**2) */
/*         AGAINST OVERFLOW */

	    if (yquad > 3537118876014220. || xquad > 708.503061461606) {
		goto L100;
	    }

	    w1 = exp(xquad) * 2;
	    u2 = w1 * cos(yquad);
	    v2 = -w1 * sin(yquad);
	}

	*u = u2 - *u;
	*v = v2 - *v;
	if (*xi > 0.f) {
	    *v = -(*v);
	}
    } else {
	if (*xi < 0.f) {
	    *v = -(*v);
	}
    }

    return 0;

L100:
    *flag__ = TRUE_;
    return 0;

} /* wofz_ */
示例#13
0
/* $Procedure  ZZWIND2D ( Find winding number of polygon about point ) */
integer zzwind2d_(integer *n, doublereal *vertcs, doublereal *point)
{
    /* System generated locals */
    integer vertcs_dim2, ret_val, i__1, i__2;
    doublereal d__1;

    /* Builtin functions */
    integer s_rnge(char *, integer, char *, integer), i_dnnt(doublereal *);

    /* Local variables */
    doublereal rvec[2];
    integer i__, j;
    extern /* Subroutine */ int chkin_(char *, ftnlen), moved_(doublereal *, 
	    integer *, doublereal *);
    extern doublereal vdotg_(doublereal *, doublereal *, integer *), vsepg_(
	    doublereal *, doublereal *, integer *);
    extern /* Subroutine */ int vsubg_(doublereal *, doublereal *, integer *, 
	    doublereal *);
    doublereal rperp[2], rnext[2];
    extern doublereal twopi_(void);
    doublereal atotal;
    extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *, 
	    ftnlen);
    extern logical return_(void);
    doublereal sep;

/* $ Abstract */

/*     SPICE Private routine intended solely for the support of SPICE */
/*     routines.  Users should not call this routine directly due */
/*     to the volatile nature of this routine. */

/*     Find the winding number of a planar polygon about a specified */
/*     point in 2-dimensional space. */

/* $ 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 */

/*     PLANES */

/* $ Keywords */

/*     GEOMETRY */
/*     MATH */
/*     PLANE */

/* $ Declarations */
/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     N          I   Number of vertices of polygon. */
/*     VERTCS     I   Vertices of polygon. */
/*     POINT      I   Point in PLANE. */

/*     The function returns the winding number of the input polygon */
/*     about the input point. */

/* $ Detailed_Input */

/*     N, */
/*     VERTCS         are, respectively, the number vertices defining */
/*                    the polygon and the vertices themselves.  Each */
/*                    pair of consecutive vectors in the array VERTCS */
/*                    defines an edge of the polygon. */

/* $ Detailed_Output */

/*     The function returns the winding number of the input polygon */
/*     about the input point. The winding number measures the "net" */
/*     number of times the polygon wraps around POINT:  this is */
/*     the number of times the polygon wraps around POINT in the */
/*     counterclockwise sense minus the number of times the polygon */
/*     wraps around POINT in the clockwise sense. */

/*     The possible values and meanings of the winding number are: */

/*        ZZWIND2D > 0:  The polygon winds about POINT a total */
/*                       of ZZWIND2D times in the counterclockwise */
/*                       direction. */

/*                       POINT is inside the polygon. */


/*        ZZWIND2D < 0:  The polygon winds about POINT a total */
/*                       of ZZWIND2D times in the clockwise */
/*                       direction. */

/*                       POINT is inside the polygon. */


/*        ZZWIND2D = 0:  The number of times the polygon wraps around */
/*                       POINT in the counterclockwise sense is equal */
/*                       to the number of times the polygon wraps around */
/*                       POINT in the clockwise sense. */

/*                       POINT is outside the polygon. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     1)  If the number of boundary vectors N is not at least 3, */
/*         or if the number exceeds MAXFOV, the error */
/*         SPICE(INVALIDCOUNT) will be signaled. */

/*     2)  The input point and vertices are expected to lie in */
/*         the input plane.  To avoid problems introduced by */
/*         round-off errors, all of these vectors are projected */
/*         orthogonally onto the plane before the winding number */
/*         is computed.  If the input point or vertices are "far" */
/*         from the input plane, no error will be signaled. */

/*     3)  If the input plane as a zero normal vector, the error */
/*         SPICE(ZEROVECTOR) will be signaled. */

/* $ Files */

/*     None. */

/* $ Particulars */

/*     Find the winding number of a 2-D polygon about a specified */
/*     point. */

/*     This routine supports determination of whether an ellipsoidal */
/*     body is in the field of view of a remote-sensing instrument */
/*     with a field of view having polygonal cross section. */

/*     The winding number is actually defined for closed, piecewise */
/*     differentiable curves in the complex plane. If z(t), t in */
/*     [0, 2*Pi], is a parameterization of such a curve, then if the */
/*     symbol I is used to represent the integration operator, z0 is the */
/*     complex point of interest, and w is the winding number, we have */

/*                1 */
/*        w =  -------  *  I  ( d ( log(z-z0) ) ) */
/*             2*Pi*i     z(t) */


/*                1 */
/*          =  -------  *  I  ( ( 1 / (z-z0) ) dz ) */
/*             2*Pi*i     z(t) */


/*     Because of Cauchy's theorem, we can transform the problem, */
/*     without loss of generality (leaving out *many* steps here), to */
/*     one for which the curve has the simple form */

/*                        i n*(t-t0) */
/*        z(t) =  z0 + r e */

/*     for some real values r, n, and t0.  So */


/*             1 */
/*      w = -------  *  I  ( 1 / (z-z0) ) */
/*          2*Pi*i     z(t) */


/*             1      t=2*pi        i n*(t-t0)           i n*(t-t0) */
/*        = ------- *   I   ( (1/r e         ) * ( r i n e          )dt ) */
/*          2*Pi*i     t=0 */


/*             1     t=2*pi */
/*        = ------- *  I (   i n dt ) */
/*          2*Pi*i    t=0 */

/*             1 */
/*        = ------  *  ( 2 * Pi * i * n ) */
/*          2*Pi*i */


/*        =    n */


/*     Given the simplified form of z(t) we've chosen, it's now clear */
/*     that n is the winding number. */

/*     In the simple case of a polygonal curve, the integral can be */
/*     computed for a corresponding polygon whose vertices have been */
/*     scaled to have equal magnitude; the integral can be expressed as */
/*     the telescoping sum */

/*         N */
/*        ___ */
/*        \ */
/*        /    ( argument of vertex(i+1) - argument of vertex(i) ) */
/*        --- */
/*        i=1 */

/*     where vertex N+1 is considered have length identical to that of */
/*     vertex 1 and argument differing from that of vertex 1 by w*2*pi. */


/* $ Examples */

/*     None. */

/* $ Restrictions */

/*     None. */

/* $ Literature_References */

/*     [1] `Calculus and Analytic Geometry', Thomas and Finney. */

/* $ Author_and_Institution */

/*     N.J. Bachman   (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 08-JUL-2008 (NJB) */

/* -& */
/* $ Index_Entries */

/*     find winding number of polygon about point */

/* -& */

/*     SPICELIB functions */


/*     Local variables */


/*     Initialize the function return value. */

    /* Parameter adjustments */
    vertcs_dim2 = *n;

    /* Function Body */
    ret_val = 0;
    if (return_()) {
	return ret_val;
    }
    chkin_("ZZWIND2D", (ftnlen)8);

/*     Check the number of sides of the polygon. */

    if (*n < 3) {
	setmsg_("Polygon must have at least 3 sides; N = #.", (ftnlen)42);
	errint_("#", n, (ftnlen)1);
	sigerr_("SPICE(DEGENERATECASE)", (ftnlen)21);
	chkout_("ZZWIND2D", (ftnlen)8);
	return ret_val;
    }

/*     The total "wrap angle" starts at zero. */

    atotal = 0.;
    vsubg_(&vertcs[(i__1 = 0) < vertcs_dim2 << 1 ? i__1 : s_rnge("vertcs", 
	    i__1, "zzwind2d_", (ftnlen)285)], point, &c__2, rvec);
    i__1 = *n + 1;
    for (i__ = 2; i__ <= i__1; ++i__) {
	if (i__ <= *n) {
	    j = i__;
	} else {
	    j = 1;
	}

/*        Find the angular separation of RVEC and the next vector */
/*        RNEXT. */

	vsubg_(&vertcs[(i__2 = (j << 1) - 2) < vertcs_dim2 << 1 && 0 <= i__2 ?
		 i__2 : s_rnge("vertcs", i__2, "zzwind2d_", (ftnlen)299)], 
		point, &c__2, rnext);
	sep = vsepg_(rnext, rvec, &c__2);

/*        Create a normal vector to RVEC by rotating RVEC pi/2 radians */
/*        counterclockwise.  We'll use this vector RPERP to determine */
/*        whether the next point is reached by clockwise or */
/*        counterclockwise rotation from RVEC. */

	rperp[0] = -rvec[1];
	rperp[1] = rvec[0];
	if (vdotg_(rnext, rperp, &c__2) >= 0.) {

/*           RNEXT is reached by counterclockwise rotation from */
/*           RVEC.  Note that in the case of zero rotation, the */
/*           sign doesn't matter because the contribution is zero. */

	    atotal += sep;
	} else {
	    atotal -= sep;
	}

/*        Update RVEC. */

	moved_(rnext, &c__2, rvec);
    }

/*     The above sum is 2 * pi * <the number of times the polygon */
/*     wraps around P>.  Let ZZWIND2D be the wrap count. */

    d__1 = atotal / twopi_();
    ret_val = i_dnnt(&d__1);
    chkout_("ZZWIND2D", (ftnlen)8);
    return ret_val;
} /* zzwind2d_ */
示例#14
0
/* $Procedure      SPKE13 ( S/P Kernel, evaluate, type 13 ) */
/* Subroutine */ int spke13_(doublereal *et, doublereal *record, doublereal *
	state)
{
    /* System generated locals */
    integer i__1, i__2;

    /* Builtin functions */
    integer i_dnnt(doublereal *), s_rnge(char *, integer, char *, integer);

    /* Local variables */
    integer from;
    doublereal work[516]	/* was [258][2] */;
    integer i__, j, n;
    extern /* Subroutine */ int chkin_(char *, ftnlen);
    integer to;
    doublereal locrec[129];
    extern /* Subroutine */ int chkout_(char *, ftnlen), hrmint_(integer *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, doublereal *);
    extern logical return_(void);
    integer xstart;

/* $ Abstract */

/*     Evaluate a single data record from a type 13 SPK segment. */

/* $ 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 */

/*     SPK */

/* $ Keywords */

/*     EPHEMERIS */

/* $ Declarations */
/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     MAXREC     P   Maximum size of SPK record.  See SPKPVN. */
/*     ET         I   Epoch for which a state is desired. */
/*     RECORD     I   Record from a type 13 SPK segment valid for ET. */
/*     STATE      O   State (position and velocity) at epoch ET. */

/* $ Detailed_Input */

/*     ET             is the epoch for which a state vector is desired. */

/*     RECORD         is a record from a type 13 SPK segment which, when */
/*                    evaluated at epoch ET, will give the state */
/*                    (position and velocity) of some body, relative to */
/*                    some center, in some inertial reference frame. */

/*                    The structure of the record is as follows: */

/*                       +----------------------+ */
/*                       | number of states (n) | */
/*                       +----------------------+ */
/*                       | state 1 (6 elts.)    | */
/*                       +----------------------+ */
/*                       | state 2 (6 elts.)    | */
/*                       +----------------------+ */
/*                                   . */
/*                                   . */
/*                                   . */
/*                       +----------------------+ */
/*                       | state n (6 elts.)    | */
/*                       +----------------------+ */
/*                       | epochs 1--n          | */
/*                       +----------------------+ */

/* $ Detailed_Output */

/*     STATE    is the state vector at epoch ET. Its contents are, in */
/*              order, X, Y, Z, X', Y', and Z'. Units are km and km/sec. */

/* $ Parameters */

/*     MAXREC   is the maximum size of SPK record.  See the SPICELIB */
/*              routine SPKPVN for details. */

/* $ Exceptions */

/*     None.  This routine assumes that the input record is valid. */

/* $ Files */

/*     None. */

/* $ Particulars */

/*     The exact format and structure of type 13 (unequally spaced */
/*     discrete states, evaluated by Hermite interpolation) SPK segments */
/*     is described in the SPK Required Reading. */

/* $ Examples */

/*     The SPKEnn routines are almost always used in conjunction with */
/*     the corresponding SPKRnn routines, which read the records from */
/*     SPK files. */

/*     The data returned by the SPKRnn routine is in a raw form, taken */
/*     directly from the segment.  As such, it will be not be directly */
/*     useful to a user unless they have a complete understanding of the */
/*     structure of the data type.  Given that understanding, however, */
/*     the SPKRnn routines could be used to "dump" and check segment data */
/*     for a particular epoch before evaluating the record to obtain a */
/*     state vector, as in the example which follows. */


/*     C */
/*     C     Get a segment applicable to a specified body and epoch. */
/*     C */
/*           CALL SPKSFS ( BODY, ET, HANDLE, DESCR, IDENT, FOUND ) */

/*     C */
/*     C     Look at parts of the descriptor. */
/*     C */
/*           CALL DAFUS ( DESCR, 2, 6, DCD, ICD ) */

/*           CENTER = ICD( 2 ) */
/*           REF    = ICD( 3 ) */
/*           TYPE   = ICD( 4 ) */

/*           IF ( TYPE .EQ. 13 ) THEN */

/*              CALL SPKR13 ( HANDLE, DESCR, ET, RECORD ) */
/*                  . */
/*                  .  Look at the RECORD data. */
/*                  . */
/*              CALL SPKE13 ( ET, RECORD, STATE ) */
/*                  . */
/*                  .  Check out the evaluated state. */
/*                  . */
/*           END IF */

/* $ Restrictions */

/*     1)  This routine assumes that the input record is valid.  Any */
/*         checking of the input data is assumed to have been performed */
/*         when the source SPK file was created. */

/* $ Literature_References */

/*     NAIF Document 168.0, "S- and P- Kernel (SPK) Specification and */
/*     User's Guide" */

/* $ Author_and_Institution */

/*     N.J. Bachman   (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 25-FEB-2000 (NJB) */

/* -& */
/* $ Index_Entries */

/*     evaluate type_13 spk segment */

/* -& */

/*     SPICELIB functions */


/*     Local parameters */


/*     Local variables */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    }
    chkin_("SPKE13", (ftnlen)6);
    n = i_dnnt(record);

/*     We interpolate each state component in turn. */

    xstart = n * 6 + 2;
    for (i__ = 1; i__ <= 3; ++i__) {
	i__1 = n;
	for (j = 1; j <= i__1; ++j) {

/*           For the Jth input state vector, copy the Ith position and */
/*           velocity components into the local record buffer LOCREC. */

	    from = (j - 1) * 6 + 1 + i__;
	    to = (j << 1) - 1;
	    locrec[(i__2 = to - 1) < 129 && 0 <= i__2 ? i__2 : s_rnge("locrec"
		    , i__2, "spke13_", (ftnlen)234)] = record[from - 1];
	    locrec[(i__2 = to) < 129 && 0 <= i__2 ? i__2 : s_rnge("locrec", 
		    i__2, "spke13_", (ftnlen)235)] = record[from + 2];
	}

/*        Interpolate the Ith position and velocity components of the */
/*        state. */

	hrmint_(&n, &record[xstart - 1], locrec, et, work, &state[(i__1 = i__ 
		- 1) < 6 && 0 <= i__1 ? i__1 : s_rnge("state", i__1, "spke13_"
		, (ftnlen)243)], &state[(i__2 = i__ + 2) < 6 && 0 <= i__2 ? 
		i__2 : s_rnge("state", i__2, "spke13_", (ftnlen)243)]);
    }
    chkout_("SPKE13", (ftnlen)6);
    return 0;
} /* spke13_ */
示例#15
0
文件: spks21.c 项目: Dbelsa/coft
/* $Procedure      SPKS21 ( S/P Kernel, subset, type 21 ) */
/* Subroutine */ int spks21_(integer *handle, integer *baddr, integer *eaddr, 
	doublereal *begin, doublereal *end)
{
    /* System generated locals */
    integer i__1, i__2, i__3;
    doublereal d__1;

    /* Builtin functions */
    integer i_dnnt(doublereal *);

    /* Local variables */
    doublereal data[111];
    integer offe, nrec, ndir, last, i__;
    extern /* Subroutine */ int chkin_(char *, ftnlen);
    integer first;
    extern /* Subroutine */ int dafada_(doublereal *, integer *), dafgda_(
	    integer *, integer *, integer *, doublereal *);
    integer maxdim, offset, dlsize;
    extern /* Subroutine */ int chkout_(char *, ftnlen);
    extern logical return_(void);

/* $ Abstract */

/*     Extract a subset of the data in a SPK segment of type 21 */
/*     into a new segment. */

/* $ 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 */

/*     DAF */
/*     SPK */
/*     TIME */

/* $ Keywords */

/*     EPHEMERIS */

/* $ Declarations */
/* $ Abstract */

/*     Declare parameters specific to SPK type 21. */

/* $ 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 */

/*     SPK */

/* $ Keywords */

/*     SPK */

/* $ Restrictions */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman      (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 25-DEC-2013 (NJB) */

/* -& */

/*     MAXTRM      is the maximum number of terms allowed in each */
/*                 component of the difference table contained in a type */
/*                 21 SPK difference line. MAXTRM replaces the fixed */
/*                 table parameter value of 15 used in SPK type 1 */
/*                 segments. */

/*                 Type 21 segments have variable size. Let MAXDIM be */
/*                 the dimension of each component of the difference */
/*                 table within each difference line. Then the size */
/*                 DLSIZE of the difference line is */

/*                    ( 4 * MAXDIM ) + 11 */

/*                 MAXTRM is the largest allowed value of MAXDIM. */



/*     End of include file spk21.inc. */

/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     HANDLE     I   Handle of source segment. */
/*     BADDR      I   Beginning address of source segment. */
/*     EADDR      I   Ending address of source segment. */
/*     BEGIN      I   Beginning (initial epoch) of subset. */
/*     END        I   End (final epoch) of subset. */

/* $ Detailed_Input */

/*     HANDLE, */
/*     BADDR, */
/*     EADDR       are the file handle assigned to a SPK file, and the */
/*                 beginning and ending addresses of a segment within */
/*                 the file. Together they determine a complete set of */
/*                 ephemeris data, from which a subset is to be */
/*                 extracted. */

/*     BEGIN, */
/*     END         are the initial and final epochs (ephemeris time) */
/*                 of the subset to be extracted. */


/* $ Detailed_Output */

/*     None. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     1)  Any errors that occur while reading data from the source SPK */
/*         file will be diagnosed by routines in the call tree of this */
/*         routine. */

/*     2)  Any errors that occur while writing data to the output SPK */
/*         file will be diagnosed by routines in the call tree of this */
/*         routine. */

/* $ Files */

/*     See argument HANDLE. */

/* $ Particulars */

/*     The exact structure of a segment of data type 21 is detailed in */
/*     the SPK Required Reading file. */

/* $ Examples */

/*     None. */

/* $ Restrictions */

/*     None. */

/* $ Literature_References */

/*     NAIF Document 168.0, "S- and P- Kernel (SPK) Specification and */
/*     User's Guide" */

/* $ Author_and_Institution */

/*     N.J. Bachman    (JPL) */
/*     I.M. Underwood  (JPL) */
/*     E.D. Wright     (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 16-JAN-2014 (NJB) (FTK) (WLT) (IMU) */

/* -& */
/* $ Index_Entries */

/*     subset type_21 spk segment */

/* -& */

/*     SPICELIB functions */


/*     Local parameters */


/*     Local variables */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    }
    chkin_("SPKS01", (ftnlen)6);

/*     Get the number of records in the segment. From that, we can */
/*     compute */

/*        NDIR      The number of directory epochs. */

/*        OFFE      The offset of the first epoch. */


/*     the number of directory epochs. */

    i__1 = *eaddr - 1;
    dafgda_(handle, &i__1, eaddr, data);
    maxdim = i_dnnt(data);
    nrec = i_dnnt(&data[1]);
    ndir = nrec / 100;
    offe = *eaddr - ndir - nrec - 2;

/*     Well, the new segment has already been begun. We just have to */
/*     decide what to move, and move it (using DAFADA). */

/*     Let's agree right now that speed is not of the greatest */
/*     importance here. We can probably do this with two passes */
/*     through the record epochs, and one pass through the records. */

/*        1) Determine the first and last records to be included */
/*           in the subset. */

/*        2) Move the records. */

/*        3) Write the epochs. */

/*     We can leap through the epochs one last time to get the */
/*     directory epochs. */

/*     First pass: which records are to be moved? */

    first = 0;
    last = 0;
    i__1 = nrec;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i__2 = offe + i__;
	i__3 = offe + i__;
	dafgda_(handle, &i__2, &i__3, data);
	if (first == 0 && data[0] >= *begin) {
	    first = i__;
	}
	if (first != 0 && last == 0 && data[0] >= *end) {
	    last = i__;
	}
    }

/*     Second pass. Move the records. */

    dlsize = (maxdim << 2) + 11;
    offset = *baddr - 1 + (first - 1) * dlsize;
    i__1 = last;
    for (i__ = first; i__ <= i__1; ++i__) {
	i__2 = offset + 1;
	i__3 = offset + dlsize;
	dafgda_(handle, &i__2, &i__3, data);
	dafada_(data, &dlsize);
	offset += dlsize;
    }

/*     Third pass. Move the epochs. */

    i__1 = last;
    for (i__ = first; i__ <= i__1; ++i__) {
	i__2 = offe + i__;
	i__3 = offe + i__;
	dafgda_(handle, &i__2, &i__3, data);
	dafada_(data, &c__1);
    }

/*     Get every DIRSIZ'th epoch for the directory. */

    i__1 = last;
    for (i__ = first + 99; i__ <= i__1; i__ += 100) {
	i__2 = offe + i__;
	i__3 = offe + i__;
	dafgda_(handle, &i__2, &i__3, data);
	dafada_(data, &c__1);
    }

/*     Add the maximum difference line dimension and the */
/*     number of records, and we're done. */

    d__1 = (doublereal) maxdim;
    dafada_(&d__1, &c__1);
    data[0] = (doublereal) (last - first + 1);
    dafada_(data, &c__1);
    chkout_("SPKS01", (ftnlen)6);
    return 0;
} /* spks21_ */
示例#16
0
/* $Procedure      KPSOLV ( Solve Keplers Equation --- Vector Form ) */
doublereal kpsolv_(doublereal *evec)
{
    /* System generated locals */
    integer i__1, i__2, i__3, i__4;
    doublereal ret_val, d__1, d__2, d__3, d__4;

    /* Builtin functions */
    double sqrt(doublereal);
    integer i_dnnt(doublereal *);
    double cos(doublereal), sin(doublereal);

    /* Local variables */
    doublereal cosx, sinx, h__;
    integer i__;
    doublereal k, x;
    extern /* Subroutine */ int chkin_(char *, ftnlen), errdp_(char *, 
	    doublereal *, ftnlen);
    integer maxit;
    doublereal y0, xl, xm, xu, yx;
    extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen), setmsg_(char *, ftnlen);
    doublereal ecc, ecc2, yxm, ypx;

/* $ Abstract */

/*    This routine solves the equation X = < EVEC, U(X) > where */
/*    U(X) is the unit vector [ Cos(X), SIN(X) ] and  < , > denotes */
/*    the two-dimensional dot product. */

/* $ 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 */

/*     ROOTS */

/* $ Declarations */
/* $ Brief_I/O */

/*     VARIABLE  I/O  DESCRIPTION */
/*     --------  ---  -------------------------------------------------- */
/*     EVEC       I   A 2-vector whose magnitude is less than 1. */

/*     The function returns the solution to X = < EVEC, U(X) > */

/* $ Detailed_Input */

/*     EVEC       is any two dimensional vector whose magnitude is */
/*                less than 1. */

/* $ Detailed_Output */

/*     The function returns the value X such that the equation */

/*        X = EVEC(1)COS(X) + EVEC(2)SIN(X). */

/* $ Parameters */

/*     None. */

/* $ Files */

/*     None. */

/* $ Exceptions */

/*     1) If the magnitude of EVEC is greater than or equal to 1 */
/*        the error SPICE(EVECOUTOFRANGE) is signalled. */

/* $ Particulars */

/*     This routine uses bisection and Newton's method to find */
/*     the root of the equation */

/*        X = EVEC(1)COS(X) + EVEC(2)SIN(X). */

/*     This equation is just a "vector form" of Kepler's equation. */


/* $ Examples */

/*     Suppose you need to solve the equation */

/*         M = E - e SIN(E)                           [ 1 ] */

/*     for E. If we let X = E - M the equation is transformed to */

/*        0 = X - e SIN( X + M ) */

/*          = X - e SIN( M ) COS(X) - e COS(M) SIN ( X ) */

/*     Thus if we solve the equation */

/*        X = e SIN(M) COS(X) + e COS(M) SIN(X) */

/*     we can find the value of X we can compute E. */

/*     The code fragment below illustrates how this routine can */
/*     be used to solve equation [1]. */

/*         EVEC(1) = ECC * DSIN(M) */
/*         EVEC(2) = ECC * DCOS(M) */
/*         E       = M   + KPSOLV( EVEC ) */


/* $ Restrictions */

/*     None. */

/* $ Author_and_Institution */

/*     W.L. Taber      (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 1.1.0, 26-AUG-1997 (WLT) */

/*        KPSOLV is now given an initial value of zero so that */
/*        if an error condition is detected, KPSOLV will have */
/*        a return value. */

/* -    SPICELIB Version 1.0.0, 03-JAN-1997 (WLT) */

/* -& */
/* $ Index_Entries */

/*     Solve the vector form of the Kepler equation */

/* -& */

/*     MXNEWT is the number of iterations we will perform */
/*     in the Newtons method for finding the solution to */
/*     the vector form of Kepler's equation.  It has been */
/*     empirically determined that 5 iterations is always */
/*     sufficient on computers have 64 bit double precision */
/*     numbers. */


/*     We give the function an initial value, just in case */
/*     we exit without solving Kepler's equation. */

    ret_val = 0.;
    h__ = evec[0];
    k = evec[1];
    ecc2 = h__ * h__ + k * k;
    if (ecc2 >= 1.) {
	chkin_("KPSOLV", (ftnlen)6);
	setmsg_("The magnitude of the vector EVEC = ( #, # ) must be less th"
		"an 1.  However, the magnitude of this vector is #.", (ftnlen)
		109);
	errdp_("#", &h__, (ftnlen)1);
	errdp_("#", &k, (ftnlen)1);
	d__1 = sqrt(ecc2);
	errdp_("#", &d__1, (ftnlen)1);
	sigerr_("SPICE(EVECOUTOFRANGE)", (ftnlen)21);
	chkout_("KPSOLV", (ftnlen)6);
	return ret_val;
    }

/*     We first approximate the equation 0 = X - H * COS(X) - K * SIN(X) */
/*     using bisection.  If we let Y(X) = X - H * COS(X) - K * SIN(X) */

/*        Y( ECC) =  ECC - <EVEC,U(X)>  =   ECC - ECC*COS(ANGLE_X) > 0 */
/*        Y(-ECC) = -ECC - <EVEC,U(X)>  =  -ECC - ECC*COS(ANGLE_X) < 0 */

/*     where ANGLE_X is the angle between U(X) and EVEC. Thus -ECC */
/*     and ECC necessarily bracket the root of the equation Y(X) = 0. */

/*     Also note that Y'(X) = 1 - < EVEC, V(X) > where V(X) is the */
/*     unit vector given by U'(X).  Thus Y is an increasing function */
/*     over the interval from -ECC to ECC. */

/*     The mid point of ECC and -ECC is 0 and Y(0) = -H.  Thus */
/*     we can do the first bisection step without doing */
/*     much in the way of computations. */

    y0 = -h__;
    xm = 0.;
    ecc = sqrt(ecc2);
    if (y0 > 0.) {
	xu = 0.;
	xl = -ecc;
    } else if (y0 < 0.) {
	xu = ecc;
	xl = 0.;
    } else {
	ret_val = 0.;
	return ret_val;
    }

/*     Iterate until we are assured of being in a region where */
/*     Newton's method will converge quickly.  The formula */
/*     below was empirically determined to give good results. */

/* Computing MIN */
/* Computing MAX */
    d__1 = 1. / (1. - ecc);
    i__3 = 1, i__4 = i_dnnt(&d__1);
    i__1 = 32, i__2 = max(i__3,i__4);
    maxit = min(i__1,i__2);
    i__1 = maxit;
    for (i__ = 1; i__ <= i__1; ++i__) {

/*        Compute the next midpoint.  We bracket XM by XL and XU just in */
/*        case some kind of strange rounding occurs in the computation */
/*        of the midpoint. */

/* Computing MAX */
/* Computing MIN */
	d__3 = xu, d__4 = (xl + xu) * .5;
	d__1 = xl, d__2 = min(d__3,d__4);
	xm = max(d__1,d__2);

/*        Compute Y at the midpoint of XU and XL */

	yxm = xm - h__ * cos(xm) - k * sin(xm);

/*        Determine the new upper and lower bounds. */

	if (yxm > 0.) {
	    xu = xm;
	} else {
	    xl = xm;
	}
    }

/*     We've bisected into a region where we can now get rapid */
/*     convergence using Newton's method. */

    x = xm;
    for (i__ = 1; i__ <= 5; ++i__) {
	cosx = cos(x);
	sinx = sin(x);

/*        Compute Y and Y' at X.  Use these to get the next */
/*        iteration for X. */

/*        For those of you who might be wondering, "Why not put */
/*        in a check for YX .EQ. 0 and return early if we get */
/*        an exact solution?"  Here's why.  An empirical check */
/*        of those cases where you can actually escape from the */
/*        Do-loop  showed that the test YX .EQ. 0 is true */
/*        only about once in every 10000 case of random inputs */
/*        of EVEC.  Thus on average the check is a waste of */
/*        time and we don't bother with it. */

	yx = x - h__ * cosx - k * sinx;
	ypx = h__ * sinx + 1. - k * cosx;
	x -= yx / ypx;
    }
    ret_val = x;
    return ret_val;
} /* kpsolv_ */
示例#17
0
文件: sgmeta.c 项目: Dbelsa/coft
/* $Procedure      SGMETA ( Generic segments: Fetch meta data value ) */
/* Subroutine */ int sgmeta_(integer *handle, doublereal *descr, integer *
	mnemon, integer *value)
{
    /* Initialized data */

    static integer lstbeg = -1;
    static integer lsthan = 0;

    /* System generated locals */
    integer i__1, i__2, i__3;
    static doublereal equiv_0[2];

    /* Builtin functions */
    integer s_rnge(char *, integer, char *, integer), i_dnnt(doublereal *);

    /* Local variables */
    static integer meta[17];
    integer begm1, i__, begin;
    extern /* Subroutine */ int chkin_(char *, ftnlen);
#define dtemp (equiv_0)
    extern /* Subroutine */ int moved_(doublereal *, integer *, doublereal *);
    doublereal xmeta[17];
#define itemp ((integer *)equiv_0)
    extern /* Subroutine */ int dafgda_(integer *, integer *, integer *, 
	    doublereal *);
    integer niovr2, nd;
    extern logical failed_(void);
    integer ni;
    extern /* Subroutine */ int dafhsf_(integer *, integer *, integer *);
    integer begmta, endmta, ametas;
    static logical nieven;
    static integer ioffst;
    extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen);
    doublereal dmtasz;
    static integer metasz;
    extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *, 
	    integer *, ftnlen);
    extern logical return_(void);
    integer end;

/* $ Abstract */

/*     Obtain the value of a specified generic segment meta data item. */

/* $ 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 */

/*      DAF Required Reading */

/* $ Keywords */

/*       GENERIC SEGMENTS */

/* $ Declarations */
/* $ Brief_I/O */

/*      VARIABLE  I/O  DESCRIPTION */
/*      --------  ---  -------------------------------------------------- */
/*      HANDLE     I   Handle of a DAF open for reading. */
/*      DESCR      I   Descriptor for a generic segment in the DAF. */
/*      MNEMON     I   An integer mnemonic for the desired meta data. */
/*      VALUE      O   The value of the meta data item requested. */

/* $ Detailed_Input */

/*     HANDLE     is the handle of a DAF opened for reading that */
/*                contains the generic segment described by DESCR. */

/*     DESCR      is the descriptor of a generic segment. This must */
/*                be the descriptor for a generic segment in the DAF */
/*                associated with HANDLE. */

/*     MNEMON     is the mnemonic used to represent the desired piece of */
/*                meta data. See the file 'sgparam.inc' for details, the */
/*                mnemonics, and their values. */

/* $ Detailed_Output */

/*     VALUE      is the value of the meta data item associated with */
/*                the mnemonic MNEMON that is in the generic segment */
/*                specified by HANDLE and DESCR. */

/* $ Parameters */

/*     This subroutine makes use of parameters defined in the file */
/*     'sgparam.inc'. */

/* $ Files */

/*      See the description of HANDLE above. */

/* $ Exceptions */

/*     1) If the mnemonic for the meta data item is not valid, the error */
/*        SPICE(UNKNOWNMETAITEM) will be signalled. */

/*     2) If the last address in the DAF segment that reports the number */
/*        of meta data items that exist in the segment is less than */
/*        MNMETA, the error SPICE(INVALIDMETADATA) will be signaled. */

/* $ Particulars */

/*     This routine is a utility for fetching the meta data associated */
/*     with a DAF generic segment. */

/*     A DAF generic segment contains several logical data partitions: */

/*        1) A partition for constant values to be associated with each */
/*           data packet in the segment. */

/*        2) A partition for the data packets. */

/*        3) A partition for reference values. */

/*        4) A partition for a packet directory, if the segment contains */
/*           variable sized packets. */

/*        5) A partition for a reference value directory. */

/*        6) A reserved partition that is not currently used. This */
/*           partition is only for the use of the NAIF group at the Jet */
/*           Propulsion Laboratory (JPL). */

/*        7) A partition for the meta data which describes the locations */
/*           and sizes of other partitions as well as providing some */
/*           additional descriptive information about the generic */
/*           segment. */

/*                 +============================+ */
/*                 |         Constants          | */
/*                 +============================+ */
/*                 |          Packet 1          | */
/*                 |----------------------------| */
/*                 |          Packet 2          | */
/*                 |----------------------------| */
/*                 |              .             | */
/*                 |              .             | */
/*                 |              .             | */
/*                 |----------------------------| */
/*                 |          Packet N          | */
/*                 +============================+ */
/*                 |      Reference Values      | */
/*                 +============================+ */
/*                 |      Packet Directory      | */
/*                 +============================+ */
/*                 |    Reference  Directory    | */
/*                 +============================+ */
/*                 |       Reserved  Area       | */
/*                 +============================+ */
/*                 |     Segment Meta Data      | */
/*                 +----------------------------+ */

/*     Only the placement of the meta data at the end of a segment is */
/*     required. The other data partitions may occur in any order in the */
/*     segment because the meta data will contain pointers to the */
/*     appropriate locations of the other data partitions within the */
/*     segment. */

/*     The meta data for the segment should be obtained only through */
/*     use of this routine, SGMETA. */

/* $ Examples */

/*     Suppose that we would like to know how many constants, data */
/*     packets, and reference values are in the generic segment that we */
/*     have located in the DAF file associated with HANDLE. */

/*     C */
/*     C     Get the number of constants. */
/*     C */
/*           CALL SGMETA ( HANDLE, DESCR, NCON, NCONST ) */
/*     C */
/*     C     Get the number of data packets. */
/*     C */
/*           CALL SGMETA ( HANDLE, DESCR, NPKT, NPKTS ) */
/*     C */
/*     C     Get the number of constants. */
/*     C */
/*           CALL SGMETA ( HANDLE, DESCR, NREF, NREFS ) */

/*     C */
/*     C     Print the values. */
/*     C */
/*           WRITE (*, *) 'Number of Constants       : ', NCONST */
/*           WRITE (*, *) 'Number of Data Packets    : ', NPKTS */
/*           WRITE (*, *) 'Number of Reference Values: ', NREFS */

/* $ Restrictions */

/*     The segment described by DESCR MUST be a generic segment, */
/*     otherwise the results of this routine are not predictable. */

/* $ Author_and_Institution */

/*      K.R. Gehringer  (JPL) */
/*      W.L. Taber      (JPL) */
/*      F.S. Turner     (JPL) */

/* $ Literature_References */

/*      None. */

/* $ Version */

/* -    SPICELIB Version 1.4.0, 07-SEP-2001 (EDW) */

/*        Replaced DAFRDA call with DAFGDA. */

/* -    SPICELIB Version 1.3.0, 14-JUN-1999 (FST) */

/*        Altered the check in/out structure to be more reasonable. */
/*        This introduced redundant code, but only to increase the */
/*        efficiency of the normal mode of operation. */

/* -    SPICELIB Version 1.2.0, 24-SEP-1998 (FST) */

/*        Modified the code that handles reading the meta data from the */
/*        DAF to handle the case when the number of meta data items in */
/*        the file exceeds the current maximum defined in sgparam.inc. */
/*        In the event that this situation occurs, the routine loads */
/*        what meta data it can interpret and ignores the rest.  In */
/*        this event if NMETA is requested, it is returned as MXMETA in */
/*        sgparam.inc. */

/*        An additional exception is now trapped by the routine. If */
/*        a generic segment in a DAF reports less than the known minimum */
/*        number of meta data items, then the routine signals the */
/*        error SPICE(INVALIDMETADATA). */

/*        The conditions that cause the SPICE(UNKNOWNMETAITEM) to be */
/*        signaled have been altered. Now if the integer mnemonic */
/*        is not between 1 and METASZ inclusive, or NMETA the error */
/*        is signaled.  In the versions preceding this change, for */
/*        segments that reported less than NMETA items of meta data */
/*        could not use this routine to request the number of meta */
/*        data items without signalling SPICE(UNKNOWNMETAITEM). */

/* -    SPICELIB Version 1.1.0, 11-APR-1995 (KRG) */

/*        Modified the code that deals with the EQUIVALENCEd part */
/*        descriptor. We now call MOVED rather than using a direct */
/*        assignment. */

/* -    SPICELIB Version 1.0.0, 11-APR-1995 (KRG) (WLT) */

/* -& */
/* $ Index_Entries */

/*     retrieve a meta data value for a generic segment */

/* -& */

/*     Spicelib Functions */


/*     Local Parameters */

/*     Include the mnemonic values for the generic segment declarations. */


/*     Local Variables */


/* $ Abstract */

/*     Parameter declarations for the generic segments subroutines. */

/* $ 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 */

/*      DAF Required Reading */

/* $ Keywords */

/*       GENERIC SEGMENTS */

/* $ Particulars */

/*     This include file contains the parameters used by the generic */
/*     segments subroutines, SGxxxx. A generic segment is a */
/*     generalization of a DAF array which places a particular structure */
/*     on the data contained in the array, as described below. */

/*     This file defines the mnemonics that are used for the index types */
/*     allowed in generic segments as well as mnemonics for the meta data */
/*     items which are used to describe a generic segment. */

/*     A DAF generic segment contains several logical data partitions: */

/*        1) A partition for constant values to be associated with each */
/*           data packet in the segment. */

/*        2) A partition for the data packets. */

/*        3) A partition for reference values. */

/*        4) A partition for a packet directory, if the segment contains */
/*           variable sized packets. */

/*        5) A partition for a reference value directory. */

/*        6) A reserved partition that is not currently used. This */
/*           partition is only for the use of the NAIF group at the Jet */
/*           Propulsion Laboratory (JPL). */

/*        7) A partition for the meta data which describes the locations */
/*           and sizes of other partitions as well as providing some */
/*           additional descriptive information about the generic */
/*           segment. */

/*                 +============================+ */
/*                 |         Constants          | */
/*                 +============================+ */
/*                 |          Packet 1          | */
/*                 |----------------------------| */
/*                 |          Packet 2          | */
/*                 |----------------------------| */
/*                 |              .             | */
/*                 |              .             | */
/*                 |              .             | */
/*                 |----------------------------| */
/*                 |          Packet N          | */
/*                 +============================+ */
/*                 |      Reference Values      | */
/*                 +============================+ */
/*                 |      Packet Directory      | */
/*                 +============================+ */
/*                 |    Reference  Directory    | */
/*                 +============================+ */
/*                 |       Reserved  Area       | */
/*                 +============================+ */
/*                 |     Segment Meta Data      | */
/*                 +----------------------------+ */

/*     Only the placement of the meta data at the end of a generic */
/*     segment is required. The other data partitions may occur in any */
/*     order in the generic segment because the meta data will contain */
/*     pointers to their appropriate locations within the generic */
/*     segment. */

/*     The meta data for a generic segment should only be obtained */
/*     through use of the subroutine SGMETA. The meta data should not be */
/*     written through any mechanism other than the ending of a generic */
/*     segment begun by SGBWFS or SGBWVS using SGWES. */

/* $ Restrictions */

/*     1) If new reference index types are added, the new type(s) should */
/*        be defined to be the consecutive integer(s) after the last */
/*        defined reference index type used. In this way a value for */
/*        the maximum allowed index type may be maintained. This value */
/*        must also be updated if new reference index types are added. */

/*     2) If new meta data items are needed, mnemonics for them must be */
/*        added to the end of the current list of mnemonics and before */
/*        the NMETA mnemonic. In this way compatibility with files having */
/*        a different, but smaller, number of meta data items may be */
/*        maintained. See the description and example below. */

/* $ Author_and_Institution */

/*     N.J. Bachman      (JPL) */
/*     K.R. Gehringer    (JPL) */
/*     W.L. Taber        (JPL) */
/*     F.S. Turner       (JPL) */

/* $ Literature_References */

/*     Generic Segments Required Reading. */
/*     DAF Required Reading. */

/* $ Version */

/* -    SPICELIB Version 1.1.1, 28-JAN-2004 (NJB) */

/*        Header update: equations for comptutations of packet indices */
/*        for the cases of index types 0 and 1 were corrected. */

/* -    SPICELIB Version 1.1.0, 25-09-98 (FST) */

/*        Added parameter MNMETA, the minimum number of meta data items */
/*        that must be present in a generic DAF segment. */

/* -    SPICELIB Version 1.0.0, 04-03-95 (KRG) (WLT) */

/* -& */

/*     Mnemonics for the type of reference value index. */

/*     Two forms of indexing are provided: */

/*        1) An implicit form of indexing based on using two values, a */
/*           starting value, which will have an index of 1, and a step */
/*           size between reference values, which are used to compute an */
/*           index and a reference value associated with a specified key */
/*           value. See the descriptions of the implicit types below for */
/*           the particular formula used in each case. */

/*        2) An explicit form of indexing based on a reference value for */
/*           each data packet. */


/*     Reference Index Type 0 */
/*     ---------------------- */

/*     Implied index. The index and reference value of a data packet */
/*     associated with a specified key value are computed from the two */
/*     generic segment reference values using the formula below. The two */
/*     generic segment reference values, REF(1) and REF(2), represent, */
/*     respectively, a starting value and a step size between reference */
/*     values. The index of the data packet associated with a key value */
/*     of VALUE is given by: */

/*                          /    VALUE - REF(1)    \ */
/*        INDEX = 1  +  INT | -------------------- | */
/*                          \        REF(2)        / */

/*     and the reference value associated with VALUE is given by: */

/*        REFVAL = REF(1) + DBLE (INDEX-1) * REF(2) */


/*     Reference Index Type 1 */
/*     ---------------------- */

/*     Implied index. The index and reference value of a data packet */
/*     associated with a specified key value are computed from the two */
/*     generic segment reference values using the formula below. The two */
/*     generic segment reference values, REF(1) and REF(2), represent, */
/*     respectively, a starting value and a step size between reference */
/*     values. The index of the data packet associated with a key value */
/*     of VALUE is given by: */

/*                          /          VALUE - REF(1)    \ */
/*        INDEX = 1  +  INT | 0.5 + -------------------- | */
/*                          \              REF(2)        / */


/*     and the reference value associated with VALUE is given by: */

/*        REFVAL = REF(1) + DBLE (INDEX-1) * REF(2) */

/*     We get the larger index in the event that VALUE is halfway between */
/*     X(I) and X(I+1), where X(I) = BUFFER(1) + DBLE (I-1) * REFDAT(2). */


/*     Reference Index Type 2 */
/*     ---------------------- */

/*     Explicit index. In this case the number of packets must equal the */
/*     number of reference values. The index of the packet associated */
/*     with a key value of VALUE is the index of the last reference item */
/*     that is strictly less than VALUE. The reference values must be in */
/*     ascending order, REF(I) < REF(I+1). */


/*     Reference Index Type 3 */
/*     ---------------------- */

/*     Explicit index. In this case the number of packets must equal the */
/*     number of reference values. The index of the packet associated */
/*     with a key value of VALUE is the index of the last reference item */
/*     that is less than or equal to VALUE. The reference values must be */
/*     in ascending order, REF(I) < REF(I+1). */


/*     Reference Index Type 4 */
/*     ---------------------- */

/*     Explicit index. In this case the number of packets must equal the */
/*     number of reference values. The index of the packet associated */
/*     with a key value of VALUE is the index of the reference item */
/*     that is closest to the value of VALUE. In the event of a "tie" */
/*     the larger index is selected. The reference values must be in */
/*     ascending order, REF(I) < REF(I+1). */


/*     These parameters define the valid range for the index types. An */
/*     index type code, MYTYPE, for a generic segment must satisfy the */
/*     relation MNIDXT <= MYTYPE <= MXIDXT. */


/*     The following meta data items will appear in all generic segments. */
/*     Other meta data items may be added if a need arises. */

/*       1)  CONBAS  Base Address of the constants in a generic segment. */

/*       2)  NCON    Number of constants in a generic segment. */

/*       3)  RDRBAS  Base Address of the reference directory for a */
/*                   generic segment. */

/*       4)  NRDR    Number of items in the reference directory of a */
/*                   generic segment. */

/*       5)  RDRTYP  Type of the reference directory 0, 1, 2 ... for a */
/*                   generic segment. */

/*       6)  REFBAS  Base Address of the reference items for a generic */
/*                   segment. */

/*       7)  NREF    Number of reference items in a generic segment. */

/*       8)  PDRBAS  Base Address of the Packet Directory for a generic */
/*                   segment. */

/*       9)  NPDR    Number of items in the Packet Directory of a generic */
/*                   segment. */

/*      10)  PDRTYP  Type of the packet directory 0, 1, ... for a generic */
/*                   segment. */

/*      11)  PKTBAS  Base Address of the Packets for a generic segment. */

/*      12)  NPKT    Number of Packets in a generic segment. */

/*      13)  RSVBAS  Base Address of the Reserved Area in a generic */
/*                   segment. */

/*      14)  NRSV    Number of items in the reserved area of a generic */
/*                   segment. */

/*      15)  PKTSZ   Size of the packets for a segment with fixed width */
/*                   data packets or the size of the largest packet for a */
/*                   segment with variable width data packets. */

/*      16)  PKTOFF  Offset of the packet data from the start of a packet */
/*                   record. Each data packet is placed into a packet */
/*                   record which may have some bookkeeping information */
/*                   prepended to the data for use by the generic */
/*                   segments software. */

/*      17)  NMETA   Number of meta data items in a generic segment. */

/*     Meta Data Item  1 */
/*     ----------------- */


/*     Meta Data Item  2 */
/*     ----------------- */


/*     Meta Data Item  3 */
/*     ----------------- */


/*     Meta Data Item  4 */
/*     ----------------- */


/*     Meta Data Item  5 */
/*     ----------------- */


/*     Meta Data Item  6 */
/*     ----------------- */


/*     Meta Data Item  7 */
/*     ----------------- */


/*     Meta Data Item  8 */
/*     ----------------- */


/*     Meta Data Item  9 */
/*     ----------------- */


/*     Meta Data Item 10 */
/*     ----------------- */


/*     Meta Data Item 11 */
/*     ----------------- */


/*     Meta Data Item 12 */
/*     ----------------- */


/*     Meta Data Item 13 */
/*     ----------------- */


/*     Meta Data Item 14 */
/*     ----------------- */


/*     Meta Data Item 15 */
/*     ----------------- */


/*     Meta Data Item 16 */
/*     ----------------- */


/*     If new meta data items are to be added to this list, they should */
/*     be added above this comment block as described below. */

/*        INTEGER               NEW1 */
/*        PARAMETER           ( NEW1   = PKTOFF + 1 ) */

/*        INTEGER               NEW2 */
/*        PARAMETER           ( NEW2   = NEW1   + 1 ) */

/*        INTEGER               NEWEST */
/*        PARAMETER           ( NEWEST = NEW2   + 1 ) */

/*     and then the value of NMETA must be changed as well to be: */

/*        INTEGER               NMETA */
/*        PARAMETER           ( NMETA  = NEWEST + 1 ) */

/*     Meta Data Item 17 */
/*     ----------------- */


/*     Maximum number of meta data items. This is always set equal to */
/*     NMETA. */


/*     Minimum number of meta data items that must be present in a DAF */
/*     generic segment.  This number is to remain fixed even if more */
/*     meta data items are added for compatibility with old DAF files. */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    }

/*     Handle the case when we are looking at the same file and segment */
/*     descriptor first.  This will result in duplicated code, but will */
/*     increase efficiency for the usual execution case. We need not */
/*     worry about the first time through, since LSTHAN and LSTBEG are */
/*     set to values that are bogus for actual DAF files. */

    if (*handle == lsthan) {

/*        Get the begin and end values from the descriptor. They are */
/*        located in the last two "integer" positions of the descriptor. */

	if (nieven) {
	    moved_(&descr[ioffst - 1], &c__1, dtemp);
	    begin = itemp[0];
	    end = itemp[1];
	} else {
	    moved_(&descr[ioffst - 1], &c__2, dtemp);
	    begin = itemp[1];
	    end = itemp[2];
	}

/*        Check the segment start address. This will tell us whether we */
/*        are looking at the same segment. */

	if (lstbeg == begin) {

/*        The only acceptable integer mnemonics at this point are 1 */
/*        through METASZ inclusive, and NMETA.  All other requests */
/*        should signal the SPICE(UNKNOWNMETAITEM) error, since the */
/*        current segment has no knowledge of these values. */

	    if (*mnemon <= 0 || *mnemon > metasz && *mnemon != 17) {
		chkin_("SGMETA", (ftnlen)6);
		*value = -1;
		setmsg_("The item requested, #, is not one of the recognized"
			" meta data items associated with this generic segmen"
			"t.", (ftnlen)105);
		errint_("#", mnemon, (ftnlen)1);
		sigerr_("SPICE(UNKNOWNMETAITEM)", (ftnlen)22);
		chkout_("SGMETA", (ftnlen)6);
		return 0;
	    }

/*           Set the value for the desired meta data item and return. */

	    *value = meta[(i__1 = *mnemon - 1) < 17 && 0 <= i__1 ? i__1 : 
		    s_rnge("meta", i__1, "sgmeta_", (ftnlen)364)];
	    return 0;
	}
    }

/*     At this point we are going to have to load the meta data.  If */
/*     the new handle and the old handle are the same, then the above */
/*     code has already retrieved the relevant segment addresses. If not */
/*     we need to fetch them.  First check in. */

    chkin_("SGMETA", (ftnlen)6);
    if (*handle != lsthan) {
	dafhsf_(handle, &nd, &ni);
	if (failed_()) {
	    chkout_("SGMETA", (ftnlen)6);
	    return 0;
	}
	niovr2 = ni / 2;
	nieven = niovr2 << 1 == ni;
	ioffst = nd + niovr2;
	lsthan = *handle;

/*        Get the begin and end values from the descriptor. They are */
/*        located in the last two "integer" positions of the descriptor. */

	if (nieven) {
	    moved_(&descr[ioffst - 1], &c__1, dtemp);
	    begin = itemp[0];
	    end = itemp[1];
	} else {
	    moved_(&descr[ioffst - 1], &c__2, dtemp);
	    begin = itemp[1];
	    end = itemp[2];
	}
    }

/*     Save the new begin address. Remember we have either just computed */
/*     this from the IF block above, or we computed it in the very */
/*     first IF block. */

    lstbeg = begin;

/*     Compute the begin address of the meta data and compute the */
/*     end address of the number we will be collecting. */

    dafgda_(handle, &end, &end, &dmtasz);
    if (failed_()) {
	chkout_("SGMETA", (ftnlen)6);
	return 0;
    }
    metasz = i_dnnt(&dmtasz);

/*     Store the actual meta size in AMETAS, in case METASZ ends up */
/*     being modified to conform to our current understanding of */
/*     meta data items. */

    ametas = metasz;

/*     Check to see if METASZ is an unacceptable value. */

    if (metasz < 15) {
	*value = -1;
	setmsg_("This segment reports that it has # meta data items. Every g"
		"eneric segment must have at least #.", (ftnlen)95);
	errint_("#", &metasz, (ftnlen)1);
	errint_("#", &c__15, (ftnlen)1);
	sigerr_("SPICE(INVALIDMETADATA)", (ftnlen)22);
	chkout_("SGMETA", (ftnlen)6);
	return 0;

/*     If it is not, we may need to fix a few things to work around some */
/*     older files that have been delivered. We perform these kludges */
/*     here. Originally, the number of meta data items was not */
/*     considered to be part of the meta data. It now is, so if we */
/*     encounter an older version of the file, we need to increment the */
/*     meta data size by 1. The number of meta data items is always */
/*     after all of the meta data items, so we can do this. */

    } else if (metasz == 15) {
	++metasz;
	ametas = metasz;

/*     If not check to see if METASZ is greater than the known MXMETA. */
/*     If it is then this segment most likely was constructed from */
/*     some newer version of the toolkit.  Load what meta data we */
/*     currently know about as laid out in sgparam.inc. */

    } else if (metasz > 17) {

/*        Leave AMETAS alone, since we need to know how far back */
/*        into the DAF file to begin reading. */

	metasz = 17;
    }

/*     The address computations that follow are precisely the same */
/*     as the previous version of the file, except when AMETAS is not */
/*     METASZ.  This only happens when METASZ is greater than MXMETA. */

    begmta = end - ametas + 1;
    endmta = begmta + metasz - 1;
    dafgda_(handle, &begmta, &endmta, xmeta);
    if (failed_()) {
	chkout_("SGMETA", (ftnlen)6);
	return 0;
    }

/*     Convert all of the meta data values into integers. */

    i__1 = metasz;
    for (i__ = 1; i__ <= i__1; ++i__) {
	meta[(i__2 = i__ - 1) < 17 && 0 <= i__2 ? i__2 : s_rnge("meta", i__2, 
		"sgmeta_", (ftnlen)503)] = i_dnnt(&xmeta[(i__3 = i__ - 1) < 
		17 && 0 <= i__3 ? i__3 : s_rnge("xmeta", i__3, "sgmeta_", (
		ftnlen)503)]);
    }

/*     The kludge continues... NMETA and MXMETA are ALWAYS the same */
/*     value, and any missing values must appear between the last known */
/*     value, META(METASZ-1), and the end value, META(NMETA), so we zero */
/*     them out. */

    meta[16] = metasz;
    for (i__ = metasz; i__ <= 16; ++i__) {
	meta[(i__1 = i__ - 1) < 17 && 0 <= i__1 ? i__1 : s_rnge("meta", i__1, 
		"sgmeta_", (ftnlen)515)] = 0;
    }

/*     Adjust the bases so that the N'th item of a partition is at */
/*     address META(PARTITION_BASE) + N */

    begm1 = begin - 1;
    meta[0] += begm1;
    meta[5] += begm1;
    meta[2] += begm1;
    meta[7] += begm1;
    meta[10] += begm1;
    meta[12] += begm1;

/*     The only acceptable integer mnemonics at this point are 1 through */
/*     METASZ inclusive, and NMETA.  All other requests should signal */
/*     the SPICE(UNKNOWNMETAITEM) error, since the current segment has */
/*     no knowledge of these values. */

    if (*mnemon <= 0 || *mnemon > metasz && *mnemon != 17) {
	*value = -1;
	setmsg_("The item requested, #, is not one of the recognized meta da"
		"ta items associated with this generic segment.", (ftnlen)105);
	errint_("#", mnemon, (ftnlen)1);
	sigerr_("SPICE(UNKNOWNMETAITEM)", (ftnlen)22);
	chkout_("SGMETA", (ftnlen)6);
	return 0;
    }

/*     Set the value for the desired meta data item, check out if we */
/*     need to, and return. */

    *value = meta[(i__1 = *mnemon - 1) < 17 && 0 <= i__1 ? i__1 : s_rnge(
	    "meta", i__1, "sgmeta_", (ftnlen)555)];
    chkout_("SGMETA", (ftnlen)6);
    return 0;
} /* sgmeta_ */
示例#18
0
文件: slacon.c 项目: 317070/scipy
int
slacon_(int *n, float *v, float *x, int *isgn, float *est, int *kase)

{


    /* Table of constant values */
    int c__1 = 1;
    float      zero = 0.0;
    float      one = 1.0;
    
    /* Local variables */
    static int iter;
    static int jump, jlast;
    static float altsgn, estold;
    static int i, j;
    float temp;
#ifdef _CRAY
    extern int ISAMAX(int *, float *, int *);
    extern float SASUM(int *, float *, int *);
    extern int SCOPY(int *, float *, int *, float *, int *);
#else
    extern int isamax_(int *, float *, int *);
    extern float sasum_(int *, float *, int *);
    extern int scopy_(int *, float *, int *, float *, int *);
#endif
#define d_sign(a, b) (b >= 0 ? fabs(a) : -fabs(a))    /* Copy sign */
#define i_dnnt(a) \
	( a>=0 ? floor(a+.5) : -floor(.5-a) ) /* Round to nearest integer */

    if ( *kase == 0 ) {
	for (i = 0; i < *n; ++i) {
	    x[i] = 1. / (float) (*n);
	}
	*kase = 1;
	jump = 1;
	return 0;
    }

    switch (jump) {
	case 1:  goto L20;
	case 2:  goto L40;
	case 3:  goto L70;
	case 4:  goto L110;
	case 5:  goto L140;
    }

    /*     ................ ENTRY   (JUMP = 1)   
	   FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY A*X. */
  L20:
    if (*n == 1) {
	v[0] = x[0];
	*est = fabs(v[0]);
	/*        ... QUIT */
	goto L150;
    }
#ifdef _CRAY
    *est = SASUM(n, x, &c__1);
#else
    *est = sasum_(n, x, &c__1);
#endif

    for (i = 0; i < *n; ++i) {
	x[i] = d_sign(one, x[i]);
	isgn[i] = i_dnnt(x[i]);
    }
    *kase = 2;
    jump = 2;
    return 0;

    /*     ................ ENTRY   (JUMP = 2)   
	   FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
L40:
#ifdef _CRAY
    j = ISAMAX(n, &x[0], &c__1);
#else
    j = isamax_(n, &x[0], &c__1);
#endif
    --j;
    iter = 2;

    /*     MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
L50:
    for (i = 0; i < *n; ++i) x[i] = zero;
    x[j] = one;
    *kase = 1;
    jump = 3;
    return 0;

    /*     ................ ENTRY   (JUMP = 3)   
	   X HAS BEEN OVERWRITTEN BY A*X. */
L70:
#ifdef _CRAY
    SCOPY(n, x, &c__1, v, &c__1);
#else
    scopy_(n, x, &c__1, v, &c__1);
#endif
    estold = *est;
#ifdef _CRAY
    *est = SASUM(n, v, &c__1);
#else
    *est = sasum_(n, v, &c__1);
#endif

    for (i = 0; i < *n; ++i)
	if (i_dnnt(d_sign(one, x[i])) != isgn[i])
	    goto L90;

    /*     REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
    goto L120;

L90:
    /*     TEST FOR CYCLING. */
    if (*est <= estold) goto L120;

    for (i = 0; i < *n; ++i) {
	x[i] = d_sign(one, x[i]);
	isgn[i] = i_dnnt(x[i]);
    }
    *kase = 2;
    jump = 4;
    return 0;

    /*     ................ ENTRY   (JUMP = 4)   
	   X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. */
L110:
    jlast = j;
#ifdef _CRAY
    j = ISAMAX(n, &x[0], &c__1);
#else
    j = isamax_(n, &x[0], &c__1);
#endif
    --j;
    if (x[jlast] != fabs(x[j]) && iter < 5) {
	++iter;
	goto L50;
    }

    /*     ITERATION COMPLETE.  FINAL STAGE. */
L120:
    altsgn = 1.;
    for (i = 1; i <= *n; ++i) {
	x[i-1] = altsgn * ((float)(i - 1) / (float)(*n - 1) + 1.);
	altsgn = -altsgn;
    }
    *kase = 1;
    jump = 5;
    return 0;
    
    /*     ................ ENTRY   (JUMP = 5)   
	   X HAS BEEN OVERWRITTEN BY A*X. */
L140:
#ifdef _CRAY
    temp = SASUM(n, x, &c__1) / (float)(*n * 3) * 2.;
#else
    temp = sasum_(n, x, &c__1) / (float)(*n * 3) * 2.;
#endif
    if (temp > *est) {
#ifdef _CRAY
	SCOPY(n, &x[0], &c__1, &v[0], &c__1);
#else
	scopy_(n, &x[0], &c__1, &v[0], &c__1);
#endif
	*est = temp;
    }

L150:
    *kase = 0;
    return 0;

} /* slacon_ */
示例#19
0
文件: initsv.c 项目: LACunha/MOPAC
/* Subroutine */ int initsv_(integer *indeps)
{
    /* Initialized data */

    static doublereal rvdw[53] = { 1.08,1.,1.8,999.,999.,1.53,1.48,1.36,1.3,
	    999.,2.3,999.,2.05,2.1,1.75,1.7,1.65,999.,2.8,2.75,999.,999.,999.,
	    999.,999.,999.,999.,999.,999.,999.,999.,999.,999.,999.,1.8,999.,
	    999.,999.,999.,999.,999.,999.,999.,999.,999.,999.,999.,999.,999.,
	    999.,999.,999.,2.05 };

    /* System generated locals */
    integer i__1, i__2;
    doublereal d__1;

    /* Builtin functions */
    double sqrt(doublereal);
    integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), 
	    e_wsle(void);
    /* Subroutine */ int s_stop(char *, ftnlen);
    integer i_indx(char *, char *, ftnlen, ftnlen), i_dnnt(doublereal *);
    double log(doublereal);
    integer pow_ii(integer *, integer *);

    /* Local variables */
    static integer i__, n;
    static doublereal x;
    static integer i4;
    static doublereal x0, z3, z4;
#define iw ((integer *)&chanel_1 + 5)
    static integer iat;
    static doublereal epsi, avdw;
    extern doublereal reada_(char *, integer *, ftnlen);
    static doublereal delsc, disex;
#define dirsm ((doublereal *)&solv_1 + 1325)
    static doublereal rsolv;
    static integer indels, indise;
    extern /* Subroutine */ int dvfill_(integer *, doublereal *);
#define dirsmh ((doublereal *)&solv_1 + 4571)
    static integer maxnps, inrsol;
    static doublereal usevdw[53];

    /* Fortran I/O blocks */
    static cilist io___10 = { 0, 0, 0, 0, 0 };
    static cilist io___15 = { 0, 0, 0, 0, 0 };


/* 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 */
    for (i__ = 1; i__ <= 53; ++i__) {
/* L10: */
	usevdw[i__ - 1] = rvdw[i__ - 1];
    }
    epsi = reada_(keywrd_1.keywrd, indeps, (ftnlen)241);
    solv_1.fepsi = (epsi - 1.) / (epsi + .5);
    solvps_1.nps = 0;
    *iw = 6;
    solv_1.nden = molkst_1.norbs * 3 - (molkst_1.numat << 1);
    maxnps = sqrt(324000.25099999999f) - solv_1.nden - .5f;
    maxnps = min(maxnps,400);
/*     WRITE(IW,*) 'MAXIMUM NUMBER OF SEGMENTS ALLOWED:',MAXNPS */
    if (solv_1.nden * (solv_1.nden + 1) / 2 > 162000) {
	io___10.ciunit = *iw;
	s_wsle(&io___10);
	do_lio(&c__9, &c__1, "PARAMETER LENABC IS TOO SMALL FOR THIS SYSTEM", 
		(ftnlen)45);
	e_wsle();
	s_stop("PARAMETER LENABC IS TOO SMALL FOR THIS SYSTEM", (ftnlen)45);
    }
    rsolv = 1.;
    inrsol = i_indx(keywrd_1.keywrd, "RSOLV=", (ftnlen)241, (ftnlen)6);
    if (inrsol != 0) {
	rsolv = reada_(keywrd_1.keywrd, &inrsol, (ftnlen)241);
    }
    if (rsolv < 0.f) {
	s_stop(" RSOLV MUST NOT BE NEGATIVE", (ftnlen)27);
    }
    delsc = rsolv;
    indels = i_indx(keywrd_1.keywrd, "DELSC=", (ftnlen)241, (ftnlen)6);
    if (indels != 0) {
	delsc = reada_(keywrd_1.keywrd, &indels, (ftnlen)241);
    }
    if (delsc < .1) {
	io___15.ciunit = *iw;
	s_wsle(&io___15);
	do_lio(&c__9, &c__1, " DELSC TOO SMALL: SET TO 0.1", (ftnlen)28);
	e_wsle();
    }
    if (delsc > rsolv + .5) {
	s_stop(" DELSC UNREASONABLY LARGE", (ftnlen)25);
    }
    solv_1.rds = max(delsc,.1);
    disex = 2.;
    indise = i_indx(keywrd_1.keywrd, "DISEX=", (ftnlen)241, (ftnlen)6);
    if (indise != 0) {
	disex = reada_(keywrd_1.keywrd, &indise, (ftnlen)241);
    }
    i__1 = molkst_1.numat;
    for (i__ = 1; i__ <= i__1; ++i__) {
	iat = molkst_1.nat[i__ - 1];
	if (iat > 53) {
	    s_stop("MISSING VAN DER WAALS RADIUS", (ftnlen)28);
	} else {
	    avdw = usevdw[iat - 1];
	    if (avdw > 10.) {
		s_stop("MISSING VAN DER WAALS RADIUS", (ftnlen)28);
	    }
	}
	solv_1.srad[i__ - 1] = avdw + rsolv;
/* L20: */
    }
    solv_1.nspa = 60;
    if (i_indx(keywrd_1.keywrd, "NSPA=", (ftnlen)241, (ftnlen)5) != 0) {
	i__1 = i_indx(keywrd_1.keywrd, "NSPA", (ftnlen)241, (ftnlen)4);
	d__1 = reada_(keywrd_1.keywrd, &i__1, (ftnlen)241);
	solv_1.nspa = i_dnnt(&d__1);
    }
    x0 = log(solv_1.nspa * .1 - .199999);
    z3 = log(3.);
    z4 = log(4.);
    i4 = (integer) (x0 / z4);
    solvps_1.nps2 = 0;
    i__1 = i4;
    for (i__ = 0; i__ <= i__1; ++i__) {
	x = x0 - i__ * z4;
	i__2 = (integer) (x / z3);
	n = pow_ii(&c__3, &i__2) * pow_ii(&c__4, &i__);
/* L7: */
	if (n > solvps_1.nps2) {
	    solvps_1.nps2 = n;
	}
    }
    solvps_1.nps = solvps_1.nps2 / 3;
    if (solvps_1.nps2 % 3 != 0) {
	solvps_1.nps = solvps_1.nps2 / 4;
    }
    solvps_1.nps2 = solvps_1.nps2 * 10 + 2;
/* Computing MAX */
    i__1 = 12, i__2 = solvps_1.nps * 10 + 2;
    solvps_1.nps = max(i__1,i__2);
    dvfill_(&solvps_1.nps2, dirsm);
    dvfill_(&solvps_1.nps, dirsmh);
    solvps_1.nps = -solvps_1.nps;
/* Computing 2nd power */
    d__1 = (rsolv + 1.5 - solv_1.rds) * 4 * disex;
    solv_1.disex2 = d__1 * d__1 / solv_1.nspa;
    dvfill_(&c__1082, dirvec_1.dirvec);
    return 0;
} /* initsv_ */
示例#20
0
/* Subroutine */ int dlacon_(integer *n, doublereal *v, doublereal *x, 
	integer *isgn, doublereal *est, integer *kase)
{
    /* System generated locals */
    integer i__1;
    doublereal d__1;

    /* Builtin functions */
    double d_sign(doublereal *, doublereal *);
    integer i_dnnt(doublereal *);

    /* Local variables */
    static integer i__, j, iter;
    static doublereal temp;
    static integer jump;
    extern doublereal dasum_(integer *, doublereal *, integer *);
    static integer jlast;
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
	    doublereal *, integer *);
    extern integer idamax_(integer *, doublereal *, integer *);
    static doublereal altsgn, estold;


/*  -- LAPACK auxiliary routine (version 2.0) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/*     Courant Institute, Argonne National Lab, and Rice University */
/*     February 29, 1992 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  DLACON estimates the 1-norm of a square, real matrix A. */
/*  Reverse communication is used for evaluating matrix-vector products. */

/*  Arguments */
/*  ========= */

/*  N      (input) INTEGER */
/*         The order of the matrix.  N >= 1. */

/*  V      (workspace) DOUBLE PRECISION array, dimension (N) */
/*         On the final return, V = A*W,  where  EST = norm(V)/norm(W) */
/*         (W is not returned). */

/*  X      (input/output) DOUBLE PRECISION array, dimension (N) */
/*         On an intermediate return, X should be overwritten by */
/*               A * X,   if KASE=1, */
/*               A' * X,  if KASE=2, */
/*         and DLACON must be re-called with all the other parameters */
/*         unchanged. */

/*  ISGN   (workspace) INTEGER array, dimension (N) */

/*  EST    (output) DOUBLE PRECISION */
/*         An estimate (a lower bound) for norm(A). */

/*  KASE   (input/output) INTEGER */
/*         On the initial call to DLACON, KASE should be 0. */
/*         On an intermediate return, KASE will be 1 or 2, indicating */
/*         whether X should be overwritten by A * X  or A' * X. */
/*         On the final return from DLACON, KASE will again be 0. */

/*  Further Details */
/*  ======= ======= */

/*  Contributed by Nick Higham, University of Manchester. */
/*  Originally named SONEST, dated March 16, 1988. */

/*  Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */
/*  a real or complex matrix, with applications to condition estimation", */
/*  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */

/*  ===================================================================== */

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Save statement .. */
/*     .. */
/*     .. Executable Statements .. */

    /* Parameter adjustments */
    --isgn;
    --x;
    --v;

    /* Function Body */
    if (*kase == 0) {
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    x[i__] = 1. / (doublereal) (*n);
/* L10: */
	}
	*kase = 1;
	jump = 1;
	return 0;
    }

    switch (jump) {
	case 1:  goto L20;
	case 2:  goto L40;
	case 3:  goto L70;
	case 4:  goto L110;
	case 5:  goto L140;
    }

/*     ................ ENTRY   (JUMP = 1) */
/*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY A*X. */

L20:
    if (*n == 1) {
	v[1] = x[1];
	*est = abs(v[1]);
/*        ... QUIT */
	goto L150;
    }
    *est = dasum_(n, &x[1], &c__1);

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x[i__] = d_sign(&c_b11, &x[i__]);
	isgn[i__] = i_dnnt(&x[i__]);
/* L30: */
    }
    *kase = 2;
    jump = 2;
    return 0;

/*     ................ ENTRY   (JUMP = 2) */
/*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. */

L40:
    j = idamax_(n, &x[1], &c__1);
    iter = 2;

/*     MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */

L50:
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x[i__] = 0.;
/* L60: */
    }
    x[j] = 1.;
    *kase = 1;
    jump = 3;
    return 0;

/*     ................ ENTRY   (JUMP = 3) */
/*     X HAS BEEN OVERWRITTEN BY A*X. */

L70:
    dcopy_(n, &x[1], &c__1, &v[1], &c__1);
    estold = *est;
    *est = dasum_(n, &v[1], &c__1);
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	d__1 = d_sign(&c_b11, &x[i__]);
	if (i_dnnt(&d__1) != isgn[i__]) {
	    goto L90;
	}
/* L80: */
    }
/*     REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
    goto L120;

L90:
/*     TEST FOR CYCLING. */
    if (*est <= estold) {
	goto L120;
    }

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x[i__] = d_sign(&c_b11, &x[i__]);
	isgn[i__] = i_dnnt(&x[i__]);
/* L100: */
    }
    *kase = 2;
    jump = 4;
    return 0;

/*     ................ ENTRY   (JUMP = 4) */
/*     X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. */

L110:
    jlast = j;
    j = idamax_(n, &x[1], &c__1);
    if (x[jlast] != (d__1 = x[j], abs(d__1)) && iter < 5) {
	++iter;
	goto L50;
    }

/*     ITERATION COMPLETE.  FINAL STAGE. */

L120:
    altsgn = 1.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x[i__] = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) + 
		1.);
	altsgn = -altsgn;
/* L130: */
    }
    *kase = 1;
    jump = 5;
    return 0;

/*     ................ ENTRY   (JUMP = 5) */
/*     X HAS BEEN OVERWRITTEN BY A*X. */

L140:
    temp = dasum_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.;
    if (temp > *est) {
	dcopy_(n, &x[1], &c__1, &v[1], &c__1);
	*est = temp;
    }

L150:
    *kase = 0;
    return 0;

/*     End of DLACON */

} /* dlacon_ */
示例#21
0
/* Subroutine */ int dlacn2_(integer *n, doublereal *v, doublereal *x, 
	integer *isgn, doublereal *est, integer *kase, integer *isave)
{
/*  -- LAPACK auxiliary routine (version 3.1) --   
       Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..   
       November 2006   


    Purpose   
    =======   

    DLACN2 estimates the 1-norm of a square, real matrix A.   
    Reverse communication is used for evaluating matrix-vector products.   

    Arguments   
    =========   

    N      (input) INTEGER   
           The order of the matrix.  N >= 1.   

    V      (workspace) DOUBLE PRECISION array, dimension (N)   
           On the final return, V = A*W,  where  EST = norm(V)/norm(W)   
           (W is not returned).   

    X      (input/output) DOUBLE PRECISION array, dimension (N)   
           On an intermediate return, X should be overwritten by   
                 A * X,   if KASE=1,   
                 A' * X,  if KASE=2,   
           and DLACN2 must be re-called with all the other parameters   
           unchanged.   

    ISGN   (workspace) INTEGER array, dimension (N)   

    EST    (input/output) DOUBLE PRECISION   
           On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be   
           unchanged from the previous call to DLACN2.   
           On exit, EST is an estimate (a lower bound) for norm(A).   

    KASE   (input/output) INTEGER   
           On the initial call to DLACN2, KASE should be 0.   
           On an intermediate return, KASE will be 1 or 2, indicating   
           whether X should be overwritten by A * X  or A' * X.   
           On the final return from DLACN2, KASE will again be 0.   

    ISAVE  (input/output) INTEGER array, dimension (3)   
           ISAVE is used to save variables between calls to DLACN2   

    Further Details   
    ======= =======   

    Contributed by Nick Higham, University of Manchester.   
    Originally named SONEST, dated March 16, 1988.   

    Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of   
    a real or complex matrix, with applications to condition estimation",   
    ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.   

    This is a thread safe version of DLACON, which uses the array ISAVE   
    in place of a SAVE statement, as follows:   

       DLACON     DLACN2   
        JUMP     ISAVE(1)   
        J        ISAVE(2)   
        ITER     ISAVE(3)   

    =====================================================================   


       Parameter adjustments */
    /* Table of constant values */
    static integer c__1 = 1;
    static doublereal c_b11 = 1.;
    
    /* System generated locals */
    integer i__1;
    doublereal d__1;
    /* Builtin functions */
    double d_sign(doublereal *, doublereal *);
    integer i_dnnt(doublereal *);
    /* Local variables */
    static integer i__;
    static doublereal temp;
    extern doublereal dasum_(integer *, doublereal *, integer *);
    static integer jlast;
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
	    doublereal *, integer *);
    extern integer idamax_(integer *, doublereal *, integer *);
    static doublereal altsgn, estold;


    --isave;
    --isgn;
    --x;
    --v;

    /* Function Body */
    if (*kase == 0) {
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    x[i__] = 1. / (doublereal) (*n);
/* L10: */
	}
	*kase = 1;
	isave[1] = 1;
	return 0;
    }

    switch (isave[1]) {
	case 1:  goto L20;
	case 2:  goto L40;
	case 3:  goto L70;
	case 4:  goto L110;
	case 5:  goto L140;
    }

/*     ................ ENTRY   (ISAVE( 1 ) = 1)   
       FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY A*X. */

L20:
    if (*n == 1) {
	v[1] = x[1];
	*est = abs(v[1]);
/*        ... QUIT */
	goto L150;
    }
    *est = dasum_(n, &x[1], &c__1);

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x[i__] = d_sign(&c_b11, &x[i__]);
	isgn[i__] = i_dnnt(&x[i__]);
/* L30: */
    }
    *kase = 2;
    isave[1] = 2;
    return 0;

/*     ................ ENTRY   (ISAVE( 1 ) = 2)   
       FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */

L40:
    isave[2] = idamax_(n, &x[1], &c__1);
    isave[3] = 2;

/*     MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */

L50:
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x[i__] = 0.;
/* L60: */
    }
    x[isave[2]] = 1.;
    *kase = 1;
    isave[1] = 3;
    return 0;

/*     ................ ENTRY   (ISAVE( 1 ) = 3)   
       X HAS BEEN OVERWRITTEN BY A*X. */

L70:
    dcopy_(n, &x[1], &c__1, &v[1], &c__1);
    estold = *est;
    *est = dasum_(n, &v[1], &c__1);
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	d__1 = d_sign(&c_b11, &x[i__]);
	if (i_dnnt(&d__1) != isgn[i__]) {
	    goto L90;
	}
/* L80: */
    }
/*     REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
    goto L120;

L90:
/*     TEST FOR CYCLING. */
    if (*est <= estold) {
	goto L120;
    }

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x[i__] = d_sign(&c_b11, &x[i__]);
	isgn[i__] = i_dnnt(&x[i__]);
/* L100: */
    }
    *kase = 2;
    isave[1] = 4;
    return 0;

/*     ................ ENTRY   (ISAVE( 1 ) = 4)   
       X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */

L110:
    jlast = isave[2];
    isave[2] = idamax_(n, &x[1], &c__1);
    if (x[jlast] != (d__1 = x[isave[2]], abs(d__1)) && isave[3] < 5) {
	++isave[3];
	goto L50;
    }

/*     ITERATION COMPLETE.  FINAL STAGE. */

L120:
    altsgn = 1.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x[i__] = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) + 
		1.);
	altsgn = -altsgn;
/* L130: */
    }
    *kase = 1;
    isave[1] = 5;
    return 0;

/*     ................ ENTRY   (ISAVE( 1 ) = 5)   
       X HAS BEEN OVERWRITTEN BY A*X. */

L140:
    temp = dasum_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.;
    if (temp > *est) {
	dcopy_(n, &x[1], &c__1, &v[1], &c__1);
	*est = temp;
    }

L150:
    *kase = 0;
    return 0;

/*     End of DLACN2 */

} /* dlacn2_ */
示例#22
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_ */
示例#23
0
/* $Procedure ZZEKSZ05 ( EK, element entry size, class 5 ) */
integer zzeksz05_(integer *handle, integer *segdsc, integer *coldsc, integer *
	recptr)
{
    /* System generated locals */
    integer ret_val;

    /* Builtin functions */
    integer i_dnnt(doublereal *);

    /* Local variables */
    integer nrec;
    extern /* Subroutine */ int chkin_(char *, ftnlen);
    doublereal dpcnt;
    integer ncols;
    extern /* Subroutine */ int dasrdd_(integer *, integer *, integer *, 
	    doublereal *), dasrdi_(integer *, integer *, integer *, integer *)
	    ;
    integer colidx, datptr, ptrloc;
    extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *, 
	    integer *, ftnlen), sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen);

/* $ Abstract */

/*     Return the size of a specified entry in a class 5 column. */

/* $ 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 */

/*     EK */

/* $ Keywords */

/*     EK */
/*     PRIVATE */

/* $ Declarations */
/* $ 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. */


/*     Include Section:  EK Boolean Enumerated Type */


/*        ekbool.inc Version 1   21-DEC-1994 (NJB) */


/*     Within the EK system, boolean values sometimes must be */
/*     represented by integer or character codes.  The codes and their */
/*     meanings are listed below. */

/*     Integer code indicating `true': */


/*     Integer code indicating `false': */


/*     Character code indicating `true': */


/*     Character code indicating `false': */


/*     End Include Section:  EK Boolean Enumerated Type */

/* $ 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. */


/*     Include Section:  EK Column Descriptor Parameters */

/*        ekcoldsc.inc Version 6    23-AUG-1995 (NJB) */


/*     Note:  The column descriptor size parameter CDSCSZ  is */
/*     declared separately in the include section CDSIZE$INC.FOR. */

/*     Offset of column descriptors, relative to start of segment */
/*     integer address range.  This number, when added to the last */
/*     integer address preceding the segment, yields the DAS integer */
/*     base address of the first column descriptor.  Currently, this */
/*     offset is exactly the size of a segment descriptor.  The */
/*     parameter SDSCSZ, which defines the size of a segment descriptor, */
/*     is declared in the include file eksegdsc.inc. */


/*     Size of column descriptor */


/*     Indices of various pieces of column descriptors: */


/*     CLSIDX is the index of the column's class code.  (We use the */
/*     word `class' to distinguish this item from the column's data */
/*     type.) */


/*     TYPIDX is the index of the column's data type code (CHR, INT, DP, */
/*     or TIME).  The type is actually implied by the class, but it */
/*     will frequently be convenient to look up the type directly. */



/*     LENIDX is the index of the column's string length value, if the */
/*     column has character type.  A value of IFALSE in this element of */
/*     the descriptor indicates that the strings have variable length. */


/*     SIZIDX is the index of the column's element size value.  This */
/*     descriptor element is meaningful for columns with fixed-size */
/*     entries.  For variable-sized columns, this value is IFALSE. */


/*     NAMIDX is the index of the base address of the column's name. */


/*     IXTIDX is the data type of the column's index.  IXTIDX */
/*     contains a type value only if the column is indexed. For columns */
/*     that are not indexed, the location IXTIDX contains the boolean */
/*     value IFALSE. */


/*     IXPIDX is a pointer to the column's index.  IXTPDX contains a */
/*     meaningful value only if the column is indexed.  The */
/*     interpretation of the pointer depends on the data type of the */
/*     index. */


/*     NFLIDX is the index of a flag indicating whether nulls are */
/*     permitted in the column.  The value at location NFLIDX is */
/*     ITRUE if nulls are permitted and IFALSE otherwise. */


/*     ORDIDX is the index of the column's ordinal position in the */
/*     list of columns belonging to the column's parent segment. */


/*     METIDX is the index of the column's integer metadata pointer. */
/*     This pointer is a DAS integer address. */


/*     The last position in the column descriptor is reserved.  No */
/*     parameter is defined to point to this location. */


/*     End Include Section:  EK Column Descriptor Parameters */

/* $ 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. */


/*     Include Section:  EK Data Page Parameters */

/*        ekfilpar.inc  Version 1  03-APR-1995 (NJB) */

/*     These parameters apply to EK files using architecture 4. */
/*     These files use a paged DAS file as their underlying file */
/*     structure. */

/*     In paged DAS EK files, data pages are structured:  they contain */
/*     metadata as well as data.  The metadata is located in the last */
/*     few addresses of each page, so as to interfere as little as */
/*     possible with calculation of data addresses. */

/*     Each data page belongs to exactly one segment.  Some bookkeeping */
/*     information, such as record pointers, is also stored in data */
/*     pages. */

/*     Each page contains a forward pointer that allows rapid lookup */
/*     of data items that span multiple pages.  Each page also keeps */
/*     track of the current number of links from its parent segment */
/*     to the page.  Link counts enable pages to `know' when they */
/*     are no longer in use by a segment; unused pages are deallocated */
/*     and returned to the free list. */

/*     The parameters in this include file depend on the parameters */
/*     declared in the include file ekpage.inc.  If those parameters */
/*     change, this file must be updated.  The specified parameter */
/*     declarations we need from that file are: */

/*        INTEGER               PGSIZC */
/*        PARAMETER           ( PGSIZC = 1024 ) */

/*        INTEGER               PGSIZD */
/*        PARAMETER           ( PGSIZD = 128 ) */

/*        INTEGER               PGSIZI */
/*        PARAMETER           ( PGSIZI = 256 ) */



/*     Character pages use an encoding mechanism to represent integer */
/*     metadata.  Each integer is encoded in five consecutive */
/*     characters. */


/*     Character data page parameters: */


/*     Size of encoded integer: */


/*     Usable page size: */


/*     Location of character forward pointer: */


/*     Location of character link count: */


/*     Double precision data page parameters: */

/*     Usable page size: */


/*     Location of d.p. forward pointer: */


/*     Location of d.p. link count: */


/*     Integer data page parameters: */

/*     Usable page size: */


/*     Location of integer forward pointer: */


/*     Location of integer link count: */


/*     End Include Section:  EK Data Page Parameters */

/* $ 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. */


/*     Include Section:  EK Record Pointer Parameters */

/*        ekrecptr.inc Version 2  18-JUL-1995 (NJB) */


/*     This file declares parameters used in EK record pointers. */
/*     Each segment references data in a given record via two levels */
/*     of indirection:  a record number points to a record pointer, */
/*     which is a structured array of metadata and data pointers. */

/*     Record pointers always occupy contiguous ranges of integer */
/*     addresses. */

/*     The parameter declarations in this file depend on the assumption */
/*     that integer pages contain 256 DAS integer words and that the */
/*     maximum number of columns in a segment is 100.  Record pointers */
/*     are stored in integer data pages, so they must fit within the */
/*     usable data area afforded by these pages.  The size of the usable */
/*     data area is given by the parameter IPSIZE which is declared in */
/*     ekdatpag.inc.  The assumed value of IPSIZE is 254. */


/*     The first element of each record pointer is a status indicator. */
/*     The meanings of status indicators depend on whether the parent EK */
/*     is shadowed or not.  For shadowed EKs, allowed status values and */
/*     their meanings are: */

/*        OLD       The record has not been modified since */
/*                  the EK containing the record was opened. */

/*        UPDATE    The record is an update of a previously existing */
/*                  record.  The original record is now on the */
/*                  modified record list. */

/*        NEW       The record has been added since the EK containing the */
/*                  record was opened.  The record is not an update */
/*                  of a previously existing record. */

/*        DELOLD    This status applies only to a backup record. */
/*                  DELOLD status indicates that the record corresponds */
/*                  to a deleted OLD record in the source segment. */

/*        DELNEW    This status applies only to a backup record. */
/*                  DELNEW status indicates that the record corresponds */
/*                  to a deleted NEW record in the source segment. */

/*        DELUPD    This status applies only to a backup record. */
/*                  DELUPD status indicates that the record corresponds */
/*                  to a deleted UPDATEd record in the source segment. */

/*     In EKs that are not shadowed, all records have status OLD. */



/*     The following parameters refer to indices within the record */
/*     pointer structure: */

/*     Index of status indicator: */


/*     Each record pointer contains a pointer to its companion:  for a */
/*     record belonging to a shadowed EK, this is the backup counterpart, */
/*     or if the parent EK is itself a backup EK, a pointer to the */
/*     record's source record.  The pointer is UNINIT (see below) if the */
/*     record is unmodified. */

/*     Record companion pointers contain record numbers, not record */
/*     base addresses. */

/*     Index of record's companion pointer: */


/*     Each data item is referenced by an integer.  The meaning of */
/*     this integer depends on the representation of data in the */
/*     column to which the data item belongs.  Actual lookup of a */
/*     data item must be done by subroutines appropriate to the class of */
/*     the column to which the item belongs.  Note that data items don't */
/*     necessarily occupy contiguous ranges of DAS addresses. */

/*     Base address of data pointers: */


/*     Maximum record pointer size: */


/*     Data pointers are given the value UNINIT to start with; this */
/*     indicates that the data item is uninitialized.  UNINIT is */
/*     distinct from the value NULL.  NOBACK indicates an uninitialized */
/*     backup column entry. */


/*     End Include Section:  EK Record Pointer Parameters */

/* $ 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. */


/*     Include Section:  EK Segment Descriptor Parameters */

/*        eksegdsc.inc  Version 8  06-NOV-1995 (NJB) */


/*     All `base addresses' referred to below are the addresses */
/*     *preceding* the item the base applies to.  This convention */
/*     enables simplied address calculations in many cases. */

/*     Size of segment descriptor.  Note:  the include file ekcoldsc.inc */
/*     must be updated if this parameter is changed.  The parameter */
/*     CDOFF in that file should be kept equal to SDSCSZ. */


/*     Index of the segment type code: */


/*     Index of the segment's number.  This number is the segment's */
/*     index in the list of segments contained in the EK to which */
/*     the segment belongs. */


/*     Index of the DAS integer base address of the segment's integer */
/*     meta-data: */


/*     Index of the DAS character base address of the table name: */


/*     Index of the segment's column count: */


/*     Index of the segment's record count: */


/*     Index of the root page number of the record tree: */


/*     Index of the root page number of the character data page tree: */


/*     Index of the root page number of the double precision data page */
/*     tree: */


/*     Index of the root page number of the integer data page tree: */


/*     Index of the `modified' flag: */


/*     Index of the `initialized' flag: */


/*     Index of the shadowing flag: */


/*     Index of the companion file handle: */


/*     Index of the companion segment number: */


/*     The next three items are, respectively, the page numbers of the */
/*     last character, d.p., and integer data pages allocated by the */
/*     segment: */


/*     The next three items are, respectively, the page-relative */
/*     indices of the last DAS word in use in the segment's */
/*     last character, d.p., and integer data pages: */


/*     Index of the DAS character base address of the column name list: */


/*     The last descriptor element is reserved for future use.  No */
/*     parameter is defined to point to this location. */


/*     End Include Section:  EK Segment Descriptor Parameters */

/* $ 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. */


/*     Include Section:  EK Data Types */

/*        ektype.inc Version 1  27-DEC-1994 (NJB) */


/*     Within the EK system, data types of EK column contents are */
/*     represented by integer codes.  The codes and their meanings */
/*     are listed below. */

/*     Integer codes are also used within the DAS system to indicate */
/*     data types; the EK system makes no assumptions about compatibility */
/*     between the codes used here and those used in the DAS system. */


/*     Character type: */


/*     Double precision type: */


/*     Integer type: */


/*     `Time' type: */

/*     Within the EK system, time values are represented as ephemeris */
/*     seconds past J2000 (TDB), and double precision numbers are used */
/*     to store these values.  However, since time values require special */
/*     treatment both on input and output, and since the `TIME' column */
/*     has a special role in the EK specification and code, time values */
/*     are identified as a type distinct from double precision numbers. */


/*     End Include Section:  EK Data Types */

/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     HANDLE     I   File handle. */
/*     SEGDSC     I   Segment descriptor. */
/*     COLDSC     I   Column descriptor. */
/*     RECPTR     I   Record pointer. */

/*     The function returns the number of elements in the specified */
/*     column entry. */

/* $ Detailed_Input */

/*     HANDLE         is an EK file handle.  The file may be open for */
/*                    reading or writing. */

/*     SEGDSC         is the segment descriptor of the segment */
/*                    containing the column specified by COLDSC. */

/*     COLDSC         is the column descriptor of the column containing */
/*                    the entry whose size is requested.  The column */
/*                    must be class 5. */

/*     RECPTR         is a pointer to the EK record containing the */
/*                    column entry of interest. */

/* $ Detailed_Output */

/*     The function returns the number of elements in the specified */
/*     column entry. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     1)  If HANDLE is invalid, the error will be diagnosed by routines */
/*         called by this routine. */

/*     2)  If an I/O error occurs while reading the indicated file, */
/*         the error will be diagnosed by routines called by this */
/*         routine. */

/*     3)  If the column index contained in the input column descriptor */
/*         is out of range, the error SPICE(INVALIDINDEX) is signalled. */

/* $ Files */

/*     See the EK Required Reading for a discussion of the EK file */
/*     format. */

/* $ Particulars */

/*     This utility supports the commonly performed function of */
/*     determining the element count of a column entry. */

/* $ Examples */

/*     See ZZEKESIZ. */

/* $ Restrictions */

/*     None. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman   (JPL) */

/* $ Version */

/* -    Beta Version 1.0.0, 18-OCT-1995 (NJB) */

/* -& */

/*     Local variables */


/*     Use discovery check-in. */

/*     Initialize the function's return value. */

    ret_val = 0;
    nrec = segdsc[5];
    colidx = coldsc[8];

/*     Make sure the column exists. */

    ncols = segdsc[4];
    if (colidx < 1 || colidx > ncols) {
	chkin_("ZZEKSZ05", (ftnlen)8);
	setmsg_("Column index = #; valid range is 1:#.", (ftnlen)37);
	errint_("#", &colidx, (ftnlen)1);
	errint_("#", &nrec, (ftnlen)1);
	sigerr_("SPICE(INVALIDINDEX)", (ftnlen)19);
	chkout_("ZZEKSZ05", (ftnlen)8);
	return ret_val;
    }

/*     If the column has fixed-size entries, just return the declared */
/*     size. */

    if (coldsc[3] != -1) {
	ret_val = coldsc[3];
	return ret_val;
    }

/*     Compute the data pointer location.  Read the data pointer. */

    ptrloc = *recptr + 2 + colidx;
    dasrdi_(handle, &ptrloc, &ptrloc, &datptr);
    if (datptr < 1) {

/*        The value is null.  Null entries are always considered to have */
/*        size 1. */

	ret_val = 1;
    } else {

/*        DATPTR points to the element count. */

	dasrdd_(handle, &datptr, &datptr, &dpcnt);
	ret_val = i_dnnt(&dpcnt);
    }
    return ret_val;
} /* zzeksz05_ */
示例#24
0
/* $Procedure      BODMAT ( Return transformation matrix for a body ) */
/* Subroutine */ int bodmat_(integer *body, doublereal *et, doublereal *tipm)
{
    /* Initialized data */

    static logical first = TRUE_;
    static logical found = FALSE_;

    /* System generated locals */
    integer i__1, i__2, i__3;
    doublereal d__1;

    /* Builtin functions */
    integer s_rnge(char *, integer, char *, integer);
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
    integer i_dnnt(doublereal *);
    double sin(doublereal), cos(doublereal), d_mod(doublereal *, doublereal *)
	    ;

    /* Local variables */
    integer cent;
    char item[32];
    doublereal j2ref[9]	/* was [3][3] */;
    extern integer zzbodbry_(integer *);
    extern /* Subroutine */ int eul2m_(doublereal *, doublereal *, doublereal 
	    *, integer *, integer *, integer *, doublereal *);
    doublereal d__;
    integer i__, j;
    doublereal dcoef[3], t, w;
    extern /* Subroutine */ int etcal_(doublereal *, char *, ftnlen);
    integer refid;
    doublereal delta;
    extern /* Subroutine */ int chkin_(char *, ftnlen);
    doublereal epoch, rcoef[3], tcoef[200]	/* was [2][100] */, wcoef[3];
    extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
    doublereal theta;
    extern /* Subroutine */ int moved_(doublereal *, integer *, doublereal *),
	     repmi_(char *, char *, integer *, char *, ftnlen, ftnlen, ftnlen)
	    , errdp_(char *, doublereal *, ftnlen);
    doublereal costh[100];
    extern doublereal vdotg_(doublereal *, doublereal *, integer *);
    char dtype[1];
    doublereal sinth[100], tsipm[36]	/* was [6][6] */;
    extern doublereal twopi_(void);
    static integer j2code;
    doublereal ac[100], dc[100];
    integer na, nd;
    doublereal ra, wc[100];
    extern /* Subroutine */ int cleard_(integer *, doublereal *);
    extern logical bodfnd_(integer *, char *, ftnlen);
    extern /* Subroutine */ int bodvcd_(integer *, char *, integer *, integer 
	    *, doublereal *, ftnlen);
    integer frcode;
    extern doublereal halfpi_(void);
    extern /* Subroutine */ int ccifrm_(integer *, integer *, integer *, char 
	    *, integer *, logical *, ftnlen);
    integer nw;
    doublereal conepc, conref;
    extern /* Subroutine */ int pckmat_(integer *, doublereal *, integer *, 
	    doublereal *, logical *);
    integer ntheta;
    extern /* Subroutine */ int gdpool_(char *, integer *, integer *, integer 
	    *, doublereal *, logical *, ftnlen);
    char fixfrm[32], errmsg[1840];
    extern /* Subroutine */ int irfnum_(char *, integer *, ftnlen), dtpool_(
	    char *, logical *, integer *, char *, ftnlen, ftnlen);
    doublereal tmpmat[9]	/* was [3][3] */;
    extern /* Subroutine */ int setmsg_(char *, ftnlen), suffix_(char *, 
	    integer *, char *, ftnlen, ftnlen), errint_(char *, integer *, 
	    ftnlen), sigerr_(char *, ftnlen), chkout_(char *, ftnlen), 
	    irfrot_(integer *, integer *, doublereal *);
    extern logical return_(void);
    char timstr[35];
    extern doublereal j2000_(void);
    doublereal dec;
    integer dim, ref;
    doublereal phi;
    extern doublereal rpd_(void), spd_(void);
    extern /* Subroutine */ int mxm_(doublereal *, doublereal *, doublereal *)
	    ;

/* $ Abstract */

/*     Return the J2000 to body Equator and Prime Meridian coordinate */
/*     transformation matrix for a specified body. */

/* $ 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 */

/*     PCK */
/*     NAIF_IDS */
/*     TIME */

/* $ Keywords */

/*     CONSTANTS */

/* $ Declarations */
/* $ 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. */


/*     Include File:  SPICELIB Error Handling Parameters */

/*        errhnd.inc  Version 2    18-JUN-1997 (WLT) */

/*           The size of the long error message was */
/*           reduced from 25*80 to 23*80 so that it */
/*           will be accepted by the Microsoft Power Station */
/*           FORTRAN compiler which has an upper bound */
/*           of 1900 for the length of a character string. */

/*        errhnd.inc  Version 1    29-JUL-1997 (NJB) */



/*     Maximum length of the long error message: */


/*     Maximum length of the short error message: */


/*     End Include File:  SPICELIB Error Handling Parameters */

/* $ Abstract */

/*     The parameters below form an enumerated list of the recognized */
/*     frame types.  They are: INERTL, PCK, CK, TK, DYN.  The meanings */
/*     are outlined below. */

/* $ 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. */

/* $ Parameters */

/*     INERTL      an inertial frame that is listed in the routine */
/*                 CHGIRF and that requires no external file to */
/*                 compute the transformation from or to any other */
/*                 inertial frame. */

/*     PCK         is a frame that is specified relative to some */
/*                 INERTL frame and that has an IAU model that */
/*                 may be retrieved from the PCK system via a call */
/*                 to the routine TISBOD. */

/*     CK          is a frame defined by a C-kernel. */

/*     TK          is a "text kernel" frame.  These frames are offset */
/*                 from their associated "relative" frames by a */
/*                 constant rotation. */

/*     DYN         is a "dynamic" frame.  These currently are */
/*                 parameterized, built-in frames where the full frame */
/*                 definition depends on parameters supplied via a */
/*                 frame kernel. */

/* $ Author_and_Institution */

/*     N.J. Bachman    (JPL) */
/*     W.L. Taber      (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 3.0.0, 28-MAY-2004 (NJB) */

/*       The parameter DYN was added to support the dynamic frame class. */

/* -    SPICELIB Version 2.0.0, 12-DEC-1996 (WLT) */

/*        Various unused frames types were removed and the */
/*        frame time TK was added. */

/* -    SPICELIB Version 1.0.0, 10-DEC-1995 (WLT) */

/* -& */
/* $ Brief_I/O */

/*     VARIABLE  I/O  DESCRIPTION */
/*     --------  ---  -------------------------------------------------- */
/*     BODY       I   ID code of body. */
/*     ET         I   Epoch of transformation. */
/*     TIPM       O   Transformation from Inertial to PM for BODY at ET. */

/* $ Detailed_Input */

/*     BODY        is the integer ID code of the body for which the */
/*                 transformation is requested. Bodies are numbered */
/*                 according to the standard NAIF numbering scheme. */

/*     ET          is the epoch at which the transformation is */
/*                 requested. (This is typically the epoch of */
/*                 observation minus the one-way light time from */
/*                 the observer to the body at the epoch of */
/*                 observation.) */

/* $ Detailed_Output */

/*     TIPM        is the transformation matrix from Inertial to body */
/*                 Equator and Prime Meridian.  The X axis of the PM */
/*                 system is directed to the intersection of the */
/*                 equator and prime meridian. The Z axis points north. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     1) If data required to define the body-fixed frame associated */
/*        with BODY are not found in the binary PCK system or the kernel */
/*        pool, the error SPICE(FRAMEDATANOTFOUND) is signaled. In */
/*        the case of IAU style body-fixed frames, the absence of */
/*        prime meridian polynomial data (which are required) is used */
/*        as an indicator of missing data. */

/*     2) If the test for exception (1) passes, but in fact requested */
/*        data are not available in the kernel pool, the error will be */
/*        signaled by routines in the call tree of this routine. */

/*     3) If the kernel pool does not contain all of the data required */
/*        to define the number of nutation precession angles */
/*        corresponding to the available nutation precession */
/*        coefficients, the error SPICE(INSUFFICIENTANGLES) is */
/*        signaled. */

/*     4) If the reference frame REF is not recognized, a routine */
/*        called by BODMAT will diagnose the condition and invoke the */
/*        SPICE error handling system. */

/*     5) If the specified body code BODY is not recognized, the */
/*        error is diagnosed by a routine called by BODMAT. */

/* $ Files */

/*     None. */

/* $ Particulars */

/*     This routine is related to the more general routine TIPBOD */
/*     which returns a matrix that transforms vectors from a */
/*     specified inertial reference frame to body equator and */
/*     prime meridian coordinates.  TIPBOD accepts an input argument */
/*     REF that allows the caller to specify an inertial reference */
/*     frame. */

/*     The transformation represented by BODMAT's output argument TIPM */
/*     is defined as follows: */

/*        TIPM = [W] [DELTA] [PHI] */
/*                 3        1     3 */

/*     If there exists high-precision binary PCK kernel information */
/*     for the body at the requested time, these angles, W, DELTA */
/*     and PHI are computed directly from that file.  The most */
/*     recently loaded binary PCK file has first priority followed */
/*     by previously loaded binary PCK files in backward time order. */
/*     If no binary PCK file has been loaded, the text P_constants */
/*     kernel file is used. */

/*     If there is only text PCK kernel information, it is */
/*     expressed in terms of RA, DEC and W (same W as above), where */

/*        RA    = PHI - HALFPI() */
/*        DEC   = HALFPI() - DELTA */

/*     RA, DEC, and W are defined as follows in the text PCK file: */

/*           RA  = RA0  + RA1*T  + RA2*T*T   + a  sin theta */
/*                                              i          i */

/*           DEC = DEC0 + DEC1*T + DEC2*T*T  + d  cos theta */
/*                                              i          i */

/*           W   = W0   + W1*d   + W2*d*d    + w  sin theta */
/*                                              i          i */

/*     where: */

/*           d = days past J2000. */

/*           T = Julian centuries past J2000. */

/*           a , d , and w  arrays apply to satellites only. */
/*            i   i       i */

/*           theta  = THETA0 * THETA1*T are specific to each planet. */
/*                i */

/*     These angles -- typically nodal rates -- vary in number and */
/*     definition from one planetary system to the next. */

/* $ Examples */

/*     In the following code fragment, BODMAT is used to rotate */
/*     the position vector (POS) from a target body (BODY) to a */
/*     spacecraft from inertial coordinates to body-fixed coordinates */
/*     at a specific epoch (ET), in order to compute the planetocentric */
/*     longitude (PCLONG) of the spacecraft. */

/*        CALL BODMAT ( BODY, ET, TIPM ) */
/*        CALL MXV    ( TIPM, POS, POS ) */
/*        CALL RECLAT ( POS, RADIUS, PCLONG, LAT ) */

/*     To compute the equivalent planetographic longitude (PGLONG), */
/*     it is necessary to know the direction of rotation of the target */
/*     body, as shown below. */

/*        CALL BODVCD ( BODY, 'PM', 3, DIM, VALUES ) */

/*        IF ( VALUES(2) .GT. 0.D0 ) THEN */
/*           PGLONG = PCLONG */
/*        ELSE */
/*           PGLONG = TWOPI() - PCLONG */
/*        END IF */

/*     Note that the items necessary to compute the transformation */
/*     TIPM must have been loaded into the kernel pool (by one or more */
/*     previous calls to FURNSH). */

/* $ Restrictions */

/*     None. */

/* $ Literature_References */

/*     1)  Refer to the NAIF_IDS required reading file for a complete */
/*         list of the NAIF integer ID codes for bodies. */

/* $ Author_and_Institution */

/*     N.J. Bachman    (JPL) */
/*     W.L. Taber      (JPL) */
/*     I.M. Underwood  (JPL) */
/*     K.S. Zukor      (JPL) */

/* $ Version */

/* -    SPICELIB Version 4.1.1, 01-FEB-2008 (NJB) */

/*        The routine was updated to improve the error messages created */
/*        when required PCK data are not found. Now in most cases the */
/*        messages are created locally rather than by the kernel pool */
/*        access routines. In particular missing binary PCK data will */
/*        be indicated with a reasonable error message. */

/* -    SPICELIB Version 4.1.0, 25-AUG-2005 (NJB) */

/*        Updated to remove non-standard use of duplicate arguments */
/*        in MXM call. */

/*         Calls to ZZBODVCD have been replaced with calls to */
/*         BODVCD. */

/* -     SPICELIB Version 4.0.0, 12-FEB-2004 (NJB) */

/*         Code has been updated to support satellite ID codes in the */
/*         range 10000 to 99999 and to allow nutation precession angles */
/*         to be associated with any object. */

/*         Implementation changes were made to improve robustness */
/*         of the code. */

/* -     SPICELIB Version 3.2.0, 22-MAR-1995 (KSZ) */

/*        Gets TSIPM matrix from PCKMAT (instead of Euler angles */
/*        from PCKEUL.) */

/* -     SPICELIB Version 3.0.0, 10-MAR-1994 (KSZ) */

/*        Ability to get Euler angles from binary PCK file added. */
/*        This uses the new routine PCKEUL. */

/* -     SPICELIB Version 2.0.1, 10-MAR-1992 (WLT) */

/*         Comment section for permuted index source lines was added */
/*         following the header. */

/* -     SPICELIB Version 2.0.0, 04-SEP-1991 (NJB) */

/*         Updated to handle P_constants referenced to different epochs */
/*         and inertial reference frames. */

/*         The header was updated to specify that the inertial reference */
/*         frame used by BODMAT is restricted to be J2000. */

/* -    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) (IMU) */

/* -& */
/* $ Index_Entries */

/*     fetch transformation matrix for a body */
/*     transformation from j2000 position to bodyfixed */
/*     transformation from j2000 to bodyfixed coordinates */

/* -& */
/* $ Revisions */

/* -    SPICELIB Version 4.1.0, 25-AUG-2005 (NJB) */

/*        Updated to remove non-standard use of duplicate arguments */
/*        in MXM call. */

/*         Calls to ZZBODVCD have been replaced with calls to */
/*         BODVCD. */

/* -     SPICELIB Version 4.0.0, 12-FEB-2004 (NJB) */

/*         Code has been updated to support satellite ID codes in the */
/*         range 10000 to 99999 and to allow nutation precession angles */
/*         to be associated with any object. */

/*         Calls to deprecated kernel pool access routine RTPOOL */
/*         were replaced by calls to GDPOOL. */

/*         Calls to BODVAR have been replaced with calls to */
/*         ZZBODVCD. */

/* -     SPICELIB Version 3.2.0, 22-MAR-1995 (KSZ) */

/*        BODMAT now get the TSIPM matrix from PCKMAT, and */
/*        unpacks TIPM from it.  Also the calculated but unused */
/*        variable LAMBDA was removed. */

/* -     SPICELIB Version 3.0.0, 10-MAR-1994 (KSZ) */

/*        BODMAT now uses new software to check for the */
/*        existence of binary PCK files, search the for */
/*        data corresponding to the requested body and time, */
/*        and return the appropriate Euler angles, using the */
/*        new routine PCKEUL.  Otherwise the code calculates */
/*        the Euler angles from the P_constants kernel file. */

/* -     SPICELIB Version 2.0.0, 04-SEP-1991 (NJB) */

/*         Updated to handle P_constants referenced to different epochs */
/*         and inertial reference frames. */

/*         The header was updated to specify that the inertial reference */
/*         frame used by BODMAT is restricted to be J2000. */

/*         BODMAT now checks the kernel pool for presence of the */
/*         variables */

/*            BODY#_CONSTANTS_REF_FRAME */

/*         and */

/*            BODY#_CONSTANTS_JED_EPOCH */

/*         where # is the NAIF integer code of the barycenter of a */
/*         planetary system or of a body other than a planet or */
/*         satellite.  If either or both of these variables are */
/*         present, the P_constants for BODY are presumed to be */
/*         referenced to the specified inertial frame or epoch. */
/*         If the epoch of the constants is not J2000, the input */
/*         time ET is converted to seconds past the reference epoch. */
/*         If the frame of the constants is not J2000, the rotation from */
/*         the P_constants' frame to body-fixed coordinates is */
/*         transformed to the rotation from J2000 coordinates to */
/*         body-fixed coordinates. */

/*         For efficiency reasons, this routine now duplicates much */
/*         of the code of BODEUL so that it doesn't have to call BODEUL. */
/*         In some cases, BODEUL must covert Euler angles to a matrix, */
/*         rotate the matrix, and convert the result back to Euler */
/*         angles.  If this routine called BODEUL, then in such cases */
/*         this routine would convert the transformed angles back to */
/*         a matrix.  That would be a bit much.... */


/* -    Beta Version 1.1.0, 16-FEB-1989 (IMU) (NJB) */

/*        Examples section completed.  Declaration of unused variable */
/*        FOUND removed. */

/* -& */

/*     SPICELIB functions */


/*     Local parameters */


/*     Local variables */


/*     Saved variables */


/*     Initial values */


/*     Standard SPICE Error handling. */

    if (return_()) {
	return 0;
    } else {
	chkin_("BODMAT", (ftnlen)6);
    }

/*     Get the code for the J2000 frame, if we don't have it yet. */

    if (first) {
	irfnum_("J2000", &j2code, (ftnlen)5);
	first = FALSE_;
    }

/*     Get Euler angles from high precision data file. */

    pckmat_(body, et, &ref, tsipm, &found);
    if (found) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    for (j = 1; j <= 3; ++j) {
		tipm[(i__1 = i__ + j * 3 - 4) < 9 && 0 <= i__1 ? i__1 : 
			s_rnge("tipm", i__1, "bodmat_", (ftnlen)485)] = tsipm[
			(i__2 = i__ + j * 6 - 7) < 36 && 0 <= i__2 ? i__2 : 
			s_rnge("tsipm", i__2, "bodmat_", (ftnlen)485)];
	    }
	}
    } else {

/*        The data for the frame of interest are not available in a */
/*        loaded binary PCK file. This is not an error: the data may be */
/*        present in the kernel pool. */

/*        Conduct a non-error-signaling check for the presence of a */
/*        kernel variable that is required to implement an IAU style */
/*        body-fixed reference frame. If the data aren't available, we */
/*        don't want BODVCD to signal a SPICE(KERNELVARNOTFOUND) error; */
/*        we want to issue the error signal locally, with a better error */
/*        message. */

	s_copy(item, "BODY#_PM", (ftnlen)32, (ftnlen)8);
	repmi_(item, "#", body, item, (ftnlen)32, (ftnlen)1, (ftnlen)32);
	dtpool_(item, &found, &nw, dtype, (ftnlen)32, (ftnlen)1);
	if (! found) {

/*           Now we do have an error. */

/*           We don't have the data we'll need to produced the requested */
/*           state transformation matrix. In order to create an error */
/*           message understandable to the user, find, if possible, the */
/*           name of the reference frame associated with the input body. */
/*           Note that the body is really identified by a PCK frame class */
/*           ID code, though most of the documentation just calls it a */
/*           body ID code. */

	    ccifrm_(&c__2, body, &frcode, fixfrm, &cent, &found, (ftnlen)32);
	    etcal_(et, timstr, (ftnlen)35);
	    s_copy(errmsg, "PCK data required to compute the orientation of "
		    "the # # for epoch # TDB were not found. If these data we"
		    "re to be provided by a binary PCK file, then it is possi"
		    "ble that the PCK file does not have coverage for the spe"
		    "cified body-fixed frame at the time of interest. If the "
		    "data were to be provided by a text PCK file, then possib"
		    "ly the file does not contain data for the specified body"
		    "-fixed frame. In either case it is possible that a requi"
		    "red PCK file was not loaded at all.", (ftnlen)1840, (
		    ftnlen)475);

/*           Fill in the variable data in the error message. */

	    if (found) {

/*              The frame system knows the name of the body-fixed frame. */

		setmsg_(errmsg, (ftnlen)1840);
		errch_("#", "body-fixed frame", (ftnlen)1, (ftnlen)16);
		errch_("#", fixfrm, (ftnlen)1, (ftnlen)32);
		errch_("#", timstr, (ftnlen)1, (ftnlen)35);
	    } else {

/*              The frame system doesn't know the name of the */
/*              body-fixed frame, most likely due to a missing */
/*              frame kernel. */

		suffix_("#", &c__1, errmsg, (ftnlen)1, (ftnlen)1840);
		setmsg_(errmsg, (ftnlen)1840);
		errch_("#", "body-fixed frame associated with the ID code", (
			ftnlen)1, (ftnlen)44);
		errint_("#", body, (ftnlen)1);
		errch_("#", timstr, (ftnlen)1, (ftnlen)35);
		errch_("#", "Also, a frame kernel defining the body-fixed fr"
			"ame associated with body # may need to be loaded.", (
			ftnlen)1, (ftnlen)96);
		errint_("#", body, (ftnlen)1);
	    }
	    sigerr_("SPICE(FRAMEDATANOTFOUND)", (ftnlen)24);
	    chkout_("BODMAT", (ftnlen)6);
	    return 0;
	}

/*        Find the body code used to label the reference frame and epoch */
/*        specifiers for the orientation constants for BODY. */

/*        For planetary systems, the reference frame and epoch for the */
/*        orientation constants is associated with the system */
/*        barycenter, not with individual bodies in the system.  For any */
/*        other bodies, (the Sun or asteroids, for example) the body's */
/*        own code is used as the label. */

	refid = zzbodbry_(body);

/*        Look up the epoch of the constants.  The epoch is specified */
/*        as a Julian ephemeris date.  The epoch defaults to J2000. */

	s_copy(item, "BODY#_CONSTANTS_JED_EPOCH", (ftnlen)32, (ftnlen)25);
	repmi_(item, "#", &refid, item, (ftnlen)32, (ftnlen)1, (ftnlen)32);
	gdpool_(item, &c__1, &c__1, &dim, &conepc, &found, (ftnlen)32);
	if (found) {

/*           The reference epoch is returned as a JED.  Convert to */
/*           ephemeris seconds past J2000.  Then convert the input ET to */
/*           seconds past the reference epoch. */

	    conepc = spd_() * (conepc - j2000_());
	    epoch = *et - conepc;
	} else {
	    epoch = *et;
	}

/*        Look up the reference frame of the constants.  The reference */
/*        frame is specified by a code recognized by CHGIRF.  The */
/*        default frame is J2000, symbolized by the code J2CODE. */

	s_copy(item, "BODY#_CONSTANTS_REF_FRAME", (ftnlen)32, (ftnlen)25);
	repmi_(item, "#", &refid, item, (ftnlen)32, (ftnlen)1, (ftnlen)32);
	gdpool_(item, &c__1, &c__1, &dim, &conref, &found, (ftnlen)32);
	if (found) {
	    ref = i_dnnt(&conref);
	} else {
	    ref = j2code;
	}

/*        Whatever the body, it has quadratic time polynomials for */
/*        the RA and Dec of the pole, and for the rotation of the */
/*        Prime Meridian. */

	s_copy(item, "POLE_RA", (ftnlen)32, (ftnlen)7);
	cleard_(&c__3, rcoef);
	bodvcd_(body, item, &c__3, &na, rcoef, (ftnlen)32);
	s_copy(item, "POLE_DEC", (ftnlen)32, (ftnlen)8);
	cleard_(&c__3, dcoef);
	bodvcd_(body, item, &c__3, &nd, dcoef, (ftnlen)32);
	s_copy(item, "PM", (ftnlen)32, (ftnlen)2);
	cleard_(&c__3, wcoef);
	bodvcd_(body, item, &c__3, &nw, wcoef, (ftnlen)32);

/*        There may be additional nutation and libration (THETA) terms. */

	ntheta = 0;
	na = 0;
	nd = 0;
	nw = 0;
	s_copy(item, "NUT_PREC_ANGLES", (ftnlen)32, (ftnlen)15);
	if (bodfnd_(&refid, item, (ftnlen)32)) {
	    bodvcd_(&refid, item, &c__100, &ntheta, tcoef, (ftnlen)32);
	    ntheta /= 2;
	}
	s_copy(item, "NUT_PREC_RA", (ftnlen)32, (ftnlen)11);
	if (bodfnd_(body, item, (ftnlen)32)) {
	    bodvcd_(body, item, &c__100, &na, ac, (ftnlen)32);
	}
	s_copy(item, "NUT_PREC_DEC", (ftnlen)32, (ftnlen)12);
	if (bodfnd_(body, item, (ftnlen)32)) {
	    bodvcd_(body, item, &c__100, &nd, dc, (ftnlen)32);
	}
	s_copy(item, "NUT_PREC_PM", (ftnlen)32, (ftnlen)11);
	if (bodfnd_(body, item, (ftnlen)32)) {
	    bodvcd_(body, item, &c__100, &nw, wc, (ftnlen)32);
	}
/* Computing MAX */
	i__1 = max(na,nd);
	if (max(i__1,nw) > ntheta) {
	    setmsg_("Insufficient number of nutation/precession angles for b"
		    "ody * at time #.", (ftnlen)71);
	    errint_("*", body, (ftnlen)1);
	    errdp_("#", et, (ftnlen)1);
	    sigerr_("SPICE(KERNELVARNOTFOUND)", (ftnlen)24);
	    chkout_("BODMAT", (ftnlen)6);
	    return 0;
	}

/*        Evaluate the time polynomials at EPOCH. */

	d__ = epoch / spd_();
	t = d__ / 36525.;
	ra = rcoef[0] + t * (rcoef[1] + t * rcoef[2]);
	dec = dcoef[0] + t * (dcoef[1] + t * dcoef[2]);
	w = wcoef[0] + d__ * (wcoef[1] + d__ * wcoef[2]);

/*        Add nutation and libration as appropriate. */

	i__1 = ntheta;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    theta = (tcoef[(i__2 = (i__ << 1) - 2) < 200 && 0 <= i__2 ? i__2 :
		     s_rnge("tcoef", i__2, "bodmat_", (ftnlen)700)] + t * 
		    tcoef[(i__3 = (i__ << 1) - 1) < 200 && 0 <= i__3 ? i__3 : 
		    s_rnge("tcoef", i__3, "bodmat_", (ftnlen)700)]) * rpd_();
	    sinth[(i__2 = i__ - 1) < 100 && 0 <= i__2 ? i__2 : s_rnge("sinth",
		     i__2, "bodmat_", (ftnlen)702)] = sin(theta);
	    costh[(i__2 = i__ - 1) < 100 && 0 <= i__2 ? i__2 : s_rnge("costh",
		     i__2, "bodmat_", (ftnlen)703)] = cos(theta);
	}
	ra += vdotg_(ac, sinth, &na);
	dec += vdotg_(dc, costh, &nd);
	w += vdotg_(wc, sinth, &nw);

/*        Convert from degrees to radians and mod by two pi. */

	ra *= rpd_();
	dec *= rpd_();
	w *= rpd_();
	d__1 = twopi_();
	ra = d_mod(&ra, &d__1);
	d__1 = twopi_();
	dec = d_mod(&dec, &d__1);
	d__1 = twopi_();
	w = d_mod(&w, &d__1);

/*        Convert to Euler angles. */

	phi = ra + halfpi_();
	delta = halfpi_() - dec;

/*        Produce the rotation matrix defined by the Euler angles. */

	eul2m_(&w, &delta, &phi, &c__3, &c__1, &c__3, tipm);
    }

/*     Convert TIPM to the J2000-to-bodyfixed rotation, if is is not */
/*     already referenced to J2000. */

    if (ref != j2code) {

/*        Find the transformation from the J2000 frame to the frame */
/*        designated by REF.  Form the transformation from `REF' */
/*        coordinates to body-fixed coordinates.  Compose the */
/*        transformations to obtain the J2000-to-body-fixed */
/*        transformation. */

	irfrot_(&j2code, &ref, j2ref);
	mxm_(tipm, j2ref, tmpmat);
	moved_(tmpmat, &c__9, tipm);
    }

/*     TIPM now gives the transformation from J2000 to */
/*     body-fixed coordinates at epoch ET seconds past J2000, */
/*     regardless of the epoch and frame of the orientation constants */
/*     for the specified body. */

    chkout_("BODMAT", (ftnlen)6);
    return 0;
} /* bodmat_ */
示例#25
0
/* $Procedure      CKR05 ( Read CK record from segment, type 05 ) */
/* Subroutine */ int ckr05_(integer *handle, doublereal *descr, doublereal *
	sclkdp, doublereal *tol, logical *needav, doublereal *record, logical 
	*found)
{
    /* Initialized data */

    static integer lbeg = -1;
    static integer lend = -1;
    static integer lhand = 0;
    static doublereal prevn = -1.;
    static doublereal prevnn = -1.;
    static doublereal prevs = -1.;

    /* System generated locals */
    integer i__1, i__2;
    doublereal d__1, d__2;

    /* Builtin functions */
    integer i_dnnt(doublereal *), s_rnge(char *, integer, char *, integer);

    /* Local variables */
    integer high;
    doublereal rate;
    integer last, type__, i__, j, n;
    doublereal t;
    integer begin;
    extern /* Subroutine */ int chkin_(char *, ftnlen), dafus_(doublereal *, 
	    integer *, integer *, doublereal *, integer *);
    integer nidir;
    extern doublereal dpmax_(void);
    extern /* Subroutine */ int moved_(doublereal *, integer *, doublereal *);
    integer npdir, nsrch;
    extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen);
    integer lsize, first, nints, rsize;
    doublereal start;
    extern /* Subroutine */ int dafgda_(integer *, integer *, integer *, 
	    doublereal *);
    doublereal dc[2];
    integer ic[6];
    extern logical failed_(void);
    integer bufbas, dirbas;
    doublereal hepoch;
    extern doublereal brcktd_(doublereal *, doublereal *, doublereal *);
    doublereal lepoch;
    integer npread, nsread, remain, pbegix, sbegix, timbas;
    doublereal pbuffr[101];
    extern integer lstled_(doublereal *, integer *, doublereal *);
    doublereal sbuffr[103];
    integer pendix, sendix, packsz;
    extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen);
    integer maxwnd;
    doublereal contrl[5];
    extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *, 
	    integer *, ftnlen);
    extern integer lstltd_(doublereal *, integer *, doublereal *);
    doublereal nstart;
    extern logical return_(void);
    integer pgroup, sgroup, wndsiz, wstart, subtyp;
    doublereal nnstrt;
    extern logical odd_(integer *);
    integer end, low;

/* $ Abstract */

/*     Read a single CK data record from a segment of type 05 */
/*     (MEX/Rosetta Attitude file interpolation). */

/* $ 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 */

/*     CK */

/* $ Keywords */

/*     POINTING */

/* $ Declarations */
/* $ Abstract */

/*     Declare parameters specific to CK type 05. */

/* $ 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 */

/*     CK */

/* $ Keywords */

/*     CK */

/* $ Restrictions */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman      (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 20-AUG-2002 (NJB) */

/* -& */

/*     CK type 5 subtype codes: */


/*     Subtype 0:  Hermite interpolation, 8-element packets. Quaternion */
/*                 and quaternion derivatives only, no angular velocity */
/*                 vector provided. Quaternion elements are listed */
/*                 first, followed by derivatives. Angular velocity is */
/*                 derived from the quaternions and quaternion */
/*                 derivatives. */


/*     Subtype 1:  Lagrange interpolation, 4-element packets. Quaternion */
/*                 only. Angular velocity is derived by differentiating */
/*                 the interpolating polynomials. */


/*     Subtype 2:  Hermite interpolation, 14-element packets. */
/*                 Quaternion and angular angular velocity vector, as */
/*                 well as derivatives of each, are provided. The */
/*                 quaternion comes first, then quaternion derivatives, */
/*                 then angular velocity and its derivatives. */


/*     Subtype 3:  Lagrange interpolation, 7-element packets. Quaternion */
/*                 and angular velocity vector provided.  The quaternion */
/*                 comes first. */


/*     Packet sizes associated with the various subtypes: */


/*     End of file ck05.inc. */

/* $ Abstract */

/*     Declarations of the CK data type specific and general CK low */
/*     level routine parameters. */

/* $ 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 */

/*     CK.REQ */

/* $ Keywords */

/*     CK */

/* $ Restrictions */

/*     1) If new CK types are added, the size of the record passed */
/*        between CKRxx and CKExx must be registered as separate */
/*        parameter. If this size will be greater than current value */
/*        of the CKMRSZ parameter (which specifies the maximum record */
/*        size for the record buffer used inside CKPFS) then it should */
/*        be assigned to CKMRSZ as a new value. */

/* $ Author_and_Institution */

/*     N.J. Bachman      (JPL) */
/*     B.V. Semenov      (JPL) */

/* $ Literature_References */

/*     CK Required Reading. */

/* $ Version */

/* -    SPICELIB Version 2.0.0, 19-AUG-2002 (NJB) */

/*        Updated to support CK type 5. */

/* -    SPICELIB Version 1.0.0, 05-APR-1999 (BVS) */

/* -& */

/*     Number of quaternion components and number of quaternion and */
/*     angular rate components together. */


/*     CK Type 1 parameters: */

/*     CK1DTP   CK data type 1 ID; */

/*     CK1RSZ   maximum size of a record passed between CKR01 */
/*              and CKE01. */


/*     CK Type 2 parameters: */

/*     CK2DTP   CK data type 2 ID; */

/*     CK2RSZ   maximum size of a record passed between CKR02 */
/*              and CKE02. */


/*     CK Type 3 parameters: */

/*     CK3DTP   CK data type 3 ID; */

/*     CK3RSZ   maximum size of a record passed between CKR03 */
/*              and CKE03. */


/*     CK Type 4 parameters: */

/*     CK4DTP   CK data type 4 ID; */

/*     CK4PCD   parameter defining integer to DP packing schema that */
/*              is applied when seven number integer array containing */
/*              polynomial degrees for quaternion and angular rate */
/*              components packed into a single DP number stored in */
/*              actual CK records in a file; the value of must not be */
/*              changed or compatibility with existing type 4 CK files */
/*              will be lost. */

/*     CK4MXD   maximum Chebychev polynomial degree allowed in type 4 */
/*              records; the value of this parameter must never exceed */
/*              value of the CK4PCD; */

/*     CK4SFT   number of additional DPs, which are not polynomial */
/*              coefficients, located at the beginning of a type 4 */
/*              CK record that passed between routines CKR04 and CKE04; */

/*     CK4RSZ   maximum size of type 4 CK record passed between CKR04 */
/*              and CKE04; CK4RSZ is computed as follows: */

/*                 CK4RSZ = ( CK4MXD + 1 ) * QAVSIZ + CK4SFT */


/*     CK Type 5 parameters: */


/*     CK5DTP   CK data type 5 ID; */

/*     CK5MXD   maximum polynomial degree allowed in type 5 */
/*              records. */

/*     CK5MET   number of additional DPs, which are not polynomial */
/*              coefficients, located at the beginning of a type 5 */
/*              CK record that passed between routines CKR05 and CKE05; */

/*     CK5MXP   maximum packet size for any subtype.  Subtype 2 */
/*              has the greatest packet size, since these packets */
/*              contain a quaternion, its derivative, an angular */
/*              velocity vector, and its derivative.  See ck05.inc */
/*              for a description of the subtypes. */

/*     CK5RSZ   maximum size of type 5 CK record passed between CKR05 */
/*              and CKE05; CK5RSZ is computed as follows: */

/*                 CK5RSZ = ( CK5MXD + 1 ) * CK5MXP + CK5MET */



/*     Maximum record size that can be handled by CKPFS. This value */
/*     must be set to the maximum of all CKxRSZ parameters (currently */
/*     CK4RSZ.) */

/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     HANDLE     I   File handle. */
/*     DESCR      I   Segment descriptor. */
/*     SCLKDP     I   Pointing request time. */
/*     TOL        I   Lookup tolerance. */
/*     NEEDAV     I   Angular velocity flag. */
/*     RECORD     O   Data record. */
/*     FOUND      O   Flag indicating whether record was found. */

/* $ Detailed_Input */

/*     HANDLE, */
/*     DESCR       are the file handle and segment descriptor for */
/*                 a CK segment of type 05. */

/*     SCLKDP      is an encoded spacecraft clock time indicating */
/*                 the epoch for which pointing is desired. */

/*     TOL        is a time tolerance, measured in the same units as */
/*                encoded spacecraft clock. */

/*                When SCLKDP falls within the bounds of one of the */
/*                interpolation intervals then the tolerance has no */
/*                effect because pointing will be returned at the */
/*                request time. */

/*                However, if the request time is not in one of the */
/*                intervals, then the tolerance is used to determine */
/*                if pointing at one of the interval endpoints should */
/*                be returned. */

/*     NEEDAV     is true if angular velocity is requested. */

/* $ Detailed_Output */

/*     RECORD      is a set of data from the specified segment which, */
/*                 when evaluated at epoch SCLKDP, will give the */
/*                 attitude and angular velocity of some body, relative */
/*                 to the reference frame indicated by DESCR. */

/*                 The structure of the record is as follows: */

/*                    +----------------------+ */
/*                    | evaluation epoch     | */
/*                    +----------------------+ */
/*                    | subtype code         | */
/*                    +----------------------+ */
/*                    | number of packets (n)| */
/*                    +----------------------+ */
/*                    | nominal SCLK rate    | */
/*                    +----------------------+ */
/*                    | packet 1             | */
/*                    +----------------------+ */
/*                    | packet 2             | */
/*                    +----------------------+ */
/*                                . */
/*                                . */
/*                                . */
/*                    +----------------------+ */
/*                    | packet n             | */
/*                    +----------------------+ */
/*                    | epochs 1--n          | */
/*                    +----------------------+ */

/*                 The packet size is a function of the subtype code. */
/*                 All packets in a record have the same size. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     This routine follows the pattern established in the lower-numbered */
/*     CK data type readers of not explicitly performing error */
/*     diagnoses.  Exceptions are listed below nonetheless. */

/*     1) If the input HANDLE does not designate a loaded CK file, the */
/*        error will be diagnosed by routines called by this routine. */

/*     2) If the segment specified by DESCR is not of data type 05, */
/*        the error 'SPICE(WRONGCKTYPE)' is signaled. */

/*     3) If the input SCLK value is not within the range specified */
/*        in the segment descriptor, the error SPICE(TIMEOUTOFBOUNDS) */
/*        is signaled. */

/*     4) If the window size is non-positive or greater than the */
/*        maximum allowed value, the error SPICE(INVALIDVALUE) is */
/*        signaled. */

/*     5) If the window size is not compatible with the segment */
/*        subtype, the error SPICE(INVALIDVALUE) is signaled. */

/*     6) If the segment subtype is not recognized, the error */
/*        SPICE(NOTSUPPORTED) is signaled. */

/*     7) If the tolerance is negative, the error SPICE(VALUEOUTOFRANGE) */
/*        is signaled. */

/* $ Files */

/*     See argument HANDLE. */

/* $ Particulars */

/*     See the CK Required Reading file for a description of the */
/*     structure of a data type 05 segment. */

/* $ Examples */

/*     The data returned by the CKRnn routine is in its rawest form, */
/*     taken directly from the segment.  As such, it will be meaningless */
/*     to a user unless he/she understands the structure of the data type */
/*     completely.  Given that understanding, however, the CKRxx */
/*     routines might be used to "dump" and check segment data for a */
/*     particular epoch. */


/*     C */
/*     C     Get a segment applicable to a specified body and epoch. */
/*     C */
/*     C     CALL CKBSS ( INST,   SCLKDP, TOL,   NEEDAV ) */
/*           CALL CKSNS ( HANDLE, DESCR,  SEGID, SFND   ) */

/*           IF ( .NOT. SFND ) THEN */
/*              [Handle case of pointing not being found] */
/*           END IF */

/*     C */
/*     C     Look at parts of the descriptor. */
/*     C */
/*           CALL DAFUS ( DESCR, 2, 6, DCD, ICD ) */
/*           CENTER = ICD( 2 ) */
/*           REF    = ICD( 3 ) */
/*           TYPE   = ICD( 4 ) */

/*           IF ( TYPE .EQ. 05 ) THEN */

/*              CALL CKR05 ( HANDLE, DESCR, SCLKDP, TOL, NEEDAV, */
/*          .                RECORD, FOUND                       ) */

/*              IF ( .NOT. FOUND ) THEN */
/*                 [Handle case of pointing not being found] */
/*              END IF */

/*              [Look at the RECORD data] */
/*                  . */
/*                  . */
/*                  . */
/*           END IF */

/* $ Restrictions */

/*     1)  Correctness of inputs must be ensured by the caller of */
/*         this routine. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman    (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.1.0, 06-SEP-2002 (NJB) */

/* -& */
/* $ Index_Entries */

/*     read record from type_5 ck segment */

/* -& */
/* $ Revisions */

/* -& */

/*     SPICELIB functions */


/*     Local parameters */


/*     Maximum polynomial degree: */


/*     Local variables */


/*     Saved variables */


/*     Initial values */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    }
    chkin_("CKR05", (ftnlen)5);

/*     No pointing found so far. */

    *found = FALSE_;

/*     Unpack the segment descriptor, and get the start and end addresses */
/*     of the segment. */

    dafus_(descr, &c__2, &c__6, dc, ic);
    type__ = ic[2];
    begin = ic[4];
    end = ic[5];

/*     Make sure that this really is a type 05 data segment. */

    if (type__ != 5) {
	setmsg_("You are attempting to locate type * data in a type 5 data s"
		"egment.", (ftnlen)66);
	errint_("*", &type__, (ftnlen)1);
	sigerr_("SPICE(WRONGCKTYPE)", (ftnlen)18);
	chkout_("CKR05", (ftnlen)5);
	return 0;
    }

/*     Check the tolerance value. */

    if (*tol < 0.) {
	setmsg_("Tolerance must be non-negative but was actually *.", (ftnlen)
		50);
	errdp_("*", tol, (ftnlen)1);
	sigerr_("SPICE(VALUEOUTOFRANGE)", (ftnlen)22);
	chkout_("CKR05", (ftnlen)5);
	return 0;
    }

/*     Check the request time and tolerance against the bounds in */
/*     the segment descriptor. */

    if (*sclkdp + *tol < dc[0] || *sclkdp - *tol > dc[1]) {

/*        The request time is too far outside the segment's coverage */
/*        interval for any pointing to satisfy the request. */

	chkout_("CKR05", (ftnlen)5);
	return 0;
    }

/*     Set the request time to use for searching. */

    t = brcktd_(sclkdp, dc, &dc[1]);

/*     From this point onward, we assume the segment was constructed */
/*     correctly.  In particular, we assume: */

/*        1)  The segment descriptor's time bounds are in order and are */
/*            distinct. */

/*        2)  The epochs in the segment are in strictly increasing */
/*            order. */


/*        3)  The interpolation interval start times in the segment are */
/*            in strictly increasing order. */


/*        4)  The degree of the interpolating polynomial specified by */
/*            the segment is at least 1 and is no larger than MAXDEG. */


    i__1 = end - 4;
    dafgda_(handle, &i__1, &end, contrl);

/*     Check the FAILED flag just in case HANDLE is not attached to */
/*     any DAF file and the error action is not set to ABORT.  We */
/*     do this only after the first call to DAFGDA, as in CKR03. */

    if (failed_()) {
	chkout_("CKR05", (ftnlen)5);
	return 0;
    }
    rate = contrl[0];
    subtyp = i_dnnt(&contrl[1]);
    wndsiz = i_dnnt(&contrl[2]);
    nints = i_dnnt(&contrl[3]);
    n = i_dnnt(&contrl[4]);

/*     Set the packet size, which is a function of the subtype. */

    if (subtyp == 0) {
	packsz = 8;
    } else if (subtyp == 1) {
	packsz = 4;
    } else if (subtyp == 2) {
	packsz = 14;
    } else if (subtyp == 3) {
	packsz = 7;
    } else {
	setmsg_("Unexpected CK type 5 subtype # found in type 5 segment.", (
		ftnlen)55);
	errint_("#", &subtyp, (ftnlen)1);
	sigerr_("SPICE(NOTSUPPORTED)", (ftnlen)19);
	chkout_("CKR05", (ftnlen)5);
	return 0;
    }

/*     Check the window size. */

    if (wndsiz <= 0) {
	setmsg_("Window size in type 05 segment was #; must be positive.", (
		ftnlen)55);
	errint_("#", &wndsiz, (ftnlen)1);
	sigerr_("SPICE(INVALIDVALUE)", (ftnlen)19);
	chkout_("CKR05", (ftnlen)5);
	return 0;
    }
    if (subtyp == 0 || subtyp == 2) {

/*        These are the Hermite subtypes. */

	maxwnd = 8;
	if (wndsiz > maxwnd) {
	    setmsg_("Window size in type 05 segment was #; max allowed value"
		    " is # for subtypes 0 and 2 (Hermite, 8 or 14-element pac"
		    "kets).", (ftnlen)117);
	    errint_("#", &wndsiz, (ftnlen)1);
	    errint_("#", &maxwnd, (ftnlen)1);
	    sigerr_("SPICE(INVALIDVALUE)", (ftnlen)19);
	    chkout_("CKR05", (ftnlen)5);
	    return 0;
	}
	if (odd_(&wndsiz)) {
	    setmsg_("Window size in type 05 segment was #; must be even for "
		    "subtypes 0 and 2 (Hermite, 8 or 14-element packets).", (
		    ftnlen)107);
	    errint_("#", &wndsiz, (ftnlen)1);
	    sigerr_("SPICE(INVALIDVALUE)", (ftnlen)19);
	    chkout_("CKR05", (ftnlen)5);
	    return 0;
	}
    } else if (subtyp == 1 || subtyp == 3) {

/*        These are the Lagrange subtypes. */

	maxwnd = 16;
	if (wndsiz > maxwnd) {
	    setmsg_("Window size in type 05 segment was #; max allowed value"
		    " is # for subtypes 1 and 3 (Lagrange, 4 or 7-element pac"
		    "kets).", (ftnlen)117);
	    errint_("#", &wndsiz, (ftnlen)1);
	    errint_("#", &maxwnd, (ftnlen)1);
	    sigerr_("SPICE(INVALIDVALUE)", (ftnlen)19);
	    chkout_("CKR05", (ftnlen)5);
	    return 0;
	}
	if (odd_(&wndsiz)) {
	    setmsg_("Window size in type 05 segment was #; must be even for "
		    "subtypes 1 and 3 (Lagrange, 4 or 7-element packets).", (
		    ftnlen)107);
	    errint_("#", &wndsiz, (ftnlen)1);
	    sigerr_("SPICE(INVALIDVALUE)", (ftnlen)19);
	    chkout_("CKR05", (ftnlen)5);
	    return 0;
	}
    } else {
	setmsg_("This point should not be reached. Getting here may indicate"
		" that the code needs to updated to handle the new subtype #", 
		(ftnlen)118);
	errint_("#", &subtyp, (ftnlen)1);
	sigerr_("SPICE(NOTSUPPORTED)", (ftnlen)19);
	chkout_("CKR05", (ftnlen)5);
	return 0;
    }

/*     We now need to select the pointing values to interpolate */
/*     in order to satisfy the pointing request.  The first step */
/*     is to use the pointing directories (if any) to locate a set of */
/*     epochs bracketing the request time.  Note that the request */
/*     time might not be bracketed:  it could precede the first */
/*     epoch or follow the last epoch. */

/*     We'll use the variable PGROUP to refer to the set of epochs */
/*     to search.  The first group consists of the epochs prior to */
/*     and including the first pointing directory entry.  The last */
/*     group consists of the epochs following the last pointing */
/*     directory entry.  Other groups consist of epochs following */
/*     one pointing directory entry up to and including the next */
/*     pointing directory entry. */

    npdir = (n - 1) / 100;
    dirbas = begin + n * packsz + n - 1;
    if (npdir == 0) {

/*        There's no mystery about which group of epochs to search. */

	pgroup = 1;
    } else {

/*        There's at least one directory.  Find the first directory */
/*        whose time is greater than or equal to the request time, if */
/*        there is such a directory.  We'll search linearly through the */
/*        directory entries, reading up to DIRSIZ of them at a time. */
/*        Having found the correct set of directory entries, we'll */
/*        perform a binary search within that set for the desired entry. */

	bufbas = dirbas;
	npread = min(npdir,100);
	i__1 = bufbas + 1;
	i__2 = bufbas + npread;
	dafgda_(handle, &i__1, &i__2, pbuffr);
	remain = npdir - npread;
	while(pbuffr[(i__1 = npread - 1) < 101 && 0 <= i__1 ? i__1 : s_rnge(
		"pbuffr", i__1, "ckr05_", (ftnlen)633)] < t && remain > 0) {
	    bufbas += npread;
	    npread = min(remain,100);

/*           Note:  NPREAD is always > 0 here. */

	    i__1 = bufbas + 1;
	    i__2 = bufbas + npread;
	    dafgda_(handle, &i__1, &i__2, pbuffr);
	    remain -= npread;
	}

/*        At this point, BUFBAS - DIRBAS is the number of directory */
/*        entries preceding the one contained in PBUFFR(1). */

/*        PGROUP is one more than the number of directories we've */
/*        passed by. */

	pgroup = bufbas - dirbas + lstltd_(&t, &npread, pbuffr) + 1;
    }

/*     PGROUP now indicates the set of epochs in which to search for the */
/*     request epoch.  The following cases can occur: */

/*        PGROUP = 1 */
/*        ========== */

/*           NPDIR = 0 */
/*           -------- */
/*           The request time may precede the first time tag */
/*           of the segment, exceed the last time tag, or lie */
/*           in the closed interval bounded by these time tags. */

/*           NPDIR >= 1 */
/*           --------- */
/*           The request time may precede the first time tag */
/*           of the group but does not exceed the last epoch */
/*           of the group. */


/*        1 < PGROUP <= NPDIR */
/*        =================== */

/*           The request time follows the last time of the */
/*           previous group and is less than or equal to */
/*           the pointing directory entry at index PGROUP. */

/*        1 < PGROUP = NPDIR + 1 */
/*        ====================== */

/*           The request time follows the last time of the */
/*           last pointing directory entry.  The request time */
/*           may exceed the last time tag. */


/*     Now we'll look up the time tags in the group of epochs */
/*     we've identified. */

/*     We'll use the variable names PBEGIX and PENDIX to refer to */
/*     the indices, relative to the set of time tags, of the first */
/*     and last time tags in the set we're going to look up. */

    if (pgroup == 1) {
	pbegix = 1;
	pendix = min(n,100);
    } else {

/*        If the group index is greater than 1, we'll include the last */
/*        time tag of the previous group in the set of time tags we look */
/*        up.  That way, the request time is strictly bracketed on the */
/*        low side by the time tag set we look up. */

	pbegix = (pgroup - 1) * 100;
/* Computing MIN */
	i__1 = pbegix + 100;
	pendix = min(i__1,n);
    }
    timbas = dirbas - n;
    i__1 = timbas + pbegix;
    i__2 = timbas + pendix;
    dafgda_(handle, &i__1, &i__2, pbuffr);
    npread = pendix - pbegix + 1;

/*     At this point, we'll deal with the cases where T lies outside */
/*     of the range of epochs we've buffered. */

    if (t < pbuffr[0]) {

/*        This can happen only if PGROUP = 1 and T precedes all epochs. */
/*        If the input request time is too far from PBUFFR(1) on */
/*        the low side, we're done. */

	if (*sclkdp + *tol < pbuffr[0]) {
	    chkout_("CKR05", (ftnlen)5);
	    return 0;
	}

/*        Bracket T to move it within the range of buffered epochs. */

	t = pbuffr[0];
    } else if (t > pbuffr[(i__1 = npread - 1) < 101 && 0 <= i__1 ? i__1 : 
	    s_rnge("pbuffr", i__1, "ckr05_", (ftnlen)748)]) {

/*        This can happen only if T follows all epochs. */

	if (*sclkdp - *tol > pbuffr[(i__1 = npread - 1) < 101 && 0 <= i__1 ? 
		i__1 : s_rnge("pbuffr", i__1, "ckr05_", (ftnlen)752)]) {
	    chkout_("CKR05", (ftnlen)5);
	    return 0;
	}

/*        Bracket T to move it within the range of buffered epochs. */

	t = pbuffr[(i__1 = npread - 1) < 101 && 0 <= i__1 ? i__1 : s_rnge(
		"pbuffr", i__1, "ckr05_", (ftnlen)762)];
    }

/*     At this point, */

/*        | T - SCLKDP |  <=  TOL */

/*     Also, one of the following is true: */

/*        T is the first time of the segment */

/*        T is the last time of the segment */

/*        T equals SCLKDP */



/*     Find two adjacent time tags bounding the request epoch.  The */
/*     request time cannot be greater than all of time tags in the */
/*     group, and it cannot precede the first element of the group. */

    i__ = lstltd_(&t, &npread, pbuffr);

/*     The variables LOW and HIGH are the indices of a pair of time */
/*     tags that bracket the request time.  Remember that NPREAD could */
/*     be equal to 1, in which case we would have LOW = HIGH. */

    if (i__ == 0) {

/*        This can happen only if PGROUP = 1 and T = PBUFFR(1). */

	low = 1;
	lepoch = pbuffr[0];
	if (n == 1) {
	    high = 1;
	} else {
	    high = 2;
	}
	hepoch = pbuffr[(i__1 = high - 1) < 101 && 0 <= i__1 ? i__1 : s_rnge(
		"pbuffr", i__1, "ckr05_", (ftnlen)805)];
    } else {
	low = pbegix + i__ - 1;
	lepoch = pbuffr[(i__1 = i__ - 1) < 101 && 0 <= i__1 ? i__1 : s_rnge(
		"pbuffr", i__1, "ckr05_", (ftnlen)810)];
	high = low + 1;
	hepoch = pbuffr[(i__1 = i__) < 101 && 0 <= i__1 ? i__1 : s_rnge("pbu"
		"ffr", i__1, "ckr05_", (ftnlen)813)];
    }

/*     We now need to find the interpolation interval containing */
/*     T, if any.  We may be able to use the interpolation */
/*     interval found on the previous call to this routine.  If */
/*     this is the first call or if the previous interval is not */
/*     applicable, we'll search for the interval. */

/*     First check if the request time falls in the same interval as */
/*     it did last time.  We need to make sure that we are dealing */
/*     with the same segment as well as the same time range. */


/*        PREVS      is the start time of the interval that satisfied */
/*                   the previous request for pointing. */

/*        PREVN      is the start time of the interval that followed */
/*                   the interval specified above. */

/*        PREVNN     is the start time of the interval that followed */
/*                   the interval starting at PREVN. */

/*        LHAND      is the handle of the file that PREVS and PREVN */
/*                   were found in. */

/*        LBEG,      are the beginning and ending addresses of the */
/*        LEND       segment in the file LHAND that PREVS and PREVN */
/*                   were found in. */

    if (*handle == lhand && begin == lbeg && end == lend && t >= prevs && t < 
	    prevn) {
	start = prevs;
	nstart = prevn;
	nnstrt = prevnn;
    } else {

/*        Search for the interpolation interval. */

	nidir = (nints - 1) / 100;
	dirbas = end - 5 - nidir;
	if (nidir == 0) {

/*           There's no mystery about which group of epochs to search. */

	    sgroup = 1;
	} else {

/*           There's at least one directory.  Find the first directory */
/*           whose time is greater than or equal to the request time, if */
/*           there is such a directory.  We'll search linearly through */
/*           the directory entries, reading up to DIRSIZ of them at a */
/*           time. Having found the correct set of directory entries, */
/*           we'll perform a binary search within that set for the */
/*           desired entry. */

	    bufbas = dirbas;
	    nsread = min(nidir,100);
	    remain = nidir - nsread;
	    i__1 = bufbas + 1;
	    i__2 = bufbas + nsread;
	    dafgda_(handle, &i__1, &i__2, sbuffr);
	    while(sbuffr[(i__1 = nsread - 1) < 103 && 0 <= i__1 ? i__1 : 
		    s_rnge("sbuffr", i__1, "ckr05_", (ftnlen)885)] < t && 
		    remain > 0) {
		bufbas += nsread;
		nsread = min(remain,100);
		remain -= nsread;

/*              Note:  NSREAD is always > 0 here. */

		i__1 = bufbas + 1;
		i__2 = bufbas + nsread;
		dafgda_(handle, &i__1, &i__2, sbuffr);
	    }

/*           At this point, BUFBAS - DIRBAS is the number of directory */
/*           entries preceding the one contained in SBUFFR(1). */

/*           SGROUP is one more than the number of directories we've */
/*           passed by. */

	    sgroup = bufbas - dirbas + lstltd_(&t, &nsread, sbuffr) + 1;
	}

/*        SGROUP now indicates the set of interval start times in which */
/*        to search for the request epoch. */

/*        Now we'll look up the time tags in the group of epochs we've */
/*        identified. */

/*        We'll use the variable names SBEGIX and SENDIX to refer to the */
/*        indices, relative to the set of start times, of the first and */
/*        last start times in the set we're going to look up. */

	if (sgroup == 1) {
	    sbegix = 1;
	    sendix = min(nints,102);
	} else {

/*           Look up the start times for the group of interest. Also */
/*           buffer last start time from the previous group. Also, it */
/*           turns out to be useful to pick up two extra start */
/*           times---the first two start times of the next group---if */
/*           they exist. */

	    sbegix = (sgroup - 1) * 100;
/* Computing MIN */
	    i__1 = sbegix + 102;
	    sendix = min(i__1,nints);
	}
	timbas = dirbas - nints;
	i__1 = timbas + sbegix;
	i__2 = timbas + sendix;
	dafgda_(handle, &i__1, &i__2, sbuffr);
	nsread = sendix - sbegix + 1;

/*        Find the last interval start time less than or equal to the */
/*        request time.  We know T is greater than or equal to the */
/*        first start time, so I will be > 0. */

	nsrch = min(101,nsread);
	i__ = lstled_(&t, &nsrch, sbuffr);
	start = sbuffr[(i__1 = i__ - 1) < 103 && 0 <= i__1 ? i__1 : s_rnge(
		"sbuffr", i__1, "ckr05_", (ftnlen)956)];

/*        Let NSTART ("next start") be the start time that follows */
/*        START, if START is not the last start time.  If NSTART */
/*        has a successor, let NNSTRT be that start time. */

	if (i__ < nsread) {
	    nstart = sbuffr[(i__1 = i__) < 103 && 0 <= i__1 ? i__1 : s_rnge(
		    "sbuffr", i__1, "ckr05_", (ftnlen)965)];
	    if (i__ + 1 < nsread) {
		nnstrt = sbuffr[(i__1 = i__ + 1) < 103 && 0 <= i__1 ? i__1 : 
			s_rnge("sbuffr", i__1, "ckr05_", (ftnlen)969)];
	    } else {
		nnstrt = dpmax_();
	    }
	} else {
	    nstart = dpmax_();
	    nnstrt = dpmax_();
	}
    }

/*     If T does not lie within the interpolation interval starting */
/*     at time START, we'll determine whether T is closer to this */
/*     interval or the next.  If the distance between T and the */
/*     closer interval is less than or equal to TOL, we'll map T */
/*     to the closer endpoint of the closer interval.  Otherwise, */
/*     we return without finding pointing. */

    if (hepoch == nstart) {

/*        The first time tag greater than or equal to T is the start */
/*        time of the next interpolation interval. */

/*        The request time lies between interpolation intervals. */
/*        LEPOCH is the last time tag of the first interval; HEPOCH */
/*        is the first time tag of the next interval. */

	if ((d__1 = t - lepoch, abs(d__1)) <= (d__2 = hepoch - t, abs(d__2))) 
		{

/*           T is closer to the first interval... */

	    if ((d__1 = t - lepoch, abs(d__1)) > *tol) {

/*              ...But T is too far from the interval. */

		chkout_("CKR05", (ftnlen)5);
		return 0;
	    }

/*           Map T to the right endpoint of the preceding interval. */

	    t = lepoch;
	    high = low;
	    hepoch = lepoch;
	} else {

/*           T is closer to the second interval... */

	    if ((d__1 = hepoch - t, abs(d__1)) > *tol) {

/*              ...But T is too far from the interval. */

		chkout_("CKR05", (ftnlen)5);
		return 0;
	    }

/*           Map T to the left endpoint of the next interval. */

	    t = hepoch;
	    low = high;
	    lepoch = hepoch;

/*           Since we're going to be picking time tags from the next */
/*           interval, we'll need to adjust START and NSTART. */

	    start = nstart;
	    nstart = nnstrt;
	}
    }

/*     We now have */

/*        LEPOCH < T <  HEPOCH */
/*                -   - */

/*     where LEPOCH and HEPOCH are the time tags at indices */
/*     LOW and HIGH, respectively. */

/*     Now select the set of packets used for interpolation.  Note */
/*     that the window size is known to be even. */

/*     Unlike CK types 8, 9, 12, and 13, for type 05 we adjust */
/*     the window size to keep the request time within the central */
/*     interval of the window. */

/*     The nominal bracketing epochs we've found are the (WNDSIZ/2)nd */
/*     and (WNDSIZ/2 + 1)st of the interpolating set.  If the request */
/*     time is too close to one end of the interpolation interval, we */
/*     reduce the window size, after which one endpoint of the window */
/*     will coincide with an endpoint of the interpolation interval. */

/*     We start out by looking up the set of time tags we'd use */
/*     if there were no gaps in the coverage.  We then trim our */
/*     time tag set to ensure all tags are in the interpolation */
/*     interval.  It's possible that the interpolation window will */
/*     collapse to a single point as a result of this last step. */

/*     Let LSIZE be the size of the "left half" of the window:  the */
/*     size of the set of window epochs to the left of the request time. */
/*     We want this size to be WNDSIZ/2, but if not enough states are */
/*     available, the set ranges from index 1 to index LOW. */

/* Computing MIN */
    i__1 = wndsiz / 2;
    lsize = min(i__1,low);

/*     RSIZE is defined analogously for the right half of the window. */

/* Computing MIN */
    i__1 = wndsiz / 2, i__2 = n - high + 1;
    rsize = min(i__1,i__2);

/*     The window size is simply the sum of LSIZE and RSIZE. */

    wndsiz = lsize + rsize;

/*     FIRST and LAST are the endpoints of the range of indices of */
/*     time tags (and packets) we'll collect in the output record. */

    first = low - lsize + 1;
    last = first + wndsiz - 1;

/*     Buffer the epochs. */

    wstart = begin + n * packsz + first - 1;
    i__1 = wstart + wndsiz - 1;
    dafgda_(handle, &wstart, &i__1, pbuffr);

/*     Discard any epochs less than START or greater than or equal */
/*     to NSTART.  The set of epochs we want ranges from indices */
/*     I+1 to J.  This range is non-empty unless START and NSTART */
/*     are both DPMAX(). */

    i__ = lstltd_(&start, &wndsiz, pbuffr);
    j = lstltd_(&nstart, &wndsiz, pbuffr);
    if (i__ == j) {

/*        Fuggedaboudit. */

	chkout_("CKR05", (ftnlen)5);
	return 0;
    }

/*     Update FIRST, LAST, and WNDSIZ. */

    wndsiz = j - i__;
    first += i__;
    last = first + wndsiz - 1;

/*     Put the subtype into the output record.  The size of the group */
/*     of packets is derived from the subtype, so we need not include */
/*     the size. */

    record[0] = t;
    record[1] = (doublereal) subtyp;
    record[2] = (doublereal) wndsiz;
    record[3] = rate;

/*     Read the packets. */

    i__1 = begin + (first - 1) * packsz;
    i__2 = begin + last * packsz - 1;
    dafgda_(handle, &i__1, &i__2, &record[4]);

/*     Finally, add the epochs to the output record. */

    i__2 = j - i__;
    moved_(&pbuffr[(i__1 = i__) < 101 && 0 <= i__1 ? i__1 : s_rnge("pbuffr", 
	    i__1, "ckr05_", (ftnlen)1158)], &i__2, &record[wndsiz * packsz + 
	    4]);

/*     Save the information about the interval and segment. */

    lhand = *handle;
    lbeg = begin;
    lend = end;
    prevs = start;
    prevn = nstart;
    prevnn = nnstrt;

/*     Indicate pointing was found. */

    *found = TRUE_;
    chkout_("CKR05", (ftnlen)5);
    return 0;
} /* ckr05_ */
示例#26
0
int
dlacon_(int *n, double *v, double *x, int *isgn, double *est, int *kase)

{
/*
    Purpose   
    =======   

    DLACON estimates the 1-norm of a square matrix A.   
    Reverse communication is used for evaluating matrix-vector products. 
  

    Arguments   
    =========   

    N      (input) INT
           The order of the matrix.  N >= 1.   

    V      (workspace) DOUBLE PRECISION array, dimension (N)   
           On the final return, V = A*W,  where  EST = norm(V)/norm(W)   
           (W is not returned).   

    X      (input/output) DOUBLE PRECISION array, dimension (N)   
           On an intermediate return, X should be overwritten by   
                 A * X,   if KASE=1,   
                 A' * X,  if KASE=2,
           and DLACON must be re-called with all the other parameters   
           unchanged.   

    ISGN   (workspace) INT array, dimension (N)

    EST    (output) DOUBLE PRECISION   
           An estimate (a lower bound) for norm(A).   

    KASE   (input/output) INT
           On the initial call to DLACON, KASE should be 0.   
           On an intermediate return, KASE will be 1 or 2, indicating   
           whether X should be overwritten by A * X  or A' * X.   
           On the final return from DLACON, KASE will again be 0.   

    Further Details   
    ======= =======   

    Contributed by Nick Higham, University of Manchester.   
    Originally named CONEST, dated March 16, 1988.   

    Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of 
    a real or complex matrix, with applications to condition estimation", 
    ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.   
    ===================================================================== 
*/

    /* Table of constant values */
    int c__1 = 1;
    double      zero = 0.0;
    double      one = 1.0;
    
    /* Local variables */
    static int iter;
    static int jump, jlast;
    static double altsgn, estold;
    static int i, j;
    double temp;
    extern int idamax_(int *, double *, int *);
    extern double dasum_(int *, double *, int *);
    extern int dcopy_(int *, double *, int *, double *, int *);
#define d_sign(a, b) (b >= 0 ? fabs(a) : -fabs(a))    /* Copy sign */
#define i_dnnt(a) \
	( a>=0 ? floor(a+.5) : -floor(.5-a) ) /* Round to nearest integer */

    if ( *kase == 0 ) {
	for (i = 0; i < *n; ++i) {
	    x[i] = 1. / (double) (*n);
	}
	*kase = 1;
	jump = 1;
	return 0;
    }

    switch (jump) {
	case 1:  goto L20;
	case 2:  goto L40;
	case 3:  goto L70;
	case 4:  goto L110;
	case 5:  goto L140;
    }

    /*     ................ ENTRY   (JUMP = 1)   
	   FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY A*X. */
  L20:
    if (*n == 1) {
	v[0] = x[0];
	*est = fabs(v[0]);
	/*        ... QUIT */
	goto L150;
    }
    *est = dasum_(n, x, &c__1);

    for (i = 0; i < *n; ++i) {
	x[i] = d_sign(one, x[i]);
	isgn[i] = i_dnnt(x[i]);
    }
    *kase = 2;
    jump = 2;
    return 0;

    /*     ................ ENTRY   (JUMP = 2)   
	   FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
L40:
    j = idamax_(n, &x[0], &c__1);
    --j;
    iter = 2;

    /*     MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
L50:
    for (i = 0; i < *n; ++i) x[i] = zero;
    x[j] = one;
    *kase = 1;
    jump = 3;
    return 0;

    /*     ................ ENTRY   (JUMP = 3)   
	   X HAS BEEN OVERWRITTEN BY A*X. */
L70:
    dcopy_(n, &x[0], &c__1, &v[0], &c__1);
    estold = *est;
    *est = dasum_(n, v, &c__1);

    for (i = 0; i < *n; ++i)
	if (i_dnnt(d_sign(one, x[i])) != isgn[i])
	    goto L90;

    /*     REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
    goto L120;

L90:
    /*     TEST FOR CYCLING. */
    if (*est <= estold) goto L120;

    for (i = 0; i < *n; ++i) {
	x[i] = d_sign(one, x[i]);
	isgn[i] = i_dnnt(x[i]);
    }
    *kase = 2;
    jump = 4;
    return 0;

    /*     ................ ENTRY   (JUMP = 4)   
	   X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. */
L110:
    jlast = j;
    j = idamax_(n, &x[0], &c__1);
    --j;
    if (x[jlast] != fabs(x[j]) && iter < 5) {
	++iter;
	goto L50;
    }

    /*     ITERATION COMPLETE.  FINAL STAGE. */
L120:
    altsgn = 1.;
    for (i = 1; i <= *n; ++i) {
	x[i-1] = altsgn * ((double) (i - 1) / (double) (*n - 1) + 1.);
	altsgn = -altsgn;
    }
    *kase = 1;
    jump = 5;
    return 0;
    
    /*     ................ ENTRY   (JUMP = 5)   
	   X HAS BEEN OVERWRITTEN BY A*X. */
L140:
    temp = dasum_(n, x, &c__1) / (double) (*n * 3) * 2.;
    if (temp > *est) {
	dcopy_(n, &x[0], &c__1, &v[0], &c__1);
	*est = temp;
    }

L150:
    *kase = 0;
    return 0;

} /* dlacon_ */
示例#27
0
/* $Procedure      ZZEKGLNK ( EK, get link count for data page ) */
/* Subroutine */ int zzekglnk_(integer *handle, integer *type__, integer *p, 
	integer *nlinks)
{
    /* System generated locals */
    integer i__1, i__2;

    /* Builtin functions */
    integer i_dnnt(doublereal *);

    /* Local variables */
    integer base;
    extern /* Subroutine */ int zzekpgbs_(integer *, integer *, integer *);
    doublereal dplnk;
    extern logical failed_(void);
    extern /* Subroutine */ int dasrdd_(integer *, integer *, integer *, 
	    doublereal *), dasrdi_(integer *, integer *, integer *, integer *)
	    , zzekgei_(integer *, integer *, integer *);

/* $ Abstract */

/*     Return the link count for a specified EK data page. */

/* $ 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 */

/*     EK */

/* $ Keywords */

/*     EK */
/*     PRIVATE */

/* $ Declarations */
/* $ 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. */


/*     Include Section:  EK Data Page Parameters */

/*        ekfilpar.inc  Version 1  03-APR-1995 (NJB) */

/*     These parameters apply to EK files using architecture 4. */
/*     These files use a paged DAS file as their underlying file */
/*     structure. */

/*     In paged DAS EK files, data pages are structured:  they contain */
/*     metadata as well as data.  The metadata is located in the last */
/*     few addresses of each page, so as to interfere as little as */
/*     possible with calculation of data addresses. */

/*     Each data page belongs to exactly one segment.  Some bookkeeping */
/*     information, such as record pointers, is also stored in data */
/*     pages. */

/*     Each page contains a forward pointer that allows rapid lookup */
/*     of data items that span multiple pages.  Each page also keeps */
/*     track of the current number of links from its parent segment */
/*     to the page.  Link counts enable pages to `know' when they */
/*     are no longer in use by a segment; unused pages are deallocated */
/*     and returned to the free list. */

/*     The parameters in this include file depend on the parameters */
/*     declared in the include file ekpage.inc.  If those parameters */
/*     change, this file must be updated.  The specified parameter */
/*     declarations we need from that file are: */

/*        INTEGER               PGSIZC */
/*        PARAMETER           ( PGSIZC = 1024 ) */

/*        INTEGER               PGSIZD */
/*        PARAMETER           ( PGSIZD = 128 ) */

/*        INTEGER               PGSIZI */
/*        PARAMETER           ( PGSIZI = 256 ) */



/*     Character pages use an encoding mechanism to represent integer */
/*     metadata.  Each integer is encoded in five consecutive */
/*     characters. */


/*     Character data page parameters: */


/*     Size of encoded integer: */


/*     Usable page size: */


/*     Location of character forward pointer: */


/*     Location of character link count: */


/*     Double precision data page parameters: */

/*     Usable page size: */


/*     Location of d.p. forward pointer: */


/*     Location of d.p. link count: */


/*     Integer data page parameters: */

/*     Usable page size: */


/*     Location of integer forward pointer: */


/*     Location of integer link count: */


/*     End Include Section:  EK Data Page Parameters */

/* $ 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. */


/*     Include Section:  EK Segment Descriptor Parameters */

/*        eksegdsc.inc  Version 8  06-NOV-1995 (NJB) */


/*     All `base addresses' referred to below are the addresses */
/*     *preceding* the item the base applies to.  This convention */
/*     enables simplied address calculations in many cases. */

/*     Size of segment descriptor.  Note:  the include file ekcoldsc.inc */
/*     must be updated if this parameter is changed.  The parameter */
/*     CDOFF in that file should be kept equal to SDSCSZ. */


/*     Index of the segment type code: */


/*     Index of the segment's number.  This number is the segment's */
/*     index in the list of segments contained in the EK to which */
/*     the segment belongs. */


/*     Index of the DAS integer base address of the segment's integer */
/*     meta-data: */


/*     Index of the DAS character base address of the table name: */


/*     Index of the segment's column count: */


/*     Index of the segment's record count: */


/*     Index of the root page number of the record tree: */


/*     Index of the root page number of the character data page tree: */


/*     Index of the root page number of the double precision data page */
/*     tree: */


/*     Index of the root page number of the integer data page tree: */


/*     Index of the `modified' flag: */


/*     Index of the `initialized' flag: */


/*     Index of the shadowing flag: */


/*     Index of the companion file handle: */


/*     Index of the companion segment number: */


/*     The next three items are, respectively, the page numbers of the */
/*     last character, d.p., and integer data pages allocated by the */
/*     segment: */


/*     The next three items are, respectively, the page-relative */
/*     indices of the last DAS word in use in the segment's */
/*     last character, d.p., and integer data pages: */


/*     Index of the DAS character base address of the column name list: */


/*     The last descriptor element is reserved for future use.  No */
/*     parameter is defined to point to this location. */


/*     End Include Section:  EK Segment Descriptor Parameters */

/* $ 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. */


/*     Include Section:  EK Data Types */

/*        ektype.inc Version 1  27-DEC-1994 (NJB) */


/*     Within the EK system, data types of EK column contents are */
/*     represented by integer codes.  The codes and their meanings */
/*     are listed below. */

/*     Integer codes are also used within the DAS system to indicate */
/*     data types; the EK system makes no assumptions about compatibility */
/*     between the codes used here and those used in the DAS system. */


/*     Character type: */


/*     Double precision type: */


/*     Integer type: */


/*     `Time' type: */

/*     Within the EK system, time values are represented as ephemeris */
/*     seconds past J2000 (TDB), and double precision numbers are used */
/*     to store these values.  However, since time values require special */
/*     treatment both on input and output, and since the `TIME' column */
/*     has a special role in the EK specification and code, time values */
/*     are identified as a type distinct from double precision numbers. */


/*     End Include Section:  EK Data Types */

/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     HANDLE     I   File handle. */
/*     TYPE       I   Data type of page. */
/*     P          I   Page number. */
/*     NLINKS     O   Number of links to page. */

/* $ Detailed_Input */

/*     HANDLE         is a file handle of an EK open for write access. */

/*     TYPE           is the data type of the desired page. */

/*     P              is the page number of the allocated page.  This */
/*                    number is recognized by the EK paged access */
/*                    routines. */

/* $ Detailed_Output */

/*     NLINKS         is the currently held number of links to the */
/*                    specified data page. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     1)  If HANDLE is invalid, the error will be diagnosed by routines */
/*         called by this routine. */

/*     2)  If TYPE is invalid, the error will be diagnosed by routines */
/*         called by this routine. */

/*     3)  If an I/O error occurs while reading or writing the indicated */
/*         file, the error will be diagnosed by routines called by this */
/*         routine. */

/* $ Files */

/*     See the EK Required Reading for a discussion of the EK file */
/*     format. */

/* $ Particulars */

/*     This routine centralizes EK data page link count accesses. */

/* $ Examples */

/*     See EKDELR. */

/* $ Restrictions */

/*     None. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman   (JPL) */

/* $ Version */

/* -    Beta Version 1.0.0, 10-OCT-1995 (NJB) */

/* -& */

/*     SPICELIB functions */


/*     Local variables */


/*     Use discovery check-in. */

/*     Look up the base address of the page. */

    zzekpgbs_(type__, p, &base);
    if (failed_()) {
	return 0;
    }
    if (*type__ == 1) {

/*        Look up the encoded count. */

	i__1 = base + 1020;
	zzekgei_(handle, &i__1, nlinks);
    } else if (*type__ == 2) {

/*        Convert the encoded count to integer type. */

	i__1 = base + 128;
	i__2 = base + 128;
	dasrdd_(handle, &i__1, &i__2, &dplnk);
	*nlinks = i_dnnt(&dplnk);
    } else {

/*        The remaining possibility is that TYPE is INT.  If we had had */
/*        an unrecognized type, ZZEKPGBS would have complained. */

	i__1 = base + 256;
	i__2 = base + 256;
	dasrdi_(handle, &i__1, &i__2, nlinks);
    }
    return 0;
} /* zzekglnk_ */