/* $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_ */
/* $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_ */
/* $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_ */
/* 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_ */
/* $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_ */
/*< 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_ */
/* $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_ */
/* 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_ */
/* $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_ */
/* $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_ */
/* $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_ */
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_ */
/* $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_ */
/* $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_ */
/* $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_ */
/* $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_ */
/* $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_ */
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_ */
/* 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_ */
/* 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_ */
/* 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_ */
/* ----------------------------------------------------------------------| */
/* 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_ */
/* $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_ */
/* $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, ¢, &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_ */
/* $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_ */
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_ */
/* $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_ */