/* Subroutine */ int setchr_(char *chr, integer *at, char *string, ftnlen
chr_len, ftnlen string_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Local variables */
extern /* Subroutine */ int chkin_(char *, ftnlen), sigerr_(char *,
ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen),
errint_(char *, integer *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Set a particular location in a string to be a specified */
/* character. */
/* $ 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 */
/* String */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* CHR I character to put in a specified location of string */
/* AT I/O place in string to put CHR */
/* STRING I/O string to be modified by overwriting a character */
/* $ Detailed_Input */
/* CHR A character to overwrite a specified character of */
/* the input string. */
/* AT Location in the input string to overwrite. */
/* STRING String that will have one character modified. */
/* $ Detailed_Output */
/* AT Incremented by 1 from its input value. */
/* STRING The input string after having set STRING(AT:AT) = CHR */
/* $ Parameters */
/* None. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* 1) If AT is before or after the end of the string. The */
/* error 'SPICE(INDEXOUTOFRANGE)' will be signalled. The */
/* string will not be modified. */
/* $ Particulars */
/* This is a "macro" subroutine that encapulates the operations: */
/* 1) check to make sure AT is in range */
/* 2) Overwrite STRING(AT:AT) with CHR */
/* 3) Increment AT by 1. */
/* $ Examples */
/* Here's how you can use this routine to copy the text from one */
/* string into another a character at a time.. Variations can be */
/* made on this example to handle specific tasks based upon the */
/* value of the character to be copied. The example assumes */
/* that INPUT and OUTPUT occupy distinct memory. */
/* GET = 1 */
/* AT = 1 */
/* DO GET = 1, LEN(INPUT) */
/* CALL SETCHR( INPUT(GET:GET), AT, OUTPUT ) */
/* END DO */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 28-MAR-2003 (WLT) */
/* -& */
/* $ Index_Entries */
/* Overwrite a character in a string */
/* -& */
if (return_()) {
return 0;
}
if (*at < 0 || *at > i_len(string, string_len)) {
chkin_("SETCHR", (ftnlen)6);
setmsg_("A request has been made to set the #'th character of a stri"
"ng. However the valid range of characters is from 0 to #.", (
ftnlen)117);
errint_("#", at, (ftnlen)1);
i__1 = i_len(string, string_len);
errint_("#", &i__1, (ftnlen)1);
sigerr_("SPICE(INDEXOUTOFRANGE)", (ftnlen)22);
chkout_("SETCHR", (ftnlen)6);
return 0;
}
*(unsigned char *)&string[*at - 1] = *(unsigned char *)chr;
++(*at);
return 0;
} /* setchr_ */
/* $Procedure ZZEKAC04 ( EK, add class 4 column to segment ) */
/* Subroutine */ int zzekac04_(integer *handle, integer *segdsc, integer *
coldsc, integer *ivals, integer *entszs, logical *nlflgs)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
integer page[256], nelt, from, size;
extern /* Subroutine */ int zzekcnam_(integer *, integer *, char *,
ftnlen), zzeksfwd_(integer *, integer *, integer *, integer *),
zzekpgwi_(integer *, integer *, integer *), zzekspsh_(integer *,
integer *);
integer i__, n, p, ndata, pbase;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
integer class__, nlink, p2, nrows;
extern logical return_(void);
char column[32];
integer adrbuf[254], bufptr, colidx, cursiz, nulptr, remain, to;
logical cntinu, fixsiz, newreq, nullok;
extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen), sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), cleari_(integer *, integer *);
integer row;
extern /* Subroutine */ int zzekaps_(integer *, integer *, integer *,
logical *, integer *, integer *);
/* $ Abstract */
/* Add an entire class 4 column to an EK 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 */
/* EK */
/* $ Keywords */
/* EK */
/* $ 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 Column Name Size */
/* ekcnamsz.inc Version 1 17-JAN-1995 (NJB) */
/* Size of column name, in characters. */
/* End Include Section: EK Column Name Size */
/* $ 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 Das Paging Parameters */
/* ekpage.inc Version 4 25-AUG-1995 (NJB) */
/* The EK DAS paging system makes use of the integer portion */
/* of an EK file's DAS address space to store the few numbers */
/* required to describe the system's state. The allocation */
/* of DAS integer addresses is shown below. */
/* DAS integer array */
/* +--------------------------------------------+ */
/* | EK architecture code | Address = 1 */
/* +--------------------------------------------+ */
/* | Character page size (in DAS words) | */
/* +--------------------------------------------+ */
/* | Character page base address | */
/* +--------------------------------------------+ */
/* | Number of character pages in file | */
/* +--------------------------------------------+ */
/* | Number of character pages on free list | */
/* +--------------------------------------------+ */
/* | Character free list head pointer | Address = 6 */
/* +--------------------------------------------+ */
/* | | Addresses = */
/* | Metadata for d.p. pages | 7--11 */
/* | | */
/* +--------------------------------------------+ */
/* | | Addresses = */
/* | Metadata for integer pages | 12--16 */
/* | | */
/* +--------------------------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------------------------+ */
/* | | End Address = */
/* | Unused space | integer page */
/* | | end */
/* +--------------------------------------------+ */
/* | | Start Address = */
/* | First integer page | integer page */
/* | | base */
/* +--------------------------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------------------------+ */
/* | | */
/* | Last integer page | */
/* | | */
/* +--------------------------------------------+ */
/* The following parameters indicate positions of elements in the */
/* paging system metadata array: */
/* Number of metadata items per data type: */
/* Character metadata indices: */
/* Double precision metadata indices: */
/* Integer metadata indices: */
/* Size of metadata area: */
/* Page sizes, in units of DAS words of the appropriate type: */
/* Default page base addresses: */
/* End Include Section: EK Das Paging 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 Handle attached to new EK file. */
/* SEGDSC I Segment descriptor. */
/* COLDSC I Column descriptor. */
/* IVALS I Integer values to add to column. */
/* ENTSZS I Array of sizes of column entries. */
/* NLFLGS I Array of null flags for column entries. */
/* $ Detailed_Input */
/* HANDLE the handle of an EK file that is open for writing. */
/* A `begin segment for fast load' operation must */
/* have already been performed for the designated */
/* segment. */
/* SEGDSC is a descriptor for the segment to which data is */
/* to be added. The segment descriptor is not */
/* updated by this routine, but some fields in the */
/* descriptor will become invalid after this routine */
/* returns. */
/* COLDSC is a descriptor for the column to be added. The */
/* column attributes must be filled in, but any */
/* pointers may be uninitialized. */
/* ENTSZS is an array containing sizes of column entries. */
/* The Ith element of ENTSZS gives the size of the */
/* Ith column entry. ENTSZS is used only for columns */
/* having variable-size entries. For such columns, */
/* the dimension of ENTSZS must be at least NROWS. */
/* The size of null entries should be set to zero. */
/* For columns having fixed-size entries, the */
/* dimension of this array may be any positive value. */
/* IVALS is an array containing the entire set of column */
/* entries for the specified column. The entries */
/* are listed in row-order: the column entry for the */
/* first row of the segment is first, followed by the */
/* column entry for the second row, and so on. The */
/* number of column entries must match the declared */
/* number of rows in the segment. For columns having */
/* fixed-size entries, a null entry must be allocated */
/* the same amount of space occupied by a non-null */
/* entry in the array IVALS. For columns having */
/* variable-size entries, null entries do not require */
/* any space in the IVALS array, but in any case must */
/* have their allocated space described correctly by */
/* the corresponding element of the ENTSZS array */
/* (described below). */
/* ENTSZS is an array containing sizes of column entries. */
/* The Ith element of ENTSZS gives the size of the */
/* Ith column entry. ENTSZS is used only for columns */
/* having variable-size entries. For such columns, */
/* the dimension of ENTSZS must be at least NROWS. */
/* The size of null entries should be set to zero. */
/* For columns having fixed-size entries, the */
/* dimension of this array may be any positive value. */
/* NLFLGS is an array of logical flags indicating whether */
/* the corresponding entries are null. If the Ith */
/* element of NLFLGS is .FALSE., the Ith column entry */
/* defined by IVALS is added to the specified segment */
/* in the specified kernel file. */
/* If the Ith element of NLFGLS is .TRUE., the */
/* contents of the Ith column entry are undefined. */
/* NLFLGS is used only for columns that allow null */
/* values; it's ignored for other columns. */
/* $ Detailed_Output */
/* None. See $Particulars for a description of the effect of this */
/* routine. */
/* $ 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 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 operates by side effects: it modifies the named */
/* EK file by adding data to the specified column. This routine */
/* writes the entire contents of the specified column in one shot. */
/* This routine creates columns much more efficiently than can be */
/* done by sequential calls to EKACEI, but has the drawback that */
/* the caller must use more memory for the routine's inputs. This */
/* routine cannot be used to add data to a partially completed */
/* column. */
/* $ Examples */
/* See EKACLI. */
/* $ Restrictions */
/* 1) This routine assumes the EK scratch area has been set up */
/* properly for a fast load operation. This routine writes */
/* to the EK scratch area as well. */
/* 2) Only one segment can be created at a time using the fast */
/* load routines. */
/* 3) No other EK operation may interrupt a fast load. For */
/* example, it is not valid to issue a query while a fast load */
/* is in progress. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 22-JUL-1996 (NJB) */
/* Bug fix: case of 100% null data values is now handled */
/* correctly. Previous version line was changed from "Beta" */
/* to "SPICELIB." */
/* - SPICELIB Version 1.0.0, 26-SEP-1995 (NJB) */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 22-JUL-1996 (NJB) */
/* Bug fix: case of 100% null data values is now handled */
/* correctly. The test to determine when to write a page */
/* was fixed to handle this case. */
/* Previous version line was changed from "Beta" */
/* to "SPICELIB." */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZEKAC04", (ftnlen)8);
}
/* Grab the column's attributes. */
class__ = coldsc[0];
nulptr = coldsc[7];
colidx = coldsc[8];
size = coldsc[3];
nullok = nulptr != -1;
fixsiz = size != -1;
/* This column had better be class 4. */
if (class__ != 4) {
zzekcnam_(handle, coldsc, column, (ftnlen)32);
setmsg_("Column class code # found in descriptor for column #. Clas"
"s should be 4.", (ftnlen)73);
errint_("#", &class__, (ftnlen)1);
errch_("#", column, (ftnlen)1, (ftnlen)32);
sigerr_("SPICE(NOCLASS)", (ftnlen)14);
chkout_("ZZEKAC04", (ftnlen)8);
return 0;
}
/* Push the column's ordinal index on the stack. This allows us */
/* to identify the column the addresses belong to. */
zzekspsh_(&c__1, &colidx);
/* Find the number of rows in the segment. */
nrows = segdsc[5];
/* Record the number of data values to write. */
if (nullok) {
/* Sum the sizes of the non-null column entries; these are the */
/* ones that will take up space. */
ndata = 0;
i__1 = nrows;
for (i__ = 1; i__ <= i__1; ++i__) {
if (! nlflgs[i__ - 1]) {
if (fixsiz) {
ndata += size;
} else {
ndata += entszs[i__ - 1];
}
}
}
} else {
if (fixsiz) {
ndata = nrows * size;
} else {
ndata = 0;
i__1 = nrows;
for (i__ = 1; i__ <= i__1; ++i__) {
ndata += entszs[i__ - 1];
}
}
}
if (ndata > 0) {
/* There's some data to write, so allocate a page. Also */
/* prepare a data buffer to be written out as a page. */
zzekaps_(handle, segdsc, &c__3, &c_false, &p, &pbase);
cleari_(&c__256, page);
}
/* Write the input data out to the target file a page at a time. */
/* Null values don't get written. */
/* While we're at it, we'll push onto the EK stack the addresses */
/* of the column entries. We use the constant NULL rather than an */
/* address to represent null entries. */
/* We'll use FROM to indicate the element of IVALS we're */
/* considering, TO to indicate the element of PAGE to write */
/* to, and BUFPTR to indicate the element of ADRBUF to write */
/* addresses to. The variable NELT is the count of the column entry */
/* elements written for the current entry. The variable N indicates */
/* the number of integers written to the current page. */
remain = ndata;
from = 1;
to = 1;
bufptr = 1;
row = 1;
nelt = 1;
n = 0;
nlink = 0;
while(row <= nrows) {
/* NEWREQ is set to TRUE if we discover that the next column */
/* entry must start on a new page. */
newreq = FALSE_;
if (nullok && nlflgs[row - 1]) {
if (fixsiz) {
cursiz = size;
} else {
cursiz = entszs[row - 1];
}
from += cursiz;
adrbuf[(i__1 = bufptr - 1) < 254 && 0 <= i__1 ? i__1 : s_rnge(
"adrbuf", i__1, "zzekac04_", (ftnlen)415)] = -2;
++bufptr;
++row;
nelt = 1;
cntinu = FALSE_;
} else {
if (nelt == 1) {
/* We're about to write out a new column entry. We must */
/* insert the element count into the page before writing the */
/* data. The link count for the current page must be */
/* incremented to account for this new entry. */
/* At this point, we're guaranteed at least two free */
/* spaces in the current page. */
if (fixsiz) {
cursiz = size;
} else {
cursiz = entszs[row - 1];
}
adrbuf[(i__1 = bufptr - 1) < 254 && 0 <= i__1 ? i__1 : s_rnge(
"adrbuf", i__1, "zzekac04_", (ftnlen)441)] = to +
pbase;
++bufptr;
page[(i__1 = to - 1) < 256 && 0 <= i__1 ? i__1 : s_rnge("page"
, i__1, "zzekac04_", (ftnlen)443)] = cursiz;
++to;
++n;
++nlink;
}
/* At this point, there's at least one free space in the */
/* current page. */
page[(i__1 = to - 1) < 256 && 0 <= i__1 ? i__1 : s_rnge("page",
i__1, "zzekac04_", (ftnlen)454)] = ivals[from - 1];
++to;
++n;
++from;
--remain;
/* Decide whether we must continue the current entry on another */
/* data page. */
cntinu = nelt < cursiz && n == 254;
if (nelt == cursiz) {
/* The current element is the last of the current column */
/* entry. */
/* Determine whether we must start the next column entry on */
/* a new page. To start a column entry on the current page, */
/* we must have enough room for the element count and at */
/* least the first entry element. */
if (remain > 0) {
newreq = n > 252;
}
nelt = 1;
++row;
} else {
++nelt;
}
}
if (bufptr > 254 || row > nrows) {
/* The address buffer is full or we're out of input values */
/* to look at, so push the buffer contents on the stack. */
i__1 = bufptr - 1;
zzekspsh_(&i__1, adrbuf);
bufptr = 1;
}
if (cntinu || newreq || row > nrows && ndata > 0) {
/* It's time to write out the current page. First set the link */
/* count. */
page[255] = nlink;
/* Write out the data page. */
zzekpgwi_(handle, &p, page);
/* If there's more data to write, allocate another page. */
if (remain > 0) {
zzekaps_(handle, segdsc, &c__3, &c_false, &p2, &pbase);
cleari_(&c__256, page);
n = 0;
nlink = 0;
to = 1;
/* If we're continuing an element from the previous page, */
/* link the previous page to the current one. */
if (cntinu) {
zzeksfwd_(handle, &c__3, &p, &p2);
}
p = p2;
}
/* We've allocated a new data page if we needed one. */
}
/* We've written out the last completed data page. */
}
/* We've processed all entries of the input array. */
chkout_("ZZEKAC04", (ftnlen)8);
return 0;
} /* zzekac04_ */
/* $Procedure WRENCD ( Write encoded d.p. numbers to text file ) */
/* Subroutine */ int wrencd_(integer *unit, integer *n, doublereal *data)
{
/* System generated locals */
address a__1[3];
integer i__1, i__2, i__3, i__4[3];
char ch__1[66];
cilist ci__1;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), s_wsfe(cilist *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
char work[64*64];
extern /* Subroutine */ int dp2hx_(doublereal *, char *, integer *,
ftnlen);
integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer nitms, itmbeg, length[64];
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Encode and write d.p. numbers to a text 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 */
/* None. */
/* $ Keywords */
/* CONVERSION */
/* NUMBERS */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* UNIT I Fortran unit number of output text file. */
/* N I Number of d.p. numbers to encode and write. */
/* DATA I List of d.p. numbers to encode and write. */
/* $ Detailed_Input */
/* UNIT The Fortran unit number for a previously opened text */
/* file. All writing will begin at the CURRENT POSITION */
/* in the text file. */
/* N The number of double precision numbers to be encoded */
/* and written to the text file attached to UNIT. */
/* DATA List of double precision numbers to be encoded and */
/* written to the text file attached to UNIT. */
/* $ Detailed_Output */
/* See the Particulars section for a description of the effect of */
/* this routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If N, the number of data items, is not positive, the error */
/* SPICE(INVALIDARGUMENT) will be signalled. */
/* 2) If an error occurs while writing to the text file attached */
/* to UNIT, the error SPICE(FILEWRITEFAILED) will be signalled. */
/* 3) If the Fortran logical unit UNIT is not defined, the results */
/* of this routine are unpredictable. */
/* $ Files */
/* See the description of UNIT in the Detailed_Input section. */
/* $ Particulars */
/* This routine will accept a list of one or more double precision */
/* numbers which it will encode into equivalent text strings and */
/* write to the current position in a text file. The current */
/* position in a file is defined to be the text line immediately */
/* following the last text line that was written or read. The */
/* encoded d.p. numbers are written to the output text file as */
/* quoted character strings so that a Fortran list directed read may */
/* be used to read the encoded values, rather than a formatted read */
/* with the format specifier FMT = '(A)'. */
/* This routine is one of a pair of routines which are used to */
/* encode and decode d.p. numbers: */
/* WRENCD -- Encode and write d.p. numbers to a file. */
/* RDENCD -- Read and decode d.p. numbers from a file. */
/* The encoding/decoding of d.p.numbers is performed to provide a */
/* portable means for transferring data values. */
/* Currently the text string produced will be in a base 16 */
/* ``scientific notation.'' This format retains the full precision */
/* available for d.p. numbers on any given computer architecture. */
/* See DP2HX.FOR and HX2DP.FOR for details. */
/* $ Examples */
/* Please note that the output format in the examples is not */
/* intended to be exactly identical with the output format of this */
/* routine in actual use. The output format used in the examples is */
/* intended to aid in the understanding of how this routine works. */
/* It is NOT intended to be a specification of the output format for */
/* this routine. */
/* Let */
/* UNIT be the Fortran logical unit of a previously opened */
/* text file. */
/* N = 100 */
/* DATA(I) = DBLE(I), I = 1,N */
/* Then, the subroutine call */
/* CALL WRENCD( UNIT, N, DATA ) */
/* will write the first 100 integers as encoded d.p. numbers to the */
/* output text file attached to UNIT, beginning at the current */
/* position in the output file, which is marked by an arrow, '-->'. */
/* The resulting output will look something like the following: */
/* -->'1^1' '2^1' '3^1' '4^1' '5^1' '6^1' '7^1' '8^1' '9^1' */
/* 'A^1' 'B^1' 'C^1' 'D^1' 'E^1' 'F^1' '1^2' '11^2' '12^2' */
/* '13^2' '14^2' '15^2' '16^2' '17^2' '18^2' '19^2' '1A^2' */
/* '1B^2' '1C^2' '1D^2' '1E^2' '1F^2' '2^2' '21^2' '22^2' */
/* '23^2' '24^2' '25^2' '26^2' '27^2' '28^2' '29^2' '2A^2' */
/* '2B^2' '2C^2' '2D^2' '2E^2' '2F^2' '3^2' '31^2' '32^2' */
/* '33^2' '34^2' '35^2' '36^2' '37^2' '38^2' '39^2' '3A^2' */
/* '3B^2' '3C^2' '3D^2' '3E^2' '3F^2' '4^2' */
/* '41^2' '42^2' '43^2' '44^2' '45^2' '46^2' '47^2' '48^2' */
/* '49^2' '4A^2' '4B^2' '4C^2' '4D^2' '4E^2' '4F^2' '5^2' */
/* '51^2' '52^2' '53^2' '54^2' '55^2' '56^2' '57^2' '58^2' */
/* '59^2' '5A^2' '5B^2' '5C^2' '5D^2' '5E^2' '5F^2' '6^2' */
/* '61^2' '62^2' '63^2' '64^2' */
/* --> */
/* At this point, the arrow marks the position of the file pointer */
/* immediately after the call to WRENCD. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* $ Version */
/* - SPICELIB Version 1.2.0, 09-SEP-1993 (KRG) */
/* The list directed write was changed to a formatted write using */
/* the specifier FMT='(A)'. This was done in order to prevent a */
/* space from appearing as the first character on each line of the */
/* file for certian computer platforms. */
/* - SPICELIB Version 1.1.0, 21-JUN-1993 (KRG) */
/* This routine was modified to avoid the creation of long output */
/* lines on some of the supported systems, such as the NeXT with */
/* Absoft Fortran 3.2. */
/* A disclaimer was added to the $ Examples section concerning */
/* the output format used. The disclaimer simply states that the */
/* output format used in the example is not necessarily the */
/* output format actually used by the routine. */
/* - SPICELIB Version 1.0.0, 20-OCT-1992 (KRG) */
/* -& */
/* $ Index_Entries */
/* encode and write d.p. numbers to a text file */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.2.0, 09-SEP-1993 (KRG) */
/* The list directed write was changed to a formatted write using */
/* the specifier FMT='(A)'. This was done in order to prevent a */
/* space from appearing as the first character on each line of the */
/* file for certian computer platforms. */
/* - SPICELIB Version 1.1.0, 21-JUN-1993 (KRG) */
/* This routine was modified to avoid the creation of long output */
/* lines on some of the supported systems, such as the NeXT with */
/* Absoft Fortran 3.2. */
/* On some of the supported computers this routine would produce */
/* very long (greater than 1000 characters) output lines due to */
/* the implicit DO loop used in the WRITE statment: */
/* WRITE (UNIT,IOSTAT=IOSTAT,FMT=*) */
/* . ( QUOTE//WORK(I)(1:LENGTH(I))//QUOTE//' ', I=1,NITMS ) */
/* This problem was fixed by removing the implicit DO loop from */
/* the WRITE statement and placing an equivalent DO loop around */
/* the WRITE statemtent: */
/* DO I = 1, NITMS */
/* WRITE (UNIT,IOSTAT=IOSTAT,FMT=*) */
/* . QUOTE//WORK(I)(1:LENGTH(I))//QUOTE */
/* END DO */
/* The net effect of this will be that only a single datum will */
/* be written on each line of output. */
/* A disclaimer was added to the $ Examples section concerning */
/* the output format used. The disclaimer simply states that the */
/* output format used in the example is not necessarily the */
/* output format actually used by the routine. */
/* - SPICELIB Version 1.0.0, 20-OCT-1992 (KRG) */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("WRENCD", (ftnlen)6);
}
/* Check to see if the number of data items is less than or equal */
/* to zero. If it is, signal an error. */
if (*n < 1) {
setmsg_("The number of data items to be written was not positive: #.",
(ftnlen)59);
errint_("#", n, (ftnlen)1);
sigerr_("SPICE(INVALIDARGUMENT)", (ftnlen)22);
chkout_("WRENCD", (ftnlen)6);
return 0;
}
/* Initialize the beginning location for the data items to be */
/* encoded. */
itmbeg = 1;
/* Begin encoding the input data items in blocks of size NITMS. */
/* Each time the number of data items NITMS is reached, write */
/* out the encoded items in the workspace. */
while(itmbeg <= *n) {
/* The number of items is either the size of the workspace, or */
/* the number of data items which remain to be processed, which */
/* should always be less than or equal to the size of the */
/* workspace. */
/* Computing MIN */
i__1 = 64, i__2 = *n - itmbeg + 1;
nitms = min(i__1,i__2);
/* Encode each of the numbers into an equivalent character string. */
i__1 = nitms;
for (i__ = 1; i__ <= i__1; ++i__) {
dp2hx_(&data[itmbeg + i__ - 2], work + (((i__2 = i__ - 1) < 64 &&
0 <= i__2 ? i__2 : s_rnge("work", i__2, "wrencd_", (
ftnlen)324)) << 6), &length[(i__3 = i__ - 1) < 64 && 0 <=
i__3 ? i__3 : s_rnge("length", i__3, "wrencd_", (ftnlen)
324)], (ftnlen)64);
}
/* Write out the current workspace, placing single quotes around */
/* each of the character strings so that they may be read using */
/* Fortran list directed read statements rather than the format */
/* specifier FMT = '(A)'. */
i__1 = nitms;
for (i__ = 1; i__ <= i__1; ++i__) {
ci__1.cierr = 1;
ci__1.ciunit = *unit;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
/* Writing concatenation */
i__4[0] = 1, a__1[0] = "'";
i__4[1] = length[(i__3 = i__ - 1) < 64 && 0 <= i__3 ? i__3 :
s_rnge("length", i__3, "wrencd_", (ftnlen)335)], a__1[1] =
work + (((i__2 = i__ - 1) < 64 && 0 <= i__2 ? i__2 :
s_rnge("work", i__2, "wrencd_", (ftnlen)335)) << 6);
i__4[2] = 1, a__1[2] = "'";
s_cat(ch__1, a__1, i__4, &c__3, (ftnlen)66);
iostat = do_fio(&c__1, ch__1, length[(i__3 = i__ - 1) < 64 && 0 <=
i__3 ? i__3 : s_rnge("length", i__3, "wrencd_", (ftnlen)
335)] + 2);
if (iostat != 0) {
goto L100001;
}
iostat = e_wsfe();
L100001:
/* Check to see if we got a write error, IOSTAT .NE. 0. */
if (iostat != 0) {
setmsg_("Error writing to logical unit #, IOSTAT = #.", (
ftnlen)44);
errint_("#", unit, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEWRITEFAILED)", (ftnlen)22);
chkout_("WRENCD", (ftnlen)6);
return 0;
}
}
/* Position the data item pointer at the next location to begin */
/* encoding the items in the array DATA, and continue processing */
/* the data items until done. */
itmbeg += nitms;
}
chkout_("WRENCD", (ftnlen)6);
return 0;
} /* wrencd_ */
/* $Procedure UNIONC ( Union two character sets ) */
/* Subroutine */ int unionc_(char *a, char *b, char *c__, ftnlen a_len,
ftnlen b_len, ftnlen c_len)
{
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
logical l_lt(char *, char *, ftnlen, ftnlen), l_gt(char *, char *, ftnlen,
ftnlen);
/* Local variables */
integer over, acard, bcard;
extern integer cardc_(char *, ftnlen);
integer ccard;
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern integer sizec_(char *, ftnlen);
integer csize;
extern /* Subroutine */ int scardc_(integer *, char *, ftnlen);
integer apoint, bpoint;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), excess_(integer *, char *, ftnlen), setmsg_(char *,
ftnlen), errint_(char *, integer *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Union two character sets to form a third set. */
/* $ 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 */
/* SETS */
/* $ Keywords */
/* CELLS, SETS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* A I First input set. */
/* B I Second input set. */
/* C O Union of A and B. */
/* $ Detailed_Input */
/* A is a set. */
/* B is a set, distinct from A. */
/* $ Detailed_Output */
/* C is a set, distinct from sets A and B, which */
/* contains the union of A and B (that is, all of */
/* the elements which are in A or B or both). */
/* If the size (maximum cardinality) of C is smaller */
/* than the cardinality of the union of A and B, */
/* then only as many items as will fit in C are */
/* included, and an error is signalled. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* The UNION of two sets contains every element which is */
/* in the first set, or in the second set, or in both sets. */
/* {a,b} union {c,d} = {a,b,c,d} */
/* {a,b,c} {b,c,d} {a,b,c,d} */
/* {a,b,c,d} {} {a,b,c,d} */
/* {} {a,b,c,d} {a,b,c,d} */
/* {} {} {} */
/* The following call */
/* CALL UNIONC ( PLANETS, ASTEROIDS, RESULT ) */
/* places the union of the character sets PLANETS and */
/* ASTEROIDS into the character set RESULT. */
/* The output set must be distinct from both of the input sets. */
/* For example, the following calls are invalid. */
/* CALL UNIONI ( CURRENT, NEW, CURRENT ) */
/* CALL UNIONI ( NEW, CURRENT, CURRENT ) */
/* In each of the examples above, whether or not the subroutine */
/* signals an error, the results will almost certainly be wrong. */
/* Nearly the same effect can be achieved, however, by placing the */
/* result into a temporary set, which is immediately copied back */
/* into one of the input sets, as shown below. */
/* CALL UNIONI ( CURRENT, NEW, TEMP ) */
/* CALL COPYI ( TEMP, NEW ) */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* 1) If the union of the two sets causes an excess of elements, the */
/* error SPICE(SETEXCESS) is signalled. */
/* 2) If length of the elements of the output set is < the */
/* maximum of the lengths of the elements of the input */
/* sets, the error SPICE(ELEMENTSTOOSHORT) is signalled. */
/* $ Files */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* C.A. Curzon (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 18-JUN-1999 (WLT) */
/* Made CHKOUT calls consistent with CHKIN. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (CAC) (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* union two character sets */
/* -& */
/* $ Revisions */
/* - Beta Version 2.0.0, 05-JAN-1989 (NJB) */
/* Error signalled if output set elements are not long enough. */
/* Length must be at least max of lengths of input elements. */
/* Also, calling protocol for EXCESS has been changed. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Set up the error processing. */
if (return_()) {
return 0;
}
chkin_("UNIONC", (ftnlen)6);
/* Make sure output set elements are long enough. */
/* Computing MAX */
i__1 = i_len(a, a_len), i__2 = i_len(b, b_len);
if (i_len(c__, c_len) < max(i__1,i__2)) {
setmsg_("Length of output cell is #. Length required to contain res"
"ult is #.", (ftnlen)68);
i__1 = i_len(c__, c_len);
errint_("#", &i__1, (ftnlen)1);
/* Computing MAX */
i__2 = i_len(a, a_len), i__3 = i_len(b, b_len);
i__1 = max(i__2,i__3);
errint_("#", &i__1, (ftnlen)1);
sigerr_("SPICE(ELEMENTSTOOSHORT)", (ftnlen)23);
chkout_("UNIONC", (ftnlen)6);
return 0;
}
/* Find the cardinality of the input sets, and the allowed size */
/* of the output set. */
acard = cardc_(a, a_len);
bcard = cardc_(b, b_len);
csize = sizec_(c__, c_len);
/* Begin with the input pointers at the first elements of the */
/* input sets. The cardinality of the output set is zero. */
/* And there is no overflow so far. */
apoint = 1;
bpoint = 1;
ccard = 0;
over = 0;
/* When the ends of both input sets are reached, we're done. */
while(apoint <= acard || bpoint <= bcard) {
/* If there is still space in the output set, fill it */
/* as necessary. */
if (ccard < csize) {
if (apoint > acard) {
++ccard;
s_copy(c__ + (ccard + 5) * c_len, b + (bpoint + 5) * b_len,
c_len, b_len);
++bpoint;
} else if (bpoint > bcard) {
++ccard;
s_copy(c__ + (ccard + 5) * c_len, a + (apoint + 5) * a_len,
c_len, a_len);
++apoint;
} else if (s_cmp(a + (apoint + 5) * a_len, b + (bpoint + 5) *
b_len, a_len, b_len) == 0) {
++ccard;
s_copy(c__ + (ccard + 5) * c_len, a + (apoint + 5) * a_len,
c_len, a_len);
++apoint;
++bpoint;
} else if (l_lt(a + (apoint + 5) * a_len, b + (bpoint + 5) *
b_len, a_len, b_len)) {
++ccard;
s_copy(c__ + (ccard + 5) * c_len, a + (apoint + 5) * a_len,
c_len, a_len);
++apoint;
} else if (l_gt(a + (apoint + 5) * a_len, b + (bpoint + 5) *
b_len, a_len, b_len)) {
++ccard;
s_copy(c__ + (ccard + 5) * c_len, b + (bpoint + 5) * b_len,
c_len, b_len);
++bpoint;
}
/* Otherwise, stop filling the array, but continue to count the */
/* number of elements in excess of the size of the output set. */
} else {
if (apoint > acard) {
++over;
++bpoint;
} else if (bpoint > bcard) {
++over;
++apoint;
} else if (s_cmp(a + (apoint + 5) * a_len, b + (bpoint + 5) *
b_len, a_len, b_len) == 0) {
++over;
++apoint;
++bpoint;
} else if (l_lt(a + (apoint + 5) * a_len, b + (bpoint + 5) *
b_len, a_len, b_len)) {
++over;
++apoint;
} else if (l_gt(a + (apoint + 5) * a_len, b + (bpoint + 5) *
b_len, a_len, b_len)) {
++over;
++bpoint;
}
}
}
/* Set the cardinality of the output set. */
scardc_(&ccard, c__, c_len);
/* Report any excess. */
if (over > 0) {
excess_(&over, "set", (ftnlen)3);
sigerr_("SPICE(SETEXCESS)", (ftnlen)16);
}
chkout_("UNIONC", (ftnlen)6);
return 0;
} /* unionc_ */
/* $Procedure ZZEKTR1S ( EK tree, one-shot load ) */
/* Subroutine */ int zzektr1s_(integer *handle, integer *tree, integer *size,
integer *values)
{
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
integer base, page[256], nbig, node, subd, next, unit;
extern /* Subroutine */ int zzekpgal_(integer *, integer *, integer *,
integer *), zzekpgri_(integer *, integer *, integer *), zzekpgwi_(
integer *, integer *, integer *);
extern integer zzektrbs_(integer *);
integer d__, i__, n, q, child, s;
extern integer zzektrsz_(integer *, integer *);
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer level, nkids, npred, nkeys, tsize, kidbas;
extern /* Subroutine */ int cleari_(integer *, integer *), dasudi_(
integer *, integer *, integer *, integer *);
integer basidx;
extern /* Subroutine */ int dashlu_(integer *, integer *);
integer bigsiz, nnodes, nsmall, stnbig[10], stnbas[10], stnode[10];
extern /* Subroutine */ int errfnm_(char *, integer *, ftnlen);
extern logical return_(void);
integer maxsiz, reqsiz, stlsiz[10], stnext[10], stnkey[10], stsbsz[10],
subsiz, totnod;
extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen), sigerr_(char *, ftnlen), chkout_(char *,
ftnlen);
integer div, key;
/* $ Abstract */
/* One-shot tree load: insert an entire array into an empty */
/* tree. */
/* $ 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 Das Paging Parameters */
/* ekpage.inc Version 4 25-AUG-1995 (NJB) */
/* The EK DAS paging system makes use of the integer portion */
/* of an EK file's DAS address space to store the few numbers */
/* required to describe the system's state. The allocation */
/* of DAS integer addresses is shown below. */
/* DAS integer array */
/* +--------------------------------------------+ */
/* | EK architecture code | Address = 1 */
/* +--------------------------------------------+ */
/* | Character page size (in DAS words) | */
/* +--------------------------------------------+ */
/* | Character page base address | */
/* +--------------------------------------------+ */
/* | Number of character pages in file | */
/* +--------------------------------------------+ */
/* | Number of character pages on free list | */
/* +--------------------------------------------+ */
/* | Character free list head pointer | Address = 6 */
/* +--------------------------------------------+ */
/* | | Addresses = */
/* | Metadata for d.p. pages | 7--11 */
/* | | */
/* +--------------------------------------------+ */
/* | | Addresses = */
/* | Metadata for integer pages | 12--16 */
/* | | */
/* +--------------------------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------------------------+ */
/* | | End Address = */
/* | Unused space | integer page */
/* | | end */
/* +--------------------------------------------+ */
/* | | Start Address = */
/* | First integer page | integer page */
/* | | base */
/* +--------------------------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------------------------+ */
/* | | */
/* | Last integer page | */
/* | | */
/* +--------------------------------------------+ */
/* The following parameters indicate positions of elements in the */
/* paging system metadata array: */
/* Number of metadata items per data type: */
/* Character metadata indices: */
/* Double precision metadata indices: */
/* Integer metadata indices: */
/* Size of metadata area: */
/* Page sizes, in units of DAS words of the appropriate type: */
/* Default page base addresses: */
/* End Include Section: EK Das Paging 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 Tree Parameters */
/* ektree.inc Version 3 22-OCT-1995 (NJB) */
/* The parameters in this file define the tree structure */
/* used by the EK system. This structure is a variant of the */
/* B*-tree structure described in Knuth's book, that is */
/* Knuth, Donald E. "The Art of Computer Programming, */
/* Volume 3/Sorting and Searching" 1973, pp 471-479. */
/* The trees used in the EK system differ from generic B*-trees */
/* primarily in the way keys are treated. Rather than storing */
/* unique primary key values in each node, EK trees store integer */
/* counts that represent the ordinal position of each data value, */
/* counting from the lowest indexed element in the subtree whose */
/* root is the node in question. Thus the keys are unique within */
/* a node but not across multiple nodes: in fact the Nth key in */
/* every leaf node is N. The absolute ordinal position of a data */
/* item is defined recursively as the sum of the key of the data item */
/* and the absolute ordinal position of the data item in the parent */
/* node that immediately precedes all elements of the node in */
/* question. This data structure allows EK trees to support lookup */
/* of data items based on their ordinal position in a data set. The */
/* two prime applications of this capability in the EK system are: */
/* 1) Using trees to index the records in a table, allowing */
/* the Nth record to be located efficiently. */
/* 2) Using trees to implement order vectors that can be */
/* maintained when insertions and deletions are done. */
/* Root node */
/* +--------------------------------------------+ */
/* | Tree version code | */
/* +--------------------------------------------+ */
/* | Number of nodes in tree | */
/* +--------------------------------------------+ */
/* | Number of keys in tree | */
/* +--------------------------------------------+ */
/* | Depth of tree | */
/* +--------------------------------------------+ */
/* | Number of keys in root | */
/* +--------------------------------------------+ */
/* | Space for n keys, | */
/* | | */
/* | n = 2 * INT( ( 2*m - 2 )/3 ) | */
/* | | */
/* | where m is the max number of children per | */
/* | node in the child nodes | */
/* +--------------------------------------------+ */
/* | Space for n+1 child pointers, | */
/* | where n is as defined above. | */
/* +--------------------------------------------+ */
/* | Space for n data pointers, | */
/* | where n is as defined above. | */
/* +--------------------------------------------+ */
/* Child node */
/* +--------------------------------------------+ */
/* | Number of keys present in node | */
/* +--------------------------------------------+ */
/* | Space for m-1 keys | */
/* +--------------------------------------------+ */
/* | Space for m child pointers | */
/* +--------------------------------------------+ */
/* | Space for m-1 data pointers | */
/* +--------------------------------------------+ */
/* The following parameters give the maximum number of children */
/* allowed in the root and child nodes. During insertions, the */
/* number of children may overflow by 1. */
/* Maximum number of children allowed in a child node: */
/* Maximum number of keys allowed in a child node: */
/* Minimum number of children allowed in a child node: */
/* Minimum number of keys allowed in a child node: */
/* Maximum number of children allowed in the root node: */
/* Maximum number of keys allowed in the root node: */
/* Minimum number of children allowed in the root node: */
/* The following parameters indicate positions of elements in the */
/* tree node structures shown above. */
/* The following parameters are for the root node only: */
/* Location of version code: */
/* Version code: */
/* Location of node count: */
/* Location of total key count for the tree: */
/* Location of tree depth: */
/* Location of count of keys in root node: */
/* Base address of keys in the root node: */
/* Base address of child pointers in root node: */
/* Base address of data pointers in the root node (allow room for */
/* overflow): */
/* Size of root node: */
/* The following parameters are for child nodes only: */
/* Location of number of keys in node: */
/* Base address of keys in child nodes: */
/* Base address of child pointers in child nodes: */
/* Base address of data pointers in child nodes (allow room */
/* for overflow): */
/* Size of child node: */
/* A number of EK tree routines must declare stacks of fixed */
/* depth; this depth limit imposes a limit on the maximum depth */
/* that an EK tree can have. Because of the large branching */
/* factor of EK trees, the depth limit is of no practical */
/* importance: The number of keys that can be held in an EK */
/* tree of depth N is */
/* N-1 */
/* MXKIDC - 1 */
/* MXKIDR * ------------- */
/* MXKIDC - 1 */
/* This formula yields a capacity of over 1 billion keys for a */
/* tree of depth 6. */
/* End Include Section: EK Tree 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. */
/* TREE I Root of tree. */
/* SIZE I Size of tree. */
/* VALUES I Values to insert. */
/* $ Detailed_Input */
/* HANDLE is a file handle of an EK open for write access. */
/* TREE is the root node number of the tree of interest. */
/* The tree must be empty. */
/* SIZE is the size of the tree to create: SIZE is the */
/* number of values that will be inserted into the */
/* tree. */
/* VALUES is an array of integer values to be inserted into */
/* the tree. */
/* $ Detailed_Output */
/* None. See $Particulars for a description of the effect of this */
/* routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If HANDLE is invalid, the error will be diagnosed by routines */
/* called by this routine. The file will not be modified. */
/* 2) If an I/O error occurs while reading or writing the indicated */
/* file, the error will be diagnosed by routines called by this */
/* routine. */
/* 3) If the input tree is not empty, the error SPICE(NONEMPTYTREE) */
/* is signalled. */
/* 4) If the depth of the tree needed to hold the number of values */
/* indicated by SIZE exceeds the maximum depth limit, the error */
/* SPICE(COUNTTOOLARGE) is signalled. */
/* $ Files */
/* See the EK Required Reading for a discussion of the EK file */
/* format. */
/* $ Particulars */
/* This routine creates an EK tree and loads the tree with the */
/* integer values supplied in the array VALUES. The ordinal */
/* positions of the values in the tree correspond to the positions */
/* of the values in the input array: for example, the 10th element */
/* of the array is pointed to by the key 10. */
/* This routine loads a tree much faster than can be done by */
/* sequentially loading the set of values by successive calls to */
/* ZZEKTRIN. On the other hand, the caller must declare an array */
/* large enough to hold all of the values to be loaded. Note that */
/* a partially full tree cannot be extended using this routine. */
/* $ Examples */
/* See EKFFLD. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* 1) Knuth, Donald E. "The Art of Computer Programming, Volume */
/* 3/Sorting and Searching" 1973, pp 471-479. */
/* EK trees are closely related to the B* trees described by */
/* Knuth. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - Beta Version 1.1.0, 18-JUN-1999 (WLT) */
/* Removed redundant calls to CHKIN */
/* - Beta Version 1.0.0, 22-OCT-1995 (NJB) */
/* -& */
/* SPICELIB functions */
/* Non-SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZEKTR1S", (ftnlen)8);
}
/* Make sure the input tree is empty. */
tsize = zzektrsz_(handle, tree);
if (tsize > 0) {
dashlu_(handle, &unit);
setmsg_("Tree has size #; should be empty.EK = #; TREE = #.", (ftnlen)
50);
errint_("#", &tsize, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
errint_("#", tree, (ftnlen)1);
sigerr_("SPICE(NONEMPTYTREE)", (ftnlen)19);
chkout_("ZZEKTR1S", (ftnlen)8);
return 0;
}
/* Compute the tree depth required. The largest tree of a given */
/* depth D contains the root node plus S(D) child nodes, where */
/* S(1) = 1 */
/* and if D is at least 2, */
/* D - 2 */
/* ____ */
/* \ i */
/* S(D) = MAX_SIZE * / MAX_SIZE */
/* Root ---- Child */
/* i = 0 */
/* D - 2 */
/* ____ */
/* \ i */
/* = MXKIDR * / MXKIDC */
/* ---- */
/* i = 0 */
/* D-1 */
/* MXKIDC - 1 */
/* = MXKIDR * ------------- */
/* MXKIDC - 1 */
/* If all of these nodes are full, the number of keys that */
/* can be held in this tree is */
/* MXKEYR + S(D) * MXKEYC */
/* We want the minimum value of D such that this expression */
/* is greater than or equal to SIZE. */
tsize = 82;
d__ = 1;
s = 1;
while(tsize < *size) {
++d__;
if (d__ == 2) {
s = 82;
} else {
/* For computational purposes, the relationship */
/* S(D+1) = MXKIDR + MXKIDC * S(D) */
/* is handy. */
s = s * 63 + 83;
}
tsize = s * 62 + 82;
}
/* If the tree must be deeper than we expected, we've a problem. */
if (d__ > 10) {
dashlu_(handle, &unit);
setmsg_("Tree has depth #; max supported depth is #.EK = #; TREE = #."
, (ftnlen)60);
errint_("#", &d__, (ftnlen)1);
errint_("#", &c__10, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
errint_("#", tree, (ftnlen)1);
sigerr_("SPICE(COUNTTOOLARGE)", (ftnlen)20);
chkout_("ZZEKTR1S", (ftnlen)8);
return 0;
}
/* The basic error checks are done. At this point, we can build the */
/* tree. */
/* The approach is to fill in the tree in a top-down fashion. */
/* We decide how big each subtree of the root will be; this */
/* information allows us to decide which keys actually belong */
/* in the root. Having filled in the root, we repeat the process */
/* for each subtree of the root in left-to-right order. */
/* We use a stack to keep track of the ancestors of the */
/* node we're currently considering. The table below shows the */
/* items we save on the stack and the stack variables associated */
/* with those items: */
/* Item Stack Variable */
/* ---- --------------- */
/* Node number STNODE */
/* Size, in keys, of the */
/* subtree headed by node STSBSZ */
/* Number of keys in node STNKEY */
/* Larger subtree size STLSIZ */
/* Number of large subtrees STNBIG */
/* Index of next subtree to visit STNEXT */
/* Base index of node STNBAS */
node = *tree;
subsiz = *size;
next = 1;
level = 1;
basidx = 0;
while(level > 0) {
/* At this point, LEVEL, NEXT, NODE, SUBSIZ and BASIDX are set. */
if (next == 1) {
/* This node has not been visited yet. We'll fill in this */
/* node before proceeding to fill in its descendants. The */
/* first step is to compute the number and sizes of the */
/* subtrees of this node. */
/* Decide the large subtree size and the number of subtrees of */
/* this node. The depth SUBD of the subtrees of this node is */
/* D - LEVEL. Each subtree has size bounded by the sizes of */
/* the subtree of depth SUBD in which all nodes contain MNKEYC */
/* keys and the by the subtree of depth SUBD in which all nodes */
/* contain MXKEYC keys. If this node is not the root and is */
/* not a leaf node, the number of subtrees must be between */
/* MNKIDC and MXKIDC. */
if (level == 1) {
/* We're working on the root. The number of subtrees is */
/* anywhere between 0 and MXKIDR, inclusive. We'll create */
/* a tree with the minimum number of subtrees of the root. */
if (d__ > 1) {
/* We'll find the number of subtrees of maximum size */
/* that we would need to hold the non-root keys of the */
/* tree. We'll then determine the actual required sizes */
/* of these subtrees. */
subd = d__ - 1;
nnodes = 0;
i__1 = subd;
for (i__ = 1; i__ <= i__1; ++i__) {
nnodes = nnodes * 63 + 1;
}
maxsiz = nnodes * 62;
/* If we had NKIDS subtrees of size MAXSIZ, NKIDS */
/* would be the smallest integer such that */
/* ( NKIDS - 1 ) + NKIDS * MAXSIZ > SUBSIZ */
/* - */
/* or equivalently, */
/* NKIDS * ( MAXSIZ + 1 ) > SUBSIZ + 1 */
/* - */
/* We'll compute this value of NKIDS. */
q = subsiz + 1;
div = maxsiz + 1;
nkids = (q + div - 1) / div;
/* The minimum number of keys we must store in child */
/* nodes is the number of keys in the tree, minus those */
/* that can be accommodated in the root: */
n = subsiz - (nkids - 1);
/* Now we can figure out how large the subtrees would */
/* have to be in order to hold N keys, if all subtrees */
/* had the same size. */
bigsiz = (n + nkids - 1) / nkids;
/* We may have more capacity than we need if all subtrees */
/* have size BIGSIZ. So, we'll allow some subtrees to */
/* have size BIGSIZ-1. Not all subtrees can have the */
/* smaller size (otherwise BIGSIZ would have been */
/* smaller). The first NBIG subtrees will have the */
/* larger size. */
nsmall = nkids * bigsiz - n;
nbig = nkids - nsmall;
nkeys = nkids - 1;
} else {
/* All keys are in the root. */
nkeys = *size;
nkids = 0;
}
/* Read in the root page. */
zzekpgri_(handle, tree, page);
/* We have enough information to fill in the root node. */
/* We'll allocate nodes for the immediate children. */
/* There is one key `between' each child pointer. */
i__1 = nkeys;
for (i__ = 1; i__ <= i__1; ++i__) {
/* The Ith key may be found by considering the number */
/* of keys in the subtree between the Ith key and its */
/* predecessor in the root. */
if (i__ == 1) {
npred = 0;
} else {
npred = page[(i__2 = i__ + 3) < 256 && 0 <= i__2 ?
i__2 : s_rnge("page", i__2, "zzektr1s_", (
ftnlen)480)];
}
if (d__ > 1) {
/* The tree contains subtrees. */
if (i__ <= nbig) {
key = npred + bigsiz + 1;
} else {
key = npred + bigsiz;
}
} else {
key = i__;
}
page[(i__2 = i__ + 4) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"page", i__2, "zzektr1s_", (ftnlen)499)] = key;
page[(i__2 = i__ + 171) < 256 && 0 <= i__2 ? i__2 :
s_rnge("page", i__2, "zzektr1s_", (ftnlen)500)] =
values[key - 1];
}
totnod = 1;
i__1 = nkids;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Allocate a node for the Ith child. Store pointers */
/* to these nodes. */
zzekpgal_(handle, &c__3, &child, &base);
page[(i__2 = i__ + 87) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"page", i__2, "zzektr1s_", (ftnlen)513)] = child;
++totnod;
}
/* Fill in the root's metadata. There is one item that */
/* we'll have to fill in when we're done: the number of */
/* nodes in the tree. We know the rest of the information */
/* now. */
page[2] = *size;
page[3] = d__;
page[4] = nkeys;
page[1] = 0;
/* Write out the root. */
zzekpgwi_(handle, tree, page);
} else if (level < d__) {
/* The current node is a non-leaf child node. */
cleari_(&c__256, page);
/* The tree headed by this node has depth D-LEVEL+1 and */
/* must hold SUBSIZ keys. We must figure out the size */
/* and number of subtrees of the current node. Unlike in */
/* the case of the root, we must have between MNKIDC */
/* and MXKIDC subtrees of this node. We start out by */
/* computing the required subtree size if there were */
/* exactly MNKIDC subtrees. In this case, the total */
/* number of keys in the subtrees would be */
/* SUBSIZ - MNKEYC */
n = subsiz - 41;
reqsiz = (n + 40) / 41;
/* Compute the maximum allowable number of keys in */
/* a subtree. */
subd = d__ - level;
nnodes = 0;
i__1 = subd;
for (i__ = 1; i__ <= i__1; ++i__) {
nnodes = nnodes * 63 + 1;
}
maxsiz = nnodes * 62;
/* If the number REQSIZ we came up with is a valid size, */
/* we'll be able to get the correct number of children */
/* by using subtrees of size REQSIZ and REQSIZ-1. Note */
/* that it's impossible for REQSIZ to be too small, */
/* since the smallest possible number of subtrees is */
/* MNKIDC. */
if (reqsiz <= maxsiz) {
/* Decide how many large and small subtrees we need. */
nkids = 42;
bigsiz = reqsiz;
nsmall = bigsiz * nkids - n;
nbig = nkids - nsmall;
} else {
/* See how many subtrees of size MAXSIZ it would take */
/* to hold the requisite number of keys. We know the */
/* number is more than MNKIDC. If we have NKIDS */
/* subtrees of size MAXSIZ, the total number of */
/* keys in the subtree headed by NODE is */
/* ( NKIDS - 1 ) + ( NKIDS * MAXSIZ ) */
/* or */
/* NKIDS * ( MAXSIZ + 1 ) - 1 */
/* We must find the smallest value of NKIDS such */
/* that the above quantity is greater than or equal */
/* to SUBSIZ. */
q = subsiz + 1;
div = maxsiz + 1;
nkids = (q + div - 1) / div;
/* We know that NKIDS subtrees of size MAXSIZ, plus */
/* NKIDS-1 keys in NODE, can hold at least SUBSIZ */
/* keys. We now want to find the smallest subtree */
/* size such that NKIDS subtrees of that size, */
/* together with the NKIDS-1 keys in NODE, contain */
/* at least SUBSIZ keys. The size we seek will */
/* become BIGSIZ, the larger of the two subtree */
/* sizes we'll use. So BIGSIZ is the smallest */
/* integer such that */
/* ( NKIDS - 1 ) + ( NKIDS * BIGSIZ ) > SUBSIZ */
/* - */
/* or equivalently */
/* BIGSIZ * NKIDS > SUBSIZ - NKIDS + 1 */
/* - */
q = subsiz - nkids + 1;
div = nkids;
bigsiz = (q + div - 1) / div;
nsmall = bigsiz * nkids - q;
nbig = nkids - nsmall;
}
/* Fill in the keys for the current node. */
nkeys = nkids - 1;
i__1 = nkeys;
for (i__ = 1; i__ <= i__1; ++i__) {
/* The Ith key may be found by considering the number */
/* of keys in the subtree between the Ith key and its */
/* predecessor in the current node. */
if (i__ == 1) {
npred = basidx;
} else {
npred = basidx + page[(i__2 = i__ - 1) < 256 && 0 <=
i__2 ? i__2 : s_rnge("page", i__2, "zzektr1s_"
, (ftnlen)652)];
}
if (i__ <= nbig) {
key = npred + bigsiz + 1;
} else {
key = npred + bigsiz;
}
page[(i__2 = i__) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"page", i__2, "zzektr1s_", (ftnlen)661)] = key -
basidx;
page[(i__2 = i__ + 127) < 256 && 0 <= i__2 ? i__2 :
s_rnge("page", i__2, "zzektr1s_", (ftnlen)662)] =
values[key - 1];
}
i__1 = nkids;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Allocate a node for the Ith child. Store pointers */
/* to these nodes. */
zzekpgal_(handle, &c__3, &child, &base);
page[(i__2 = i__ + 63) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"page", i__2, "zzektr1s_", (ftnlen)674)] = child;
++totnod;
}
/* We can now fill in the metadata for the current node. */
page[0] = nkeys;
zzekpgwi_(handle, &node, page);
}
/* Unless the current node is a leaf node, prepare to visit */
/* the first child of the current node. */
if (level < d__) {
/* Push our current state. */
stnode[(i__1 = level - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge(
"stnode", i__1, "zzektr1s_", (ftnlen)696)] = node;
stsbsz[(i__1 = level - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge(
"stsbsz", i__1, "zzektr1s_", (ftnlen)697)] = subsiz;
stnkey[(i__1 = level - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge(
"stnkey", i__1, "zzektr1s_", (ftnlen)698)] = nkeys;
stlsiz[(i__1 = level - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge(
"stlsiz", i__1, "zzektr1s_", (ftnlen)699)] = bigsiz;
stnbig[(i__1 = level - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge(
"stnbig", i__1, "zzektr1s_", (ftnlen)700)] = nbig;
stnext[(i__1 = level - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge(
"stnext", i__1, "zzektr1s_", (ftnlen)701)] = 2;
stnbas[(i__1 = level - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge(
"stnbas", i__1, "zzektr1s_", (ftnlen)702)] = basidx;
/* NEXT is already set to 1. BASIDX is set, since the */
/* base index of the first child is that of the parent. */
if (level == 1) {
kidbas = 88;
} else {
kidbas = 64;
}
++level;
node = page[(i__1 = kidbas) < 256 && 0 <= i__1 ? i__1 :
s_rnge("page", i__1, "zzektr1s_", (ftnlen)715)];
subsiz = bigsiz;
} else if (level > 1) {
/* The current node is a child leaf node. There are no */
/* calculations to do; we simply assign keys and pointers, */
/* write out metadata, and pop our state. */
nkeys = subsiz;
i__1 = nkeys;
for (i__ = 1; i__ <= i__1; ++i__) {
key = basidx + i__;
page[(i__2 = i__) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"page", i__2, "zzektr1s_", (ftnlen)730)] = i__;
page[(i__2 = i__ + 127) < 256 && 0 <= i__2 ? i__2 :
s_rnge("page", i__2, "zzektr1s_", (ftnlen)731)] =
values[key - 1];
}
/* We can now fill in the metadata for the current node. */
page[0] = nkeys;
zzekpgwi_(handle, &node, page);
/* A leaf node is a subtree unto itself, and we're */
/* done with this subtree. Pop our state. */
--level;
if (level >= 1) {
node = stnode[(i__1 = level - 1) < 10 && 0 <= i__1 ? i__1
: s_rnge("stnode", i__1, "zzektr1s_", (ftnlen)750)
];
nkeys = stnkey[(i__1 = level - 1) < 10 && 0 <= i__1 ?
i__1 : s_rnge("stnkey", i__1, "zzektr1s_", (
ftnlen)751)];
bigsiz = stlsiz[(i__1 = level - 1) < 10 && 0 <= i__1 ?
i__1 : s_rnge("stlsiz", i__1, "zzektr1s_", (
ftnlen)752)];
nbig = stnbig[(i__1 = level - 1) < 10 && 0 <= i__1 ? i__1
: s_rnge("stnbig", i__1, "zzektr1s_", (ftnlen)753)
];
next = stnext[(i__1 = level - 1) < 10 && 0 <= i__1 ? i__1
: s_rnge("stnext", i__1, "zzektr1s_", (ftnlen)754)
];
basidx = stnbas[(i__1 = level - 1) < 10 && 0 <= i__1 ?
i__1 : s_rnge("stnbas", i__1, "zzektr1s_", (
ftnlen)755)];
nkids = nkeys + 1;
/* Read in the current node. */
zzekpgri_(handle, &node, page);
}
} else {
/* The only node is the root. Pop out. */
level = 0;
}
/* We've decided which node to go to next at this point. */
/* At this point, LEVEL, NEXT, NODE, SUBSIZ and BASIDX are set. */
} else {
/* The current node has been visited already. Visit the */
/* next child, if there is one. */
if (next <= nkids) {
/* Prepare to visit the next child of the current node. */
stnext[(i__1 = level - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge(
"stnext", i__1, "zzektr1s_", (ftnlen)787)] = next + 1;
if (level == 1) {
kidbas = 88;
} else {
kidbas = 64;
}
node = page[(i__1 = kidbas + next - 1) < 256 && 0 <= i__1 ?
i__1 : s_rnge("page", i__1, "zzektr1s_", (ftnlen)797)]
;
if (next <= nbig) {
subsiz = stlsiz[(i__1 = level - 1) < 10 && 0 <= i__1 ?
i__1 : s_rnge("stlsiz", i__1, "zzektr1s_", (
ftnlen)801)];
} else {
subsiz = stlsiz[(i__1 = level - 1) < 10 && 0 <= i__1 ?
i__1 : s_rnge("stlsiz", i__1, "zzektr1s_", (
ftnlen)803)] - 1;
}
if (next <= nbig + 1) {
basidx = stnbas[(i__1 = level - 1) < 10 && 0 <= i__1 ?
i__1 : s_rnge("stnbas", i__1, "zzektr1s_", (
ftnlen)809)] + (next - 1) * stlsiz[(i__2 = level
- 1) < 10 && 0 <= i__2 ? i__2 : s_rnge("stlsiz",
i__2, "zzektr1s_", (ftnlen)809)] + (next - 1);
} else {
basidx = stnbas[(i__1 = level - 1) < 10 && 0 <= i__1 ?
i__1 : s_rnge("stnbas", i__1, "zzektr1s_", (
ftnlen)815)] + nbig * stlsiz[(i__2 = level - 1) <
10 && 0 <= i__2 ? i__2 : s_rnge("stlsiz", i__2,
"zzektr1s_", (ftnlen)815)] + (next - nbig - 1) * (
stlsiz[(i__3 = level - 1) < 10 && 0 <= i__3 ?
i__3 : s_rnge("stlsiz", i__3, "zzektr1s_", (
ftnlen)815)] - 1) + (next - 1);
}
++level;
next = 1;
/* LEVEL, NEXT, NODE, SUBSIZ, and BASIDX are set. */
} else {
/* We're done with the current subtree. Pop the stack. */
--level;
if (level >= 1) {
node = stnode[(i__1 = level - 1) < 10 && 0 <= i__1 ? i__1
: s_rnge("stnode", i__1, "zzektr1s_", (ftnlen)836)
];
nkeys = stnkey[(i__1 = level - 1) < 10 && 0 <= i__1 ?
i__1 : s_rnge("stnkey", i__1, "zzektr1s_", (
ftnlen)837)];
bigsiz = stlsiz[(i__1 = level - 1) < 10 && 0 <= i__1 ?
i__1 : s_rnge("stlsiz", i__1, "zzektr1s_", (
ftnlen)838)];
nbig = stnbig[(i__1 = level - 1) < 10 && 0 <= i__1 ? i__1
: s_rnge("stnbig", i__1, "zzektr1s_", (ftnlen)839)
];
next = stnext[(i__1 = level - 1) < 10 && 0 <= i__1 ? i__1
: s_rnge("stnext", i__1, "zzektr1s_", (ftnlen)840)
];
basidx = stnbas[(i__1 = level - 1) < 10 && 0 <= i__1 ?
i__1 : s_rnge("stnbas", i__1, "zzektr1s_", (
ftnlen)841)];
nkids = nkeys + 1;
/* Read in the current node. */
zzekpgri_(handle, &node, page);
}
}
}
/* On this pass through the loop, we either--- */
/* - Visited a node for the first time and filled in the */
/* node. */
/* - Advanced to a new node that has not yet been visited. */
/* - Exited from a completed subtree. */
/* Each of these actions can be performed a finite number of */
/* times. Therefore, we made progress toward loop termination. */
}
/* The last chore is setting the total number of nodes in the root. */
base = zzektrbs_(tree);
i__1 = base + 2;
i__2 = base + 2;
dasudi_(handle, &i__1, &i__2, &totnod);
chkout_("ZZEKTR1S", (ftnlen)8);
return 0;
} /* zzektr1s_ */
/* $Procedure CONICS ( Determine state from conic elements ) */
/* Subroutine */ int conics_(doublereal *elts, doublereal *et, doublereal *
state)
{
/* System generated locals */
doublereal d__1;
/* Builtin functions */
double cos(doublereal), sin(doublereal), sqrt(doublereal), d_mod(
doublereal *, doublereal *);
/* Local variables */
doublereal cnci, argp, snci, cosi, sini, cosn, sinn;
extern /* Subroutine */ int vscl_(doublereal *, doublereal *, doublereal *
);
doublereal cosw, sinw, n, v;
extern /* Subroutine */ int chkin_(char *, ftnlen);
doublereal lnode;
extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen);
doublereal m0;
extern doublereal twopi_(void);
doublereal t0;
extern /* Subroutine */ int prop2b_(doublereal *, doublereal *,
doublereal *, doublereal *);
doublereal dt, rp, mu, basisp[3], period, basisq[3];
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen);
doublereal pstate[6], ainvrs;
extern /* Subroutine */ int setmsg_(char *, ftnlen);
extern logical return_(void);
doublereal ecc, inc;
/* $ Abstract */
/* Determine the state (position, velocity) of an orbiting body */
/* from a set of elliptic, hyperbolic, or parabolic orbital */
/* elements. */
/* $ 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 */
/* CONIC */
/* EPHEMERIS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ELTS I Conic elements. */
/* ET I Input time. */
/* STATE O State of orbiting body at ET. */
/* $ Detailed_Input */
/* ELTS are conic elements describing the orbit of a body */
/* around a primary. The elements are, in order: */
/* RP Perifocal distance. */
/* ECC Eccentricity. */
/* INC Inclination. */
/* LNODE Longitude of the ascending node. */
/* ARGP Argument of periapse. */
/* M0 Mean anomaly at epoch. */
/* T0 Epoch. */
/* MU Gravitational parameter. */
/* Units are km, rad, rad/sec, km**3/sec**2. The epoch */
/* is given in ephemeris seconds past J2000. The same */
/* elements are used to describe all three types */
/* (elliptic, hyperbolic, and parabolic) of conic orbit. */
/* ET is the time at which the state of the orbiting body */
/* is to be determined, in ephemeris seconds J2000. */
/* $ Detailed_Output */
/* STATE is the state (position and velocity) of the body at */
/* time ET. Components are x, y, z, dx/dt, dy/dt, dz/dt. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the eccentricity supplied is less than 0, the error */
/* 'SPICE(BADECCENTRICITY)' is signalled. */
/* 2) If a non-positive periapse distance is supplied, the error */
/* 'SPICE(BADPERIAPSEVALUE)' is signalled. */
/* 3) If a non-positive value for the attracting mass is supplied, */
/* the error 'SPICE(BADGM)', is signalled. */
/* 4) Errors such as an out of bounds value for ET are diagnosed */
/* by routines called by this routine. */
/* $ Files */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* Let VINIT contain the initial state of a spacecraft relative to */
/* the center of a planet at epoch ET, and let GM be the gravitation */
/* parameter of the planet. The call */
/* CALL OSCELT ( VINIT, ET, GM, ELTS ) */
/* produces a set of osculating elements describing the nominal */
/* orbit that the spacecraft would follow in the absence of all */
/* other bodies in the solar system and non-gravitational forces */
/* on the spacecraft. */
/* Now let STATE contain the state of the same spacecraft at some */
/* other epoch, LATER. The difference between this state and the */
/* state predicted by the nominal orbit at the same epoch can be */
/* computed as follows. */
/* CALL CONICS ( ELTS, LATER, NOMINAL ) */
/* CALL VSUBG ( NOMINAL, STATE, 6, DIFF ) */
/* WRITE (*,*) 'Perturbation in x, dx/dt = ', DIFF(1), DIFF(4) */
/* WRITE (*,*) ' y, dy/dt = ', DIFF(2), DIFF(5) */
/* WRITE (*,*) ' z, dz/dt = ', DIFF(3), DIFF(6) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* [1] Roger Bate, Fundamentals of Astrodynamics, Dover, 1971. */
/* $ Author_and_Institution */
/* I.M. Underwood (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 4.0.0, 26-MAR-1998 (WLT) */
/* There was a coding error in the computation of the mean */
/* anomaly in the parabolic case. This problem has been */
/* corrected. */
/* - SPICELIB Version 3.0.1, 15-OCT-1996 (WLT) */
/* Corrected a typo in the description of the units associated */
/* with the input elements. */
/* - SPICELIB Version 3.0.0, 12-NOV-1992 (WLT) */
/* The routine was re-written to make use of NAIF's universal */
/* variables formulation for state propagation (PROP2B). As */
/* a result, several problems were simultaneously corrected. */
/* A major bug was fixed that caused improper state evaluations */
/* for ET's that precede the epoch of the elements in the */
/* elliptic case. */
/* A danger of non-convergence in the solution of Kepler's */
/* equation has been eliminated. */
/* In addition to this reformulation of CONICS checks were */
/* installed that ensure the elements supplied are physically */
/* meaningful. Eccentricity must be non-negative. The */
/* distance at periapse and central mass must be positive. If */
/* not errors are signalled. */
/* - 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, 19-APR-1991 (WLT) */
/* An error in the hyperbolic state generation was corrected. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */
/* -& */
/* $ Index_Entries */
/* state from conic elements */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 3.0.1, 15-OCT-1996 (WLT) */
/* Corrected a typo in the description of the units associated */
/* with the input elements. */
/* - SPICELIB Version 3.0.0, 12-NOV-1992 (WLT) */
/* The routine was re-written to make use of NAIF's universal */
/* variables formulation for state propagation (PROP2B). As */
/* a result, several problems were simultaneously corrected. */
/* A major bug was fixed that caused improper state evaluations */
/* for ET's that precede the epoch of the elements in the */
/* elliptic case. */
/* A danger of non-convergence in the solution of Kepler's */
/* equation has been eliminated. */
/* In addition to this reformulation of CONICS checks were */
/* installed that ensure the elements supplied are physically */
/* meaningful. Eccentricity must be non-negative. The */
/* distance at periapse and central mass must be positive. If */
/* not errors are signalled. */
/* These changes were prompted by the discovery that the old */
/* formulation had a severe bug for elliptic orbits and epochs */
/* prior to the epoch of the input elements, and by the discovery */
/* that the time of flight routines had problems with convergence. */
/* - SPICELIB Version 2.0.0, 19-APR-1991 (WLT) */
/* The original version of the routine had a bug in that */
/* it attempted to restrict the hyperbolic anomaly to */
/* the interval 0 to 2*PI. This has been fixed. */
/* - Beta Version 1.0.1, 27-JAN-1989 (IMU) */
/* Examples section completed. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* The only real work required by this routine is the construction */
/* of a preliminary state vector from the input elements. Once this */
/* is in hand, we can simply let the routine PROP2B do the real */
/* work, free from the instabilities inherent in the classical */
/* elements formulation of two-body motion. */
/* To do this we shall construct a basis of vectors that lie in the */
/* plane of the orbit. The first vector P shall point towards the */
/* position of the orbiting body at periapse. The second */
/* vector Q shall point along the velocity vector of the body at */
/* periapse. */
/* The only other consideration is determining an epoch, TP, of */
/* this state and the delta time ET - TP. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("CONICS", (ftnlen)6);
}
/* Unpack the element vector. */
rp = elts[0];
ecc = elts[1];
inc = elts[2];
lnode = elts[3];
argp = elts[4];
m0 = elts[5];
t0 = elts[6];
mu = elts[7];
/* Handle all of the exceptions first. */
if (ecc < 0.) {
setmsg_("The eccentricity supplied was negative. Only positive value"
"s are meaningful. The value was #", (ftnlen)93);
errdp_("#", &ecc, (ftnlen)1);
sigerr_("SPICE(BADECCENTRICITY)", (ftnlen)22);
chkout_("CONICS", (ftnlen)6);
return 0;
}
if (rp <= 0.) {
setmsg_("The value of periapse range supplied was non-positive. Onl"
"y positive values are allowed. The value supplied was #. ", (
ftnlen)117);
errdp_("#", &rp, (ftnlen)1);
sigerr_("SPICE(BADPERIAPSEVALUE)", (ftnlen)23);
chkout_("CONICS", (ftnlen)6);
return 0;
}
if (mu <= 0.) {
setmsg_("The value of GM supplied was non-positive. Only positive v"
"alues are allowed. The value supplied was #. ", (ftnlen)105);
errdp_("#", &mu, (ftnlen)1);
sigerr_("SPICE(BADGM)", (ftnlen)12);
chkout_("CONICS", (ftnlen)6);
return 0;
}
/* First construct the orthonormal basis vectors that span the orbit */
/* plane. */
cosi = cos(inc);
sini = sin(inc);
cosn = cos(lnode);
sinn = sin(lnode);
cosw = cos(argp);
sinw = sin(argp);
snci = sinn * cosi;
cnci = cosn * cosi;
basisp[0] = cosn * cosw - snci * sinw;
basisp[1] = sinn * cosw + cnci * sinw;
basisp[2] = sini * sinw;
basisq[0] = -cosn * sinw - snci * cosw;
basisq[1] = -sinn * sinw + cnci * cosw;
basisq[2] = sini * cosw;
/* Next construct the state at periapse. */
/* The position at periapse is just BASISP scaled by the distance */
/* at periapse. */
/* The velocity must be constructed so that we can get an orbit */
/* of this shape. Recall that the magnitude of the specific angular */
/* momentum vector is given by DSQRT ( MU*RP*(1+ECC) ) */
/* The velocity will be given by V * BASISQ. But we must have the */
/* magnitude of the cross product of position and velocity be */
/* equal to DSQRT ( MU*RP*(1+ECC) ). So we must have */
/* RP*V = DSQRT( MU*RP*(1+ECC) ) */
/* so that: */
v = sqrt(mu * (ecc + 1.) / rp);
vscl_(&rp, basisp, pstate);
vscl_(&v, basisq, &pstate[3]);
/* Finally compute DT the elapsed time since the epoch of periapse. */
/* Ellipses first, since they are the most common. */
if (ecc < 1.) {
/* Recall that: */
/* N ( mean motion ) is given by DSQRT( MU / A**3 ). */
/* But since, A = RP / ( 1 - ECC ) ... */
ainvrs = (1. - ecc) / rp;
n = sqrt(mu * ainvrs) * ainvrs;
period = twopi_() / n;
/* In general the mean anomaly is given by */
/* M = (T - TP) * N */
/* Where TP is the time of periapse passage. M0 is the mean */
/* anomaly at time T0 so that */
/* Thus */
/* M0 = ( T0 - TP ) * N */
/* So TP = T0-M0/N hence the time since periapse at time ET */
/* is given by ET - T0 + M0/N. Finally, since elliptic orbits are */
/* periodic, we can mod this value by the period of the orbit. */
d__1 = *et - t0 + m0 / n;
dt = d_mod(&d__1, &period);
/* Hyperbolas next. */
} else if (ecc > 1.) {
/* Again, recall that: */
/* N ( mean motion ) is given by DSQRT( MU / |A**3| ). */
/* But since, |A| = RP / ( ECC - 1 ) ... */
ainvrs = (ecc - 1.) / rp;
n = sqrt(mu * ainvrs) * ainvrs;
dt = *et - t0 + m0 / n;
/* Finally, parabolas. */
} else {
n = sqrt(mu / (rp * 2.)) / rp;
dt = *et - t0 + m0 / n;
}
/* Now let PROP2B do the work of propagating the state. */
prop2b_(&mu, pstate, &dt, state);
chkout_("CONICS", (ftnlen)6);
return 0;
} /* conics_ */
/* $Procedure TXTOPR ( Text file, open for read ) */
/* Subroutine */ int txtopr_(char *fname, integer *unit, ftnlen fname_len)
{
/* System generated locals */
olist o__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), f_open(olist *);
/* Local variables */
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), sigerr_(char *, ftnlen), chkout_(char *, ftnlen)
, getlun_(integer *), setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Open a text file for read access. */
/* $ 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 */
/* TEXT */
/* $ Keywords */
/* FILES */
/* TEXT */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* FNAME I Name of file. */
/* UNIT O Logical unit. */
/* $ Detailed_Input */
/* FNAME is the name of the text file to be opened. */
/* $ Detailed_Output */
/* UNIT is the logical unit connected to the opened file. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If FNAME is a blank string, the error SPICE(BLANKFILENAME) is */
/* signalled. */
/* 2) If the file cannot be opened, the error SPICE(FILEOPENFAILED) */
/* is signalled. */
/* $ Files */
/* See FNAME and UNIT above. */
/* $ Particulars */
/* In SPICELIB, a text file is formatted and sequential and may */
/* contain only printable ASCII characters and blanks (ASCII 32-127). */
/* When printing a text file, records are single spaced; the first */
/* character will not be interpreted as a carriage control character. */
/* TXTOPR opens an existing text file for read access and makes use */
/* of the SPICELIB mechanism for coordinating use of logical units. */
/* System Dependencies */
/* =================== */
/* The open statement will include the following keyword = value */
/* pairs: */
/* UNIT = UNIT */
/* FILE = FNAME */
/* FORM = 'FORMATTED' */
/* ACCESS = 'SEQUENTIAL' */
/* STATUS = 'OLD' */
/* IOSTAT = IOSTAT */
/* In addition, the statement will include */
/* CARRIAGECONTROL = 'LIST' */
/* READONLY */
/* for the Vax and the OS X Absoft compiler, or */
/* MODE = 'READ' */
/* for the IBM pc. */
/* $ Examples */
/* The following example reads the first line from an input file, */
/* 'INPUT.TXT', and writes it to an output file, 'OUTPUT.TXT'. */
/* CALL TXTOPR ( 'INPUT.TXT', IN ) */
/* CALL TXTOPN ( 'OUTPUT.TXT', OUT ) */
/* READ ( IN, FMT='(A)' ) LINE */
/* WRITE ( OUT, FMT='(A)' ) LINE */
/* CLOSE ( IN ) */
/* CLOSE ( OUT ) */
/* $ Restrictions */
/* The file, FNAME, must exist prior to calling TXTOPR. */
/* $ Literature_References */
/* 1. "Lahey F77L EM/32 FORTRAN Language Reference Manual", page */
/* 145. */
/* 2. "Absoft FORTRAN 77 Language Reference Manual", page 7-12 for */
/* the NeXT. */
/* $ Author_and_Institution */
/* J.E. McLean (JPL) */
/* H.A. Neilan (JPL) */
/* M.J. Spencer (JPL) */
/* $ Version */
/* - SPICELIB Version 2.25.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 2.24.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 2.23.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 2.22.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 2.21.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 2.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 2.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 2.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 2.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 2.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 2.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 2.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 2.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 2.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 2.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 2.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 2.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 2.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 2.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 2.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 2.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 2.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 2.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 2.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 2.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 2.0.6, 24-APR-2003 (EDW) */
/* Added MAC-OSX-F77 to the list of platforms */
/* that require READONLY to read write protected */
/* kernels. */
/* - SPICELIB Version 2.0.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 2.0.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 2.0.3, 16-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - SPICELIB Version 2.0.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 2.0.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 2.0.0, 05-APR-1998 (NJB) */
/* References to the PC-LINUX environment were added. */
/* - SPICELIB Version 1.3.0, 11-NOV-1993 (HAN) */
/* Module was updated for the Silicon Graphics, DEC Alpha-OSF/1, */
/* and NeXT platforms. */
/* - SPICELIB Version 1.2.0, 12-OCT-1992 (HAN) */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 1.1.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.1.0, 13-NOV-1991 (MJS) */
/* Module updated to allow portability to the Lahey F77L EM/32 */
/* FORTRAN V 4.0 environment. */
/* - SPICELIB Version 1.0.0, 05-APR-1991 (JEM) */
/* -& */
/* $ Index_Entries */
/* text file open for read */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 05-APR-1998 (NJB) */
/* References to the PC-LINUX environment were added. */
/* - SPICELIB Version 1.3.0, 11-NOV-1993 (HAN) */
/* Module was updated for the Silicon Graphics, DEC Alpha-OSF/1, */
/* and NeXT platforms. */
/* - SPICELIB Version 1.2.0, 12-OCT-1992 (HAN) */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 1.1.0, 13-NOV-1991 (MJS) */
/* Module updated to allow portability to the Lahey F77L EM/32 */
/* FORTRAN V 4.0 environment. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("TXTOPR", (ftnlen)6);
}
if (s_cmp(fname, " ", fname_len, (ftnlen)1) == 0) {
setmsg_("A blank string is unacceptable as a file name", (ftnlen)45);
sigerr_("SPICE(BLANKFILENAME)", (ftnlen)20);
chkout_("TXTOPR", (ftnlen)6);
return 0;
}
getlun_(unit);
o__1.oerr = 1;
o__1.ounit = *unit;
o__1.ofnmlen = fname_len;
o__1.ofnm = fname;
o__1.orl = 0;
o__1.osta = "OLD";
o__1.oacc = "SEQUENTIAL";
o__1.ofm = "FORMATTED";
o__1.oblnk = 0;
iostat = f_open(&o__1);
if (iostat != 0) {
setmsg_("Could not open file #. IOSTAT was #. ", (ftnlen)37);
errch_("#", fname, (ftnlen)1, fname_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEOPENFAILED)", (ftnlen)21);
chkout_("TXTOPR", (ftnlen)6);
return 0;
}
chkout_("TXTOPR", (ftnlen)6);
return 0;
} /* txtopr_ */
/* $Procedure DASUDD ( DAS, update data, double precision ) */
/* Subroutine */ int dasudd_(integer *handle, integer *first, integer *last,
doublereal *data)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer n;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer lastc, lastd, recno, lasti, numdp;
extern /* Subroutine */ int dasa2l_(integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
extern logical failed_(void);
integer clbase;
extern /* Subroutine */ int daslla_(integer *, integer *, integer *,
integer *), dasurd_(integer *, integer *, integer *, integer *,
doublereal *);
integer clsize;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
integer wordno;
extern logical return_(void);
integer nwritn;
/* $ Abstract */
/* Update data in a specified range of double precision addresses */
/* in a 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 */
/* $ Keywords */
/* ARRAY */
/* ASSIGNMENT */
/* DAS */
/* FILES */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I DAS file handle. */
/* FIRST, */
/* LAST I Range of d.p. addresses to write to. */
/* DATA I An array of d.p. numbers. */
/* $ Detailed_Input */
/* HANDLE is a file handle of a DAS file opened for writing. */
/* FIRST, */
/* LAST are the first and last of a range of DAS logical */
/* addresses of double precision numbers. These */
/* addresses satisfy the inequality */
/* 1 < FIRST < LAST < LASTD */
/* _ - - */
/* where LASTD is the last double precision logical */
/* address in use in the DAS file designated by */
/* HANDLE. */
/* DATA is an array of double precision numbers. The */
/* array elements DATA(1) through DATA(N) will be */
/* written to the indicated DAS file, where N is */
/* LAST - FIRST + 1. */
/* $ Detailed_Output */
/* See $Particulars for a description of the effect of this routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input file handle is invalid, the error will be */
/* diagnosed by routines called by this routine. */
/* 2) Only logical addresses that already contain data may be */
/* updated: if either FIRST or LAST are outside the range */
/* [ 1, LASTD ] */
/* where LASTD is the last double precision logical address */
/* that currently contains data in the indicated DAS file, the */
/* error SPICE(INVALIDADDRESS) is signalled. */
/* The DAS file will not be modified. */
/* 3) If FIRST > LAST but both addresses are valid, this routine */
/* will not modify the indicated DAS file. No error will be */
/* signalled. */
/* 4) If an I/O error occurs during the data update attempted */
/* by this routine, the error will be diagnosed by routines */
/* called by this routine. FIRST and LAST will not be modified. */
/* $ Files */
/* See the description of the argument HANDLE in $Detailed_Input. */
/* $ Particulars */
/* This routine replaces the double precision data in the specified */
/* range of logical addresses within a DAS file with the contents of */
/* the input array DATA. */
/* The actual physical write operations that update the indicated */
/* DAS file with the contents of the input array DATA may not take */
/* place before this routine returns, since the DAS system buffers */
/* data that is written as well as data that is read. In any case, */
/* the data will be flushed to the file at the time the file is */
/* closed, if not earlier. A physical write of all buffered */
/* records can be forced by calling the SPICELIB routine DASWUR */
/* ( DAS, write updated records ). */
/* In order to append double precision data to a DAS file, filling */
/* in a range of double precision logical addresses that starts */
/* immediately after the last double precision logical address */
/* currently in use, the SPICELIB routine DASADD ( DAS add data, */
/* double precision ) should be used. */
/* $ Examples */
/* 1) Write to addresses 1 through 500 in a DAS file in */
/* random-access fashion by updating the file. Recall */
/* that data must be present in the file before it can */
/* be updated. */
/* PROGRAM UP */
/* CHARACTER*(4) TYPE */
/* DOUBLE PRECISION DATA ( 500 ) */
/* INTEGER HANDLE */
/* INTEGER I */
/* C */
/* C Open the new DAS file RAND.DAS. Use the file name */
/* C as the internal file name. */
/* C */
/* TYPE = 'TEST' */
/* CALL DASONW ( 'TEST.DAS', TYPE, 'TEST.DAS', HANDLE ) */
/* C */
/* C Append 500 double precision numbers to the file; */
/* C after the data is present, we're free to update it */
/* C in any order we please. (CLEARD zeros out a double */
/* C precision array.) */
/* C */
/* CALL CLEARD ( 500, DATA ) */
/* CALL DASADD ( HANDLE, 500, DATA ) */
/* C */
/* C Now the double precision logical addresses 1:500 */
/* C can be written to in random-access fashion. We'll */
/* C fill them in in reverse order. */
/* C */
/* DO I = 500, 1, -1 */
/* CALL DASUDD ( HANDLE, I, I, DBLE(I) ) */
/* END DO */
/* C */
/* C Close the file. */
/* C */
/* CALL DASCLS ( HANDLE ) */
/* C */
/* C Now make sure that we updated the file properly. */
/* C Open the file for reading and dump the contents */
/* C of the double precision logical addresses 1:500. */
/* C */
/* CALL DASOPR ( 'RAND.DAS', HANDLE ) */
/* CALL CLEARD ( 500, DATA ) */
/* CALL DASRDD ( HANDLE, 1, 500, DATA ) */
/* WRITE (*,*) 'Contents of RAND.DAS:' */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) DATA */
/* END */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.1 19-DEC-1995 (NJB) */
/* Corrected title of permuted index entry section. */
/* - SPICELIB Version 1.1.0, 12-MAY-1994 (KRG) (NJB) */
/* Test of FAILED() added to loop termination conditions. */
/* Removed references to specific DAS file open routines in the */
/* $ Detailed_Input section of the header. This was done in order */
/* to minimize documentation changes if the DAS open routines ever */
/* change. */
/* Modified the $ Examples section to demonstrate the new ID word */
/* format which includes a file type and to include a call to the */
/* new routine DASONW, open new for write, which makes use of the */
/* file type. Also, a variable for the type of the file to be */
/* created was added. */
/* - SPICELIB Version 1.0.0, 11-NOV-1992 (NJB) (WLT) */
/* -& */
/* $ Index_Entries */
/* update double precision data in a DAS file */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 12-MAY-1994 (KRG) (NJB) */
/* Test of FAILED() added to loop termination condition. Without */
/* this test, an infinite loop could result if DASA2L or DASURD */
/* signaled an error inside the loop. */
/* Removed references to specific DAS file open routines in the */
/* $ Detailed_Input section of the header. This was done in order */
/* to minimize documentation changes if the DAS open routines ever */
/* change. */
/* Modified the $ Examples section to demonstrate the new ID word */
/* format which includes a file type and to include a call to the */
/* new routine DASONW, open new for write, which makes use of the */
/* file type. Also, a variable for the type of the file to be */
/* created was added. */
/* - SPICELIB Version 1.0.0, 11-NOV-1992 (NJB) (WLT) */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("DASUDD", (ftnlen)6);
}
/* Get the last logical addresses in use in this DAS file. */
daslla_(handle, &lastc, &lastd, &lasti);
/* Validate the input addresses. */
if (*first < 1 || *first > lastd || *last < 1 || *last > lastd) {
setmsg_("FIRST was #. LAST was #. Valid range is [1,#].", (ftnlen)46);
errint_("#", first, (ftnlen)1);
errint_("#", last, (ftnlen)1);
errint_("#", &lastd, (ftnlen)1);
sigerr_("SPICE(INVALIDADDRESS)", (ftnlen)21);
chkout_("DASUDD", (ftnlen)6);
return 0;
}
/* Let N be the number of addresses to update. */
n = *last - *first + 1;
/* We will use the variables RECNO and OFFSET to determine where to */
/* write data in the DAS file. RECNO will be the record containing */
/* the physical location to write to; WORDNO will be the word */
/* location that we will write to next. */
/* Find the first location to write to. CLBASE and CLSIZE are the */
/* base record number and size of the cluster of d.p. records that */
/* the address FIRST lies within. */
dasa2l_(handle, &c__2, first, &clbase, &clsize, &recno, &wordno);
/* Set the number of double precision words already written. Keep */
/* writing to the file until this number equals the number of */
/* elements in DATA. */
/* Note that if N is non-positive, the loop doesn't get exercised. */
nwritn = 0;
while(nwritn < n && ! failed_()) {
/* Write as much data as we can (or need to) into the current */
/* record. We assume that CLBASE, RECNO, WORDNO, and NWRITN have */
/* been set correctly at this point. */
/* Find out how many words to write into the current record. */
/* There may be no space left in the current record. */
/* Computing MIN */
i__1 = n - nwritn, i__2 = 128 - wordno + 1;
numdp = min(i__1,i__2);
if (numdp > 0) {
/* Write NUMDP words into the current record. */
i__1 = wordno + numdp - 1;
dasurd_(handle, &recno, &wordno, &i__1, &data[nwritn]);
nwritn += numdp;
wordno += numdp;
} else {
/* It's time to start on a new record. If the record we */
/* just finished writing to (or just attempted writing to, */
/* if it was full) was not the last of the cluster, the next */
/* record to write to is the immediate successor of the last */
/* one. Otherwise, we'll have to look up the location of the */
/* next d.p. logical address. */
if (recno < clbase + clsize - 1) {
++recno;
wordno = 1;
} else {
i__1 = *first + nwritn;
dasa2l_(handle, &c__2, &i__1, &clbase, &clsize, &recno, &
wordno);
}
}
}
chkout_("DASUDD", (ftnlen)6);
return 0;
} /* dasudd_ */
/* $Procedure XFMSTA ( Transform state between coordinate systems) */
/* Subroutine */ int xfmsta_(doublereal *istate, char *icosys, char *ocosys,
char *body, doublereal *ostate, ftnlen icosys_len, ftnlen ocosys_len,
ftnlen body_len)
{
/* Initialized data */
static char cosys[40*6] = "RECTANGULAR "
"CYLINDRICAL " "LATITUDINAL "
" " "SPHERICAL "
"GEODETIC " "PLANETOGRAPHIC "
" ";
static logical first = TRUE_;
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
extern /* Subroutine */ int zzbods2c_(integer *, char *, integer *,
logical *, char *, integer *, logical *, ftnlen, ftnlen);
doublereal ivel[3], ipos[3];
extern /* Subroutine */ int vequ_(doublereal *, doublereal *);
integer isys, osys;
doublereal f;
extern /* Subroutine */ int zzctruin_(integer *);
integer i__, j;
doublereal radii[3];
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), vpack_(doublereal *, doublereal *, doublereal *,
doublereal *);
extern doublereal dpmax_(void);
logical found;
extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen), vequg_(
doublereal *, integer *, doublereal *);
doublereal sqtmp;
char isysu[40], osysu[40];
static logical svfnd1;
static integer svctr1[2];
extern logical failed_(void);
doublereal jacobi[9] /* was [3][3] */;
extern /* Subroutine */ int bodvcd_(integer *, char *, integer *, integer
*, doublereal *, ftnlen), georec_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), drdgeo_(
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *), recgeo_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), dgeodr_(
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *);
integer bodyid;
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
static integer svbdid;
extern /* Subroutine */ int latrec_(doublereal *, doublereal *,
doublereal *, doublereal *), drdlat_(doublereal *, doublereal *,
doublereal *, doublereal *), cylrec_(doublereal *, doublereal *,
doublereal *, doublereal *), drdcyl_(doublereal *, doublereal *,
doublereal *, doublereal *);
doublereal toobig;
extern /* Subroutine */ int sphrec_(doublereal *, doublereal *,
doublereal *, doublereal *), drdsph_(doublereal *, doublereal *,
doublereal *, doublereal *), pgrrec_(char *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, ftnlen), drdpgr_(char *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, ftnlen),
reccyl_(doublereal *, doublereal *, doublereal *, doublereal *),
reclat_(doublereal *, doublereal *, doublereal *, doublereal *),
sigerr_(char *, ftnlen), recsph_(doublereal *, doublereal *,
doublereal *, doublereal *), chkout_(char *, ftnlen), recpgr_(
char *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, ftnlen), dcyldr_(doublereal *,
doublereal *, doublereal *, doublereal *), dlatdr_(doublereal *,
doublereal *, doublereal *, doublereal *), ljucrs_(integer *,
char *, char *, ftnlen, ftnlen), setmsg_(char *, ftnlen), dsphdr_(
doublereal *, doublereal *, doublereal *, doublereal *);
static char svbody[36];
extern /* Subroutine */ int dpgrdr_(char *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, ftnlen);
extern logical return_(void);
integer dim;
extern /* Subroutine */ int mxv_(doublereal *, doublereal *, doublereal *)
;
/* $ Abstract */
/* Transform a state between coordinate systems. */
/* $ 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 */
/* CONVERSION */
/* COORDINATE */
/* EPHEMERIS */
/* STATE */
/* $ Declarations */
/* $ Abstract */
/* This include file defines the dimension of the counter */
/* array used by various SPICE subsystems to uniquely identify */
/* changes in their states. */
/* $ 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 */
/* CTRSIZ is the dimension of the counter array used by */
/* various SPICE subsystems to uniquely identify */
/* changes in their states. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 29-JUL-2013 (BVS) */
/* -& */
/* End of include file. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- ------------------------------------------------- */
/* ISTATE I Input state. */
/* ICOSYS I Current (input) coordinate system. */
/* OCOSYS I Desired (output) coordinate system. */
/* BODY I Name or NAIF ID of body with which */
/* coordinates are associated (if applicable). */
/* OSTATE O Converted output state. */
/* $ Detailed_Input */
/* ISTATE is a state vector in the input (ICOSYS) coordinate */
/* system representing position and velocity. */
/* All angular measurements must be in radians. */
/* Note: body radii values taken from the kernel */
/* pool are used when converting to or from geodetic or */
/* planetographic coordinates. It is the user's */
/* responsibility to verify the distance inputs are in */
/* the same units as the radii in the kernel pool, */
/* typically kilometers. */
/* ICOSYS is the name of the coordinate system that the input */
/* state vector (ISTATE) is currently in. */
/* ICOSYS may be any of the following: */
/* 'RECTANGULAR' */
/* 'CYLINDRICAL' */
/* 'LATITUDINAL' */
/* 'SPHERICAL' */
/* 'GEODETIC' */
/* 'PLANETOGRAPHIC' */
/* Leading spaces, trailing spaces, and letter case */
/* are ignored. For example, ' cyLindRical ' would be */
/* accepted. */
/* OCOSYS is the name of the coordinate system that the state */
/* should be converted to. */
/* Please see the description of ICOSYS for details. */
/* BODY is the name or NAIF ID of the body associated with the */
/* planetographic or geodetic coordinate system. */
/* If neither of the coordinate system choices are */
/* geodetic or planetographic, BODY may be an empty */
/* string (' '). */
/* Examples of accepted body names or IDs are: */
/* 'Earth' */
/* '399' */
/* Leading spaces, trailing spaces, and letter case are */
/* ignored. */
/* $ Detailed_Output */
/* OSTATE is the state vector that has been converted to the */
/* output coordinate system (OCOSYS). */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If either the input or output coordinate system is not */
/* recognized, the error SPICE(COORDSYSNOTREC) is signaled. */
/* 2) If the input body name cannot be converted to a NAIF ID */
/* (applies to geodetic and planetographic coordinate */
/* systems), the error 'SPICE(IDCODENOTFOUND)' is signaled. */
/* 3) If the input state ISTATE is not valid, meaning the position */
/* but not the velocity is along the z-axis, the error */
/* 'SPICE(INVALIDSTATE)' is signaled. */
/* Note: If both the input position and velocity are along */
/* the z-axis and the output coordinate system is not */
/* rectangular, the velocity can still be calculated even */
/* though the Jacobian is undefined. This case will not */
/* signal an error. An example of the input position and */
/* velocity along the z-axis is below. */
/* Term Value */
/* ----- ------ */
/* x 0 */
/* y 0 */
/* z z */
/* dx/dt 0 */
/* dy/dt 0 */
/* dz/dt dz_dt */
/* 4) If either the input or output coordinate system is */
/* geodetic or planetographic and at least one of the body's */
/* radii is less than or equal to zero, the error */
/* SPICE(INVALIDRADIUS) will be signaled. */
/* 5) If either the input or output coordinate system is */
/* geodetic or planetographic and the difference of the */
/* equatorial and polar radii divided by the equatorial radius */
/* would produce numeric overflow, the error */
/* 'SPICE(INVALIDRADIUS)' will be signaled. */
/* 6) If the product of the Jacobian and velocity components */
/* may lead to numeric overflow, the error */
/* 'SPICE(NUMERICOVERFLOW)' is signaled. */
/* $ Files */
/* SPK, PCK, CK, and FK kernels may be required. */
/* If the input or output coordinate systems are either geodetic or */
/* planetographic, a PCK providing the radii of the body */
/* name BODY must be loaded via FURNSH. */
/* Kernel data are normally loaded once per program run, NOT every */
/* time this routine is called. */
/* $ Particulars */
/* Input Order */
/* ------------------------------------------- */
/* The input and output states will be structured by the */
/* following descriptions. */
/* For rectangular coordinates, the state vector is the following */
/* in which X, Y, and Z are the rectangular position components and */
/* DX, DY, and DZ are the time derivatives of each position */
/* component. */
/* ISTATE = ( X, Y, Z, DX, DY, DZ ) */
/* For cylindrical coordinates, the state vector is the following */
/* in which R is the radius, LONG is the longitudes, Z is the */
/* height, and DR, DLONG, and DZ are the time derivatives of each */
/* position component. */
/* ISTATE = ( R, LONG, Z, DR, DLONG, DZ ) */
/* For latitudinal coordinates, the state vector is the following */
/* in which R is the radius, LONG is the longitude, LAT is the */
/* latitude, and DR, DLONG, and DLAT are the time derivatives of */
/* each position component. */
/* ISTATE = ( R, LONG, LAT, DR, DLONG, DLAT ) */
/* For spherical coordinates, the state vector is the following in */
/* which R is the radius, COLAT is the colatitude, LONG is the */
/* longitude, and DR, DCOLAT, and DLONG are the time derivatives of */
/* each position component. */
/* ISTATE = ( R, COLAT, LONG, DR, DCOLAT, DLONG ) */
/* For geodetic coordinates, the state vector is the following in */
/* which LONG is the longitude, LAT is the latitude, ALT is the */
/* altitude, and DLONG, DLAT, and DALT are the time derivatives of */
/* each position component. */
/* ISTATE = ( LONG, LAT, ALT, DLONG, DLAT, DALT ) */
/* For planetographic coordinates, the state vector is the */
/* following in which LONG is the longitude, LAT is the latitude, */
/* ALT is the altitude, and DLONG, DLAT, and DALT are the time */
/* derivatives of each position component. */
/* ISTATE = ( LONG, LAT, ALT, DLONG, DLAT, DALT ) */
/* Input Boundaries */
/* ------------------------------------------- */
/* There are intervals the input angles must fall within if */
/* the input coordinate system is not rectangular. These */
/* intervals are provided below. */
/* Input variable Input meaning Input interval [rad] */
/* -------------- ------------- ------------------------ */
/* LONG Longitude 0 <= LONG < 2*pi */
/* LAT Latitude -pi/2 <= LAT <= pi/2 */
/* COLAT Colatitude 0 <= COLAT <= pi */
/* $ Examples */
/* The numerical results shown for these examples may differ across */
/* platforms. The results depend on the SPICE kernels used as */
/* input, the compiler and supporting libraries, and the machine */
/* specific arithmetic implementation. */
/* 1) Find the apparent state of Phoebe as seen by CASSINI in the */
/* J2000 frame at 2004 Jun 11 19:32:00. Transform the state */
/* from rectangular to latitudinal coordinates. For verification, */
/* transform the state back from latitudinal to rectangular */
/* coordinates. */
/* Use the meta-kernel shown below to load the required SPICE */
/* kernels. */
/* KPL/MK */
/* File name: xfmsta_ex1.tm */
/* This meta-kernel is intended to support operation of SPICE */
/* example programs. The kernels shown here should not be */
/* assumed to contain adequate or correct versions of data */
/* required by SPICE-based user applications. */
/* In order for an application to use this meta-kernel, the */
/* kernels referenced here must be present in the user's */
/* current working directory. */
/* The names and contents of the kernels referenced */
/* by this meta-kernel are as follows: */
/* File name Contents */
/* --------- -------- */
/* cpck05Mar2004.tpc Planet orientation and */
/* radii */
/* naif0009.tls Leapseconds */
/* 020514_SE_SAT105.bsp Satellite ephemeris for */
/* Saturn */
/* 030201AP_SK_SM546_T45.bsp CASSINI ephemeris */
/* 981005_PLTEPH-DE405S.bsp Planetary ephemeris */
/* \begindata */
/* KERNELS_TO_LOAD = ( 'naif0009.tls' , */
/* '020514_SE_SAT105.bsp' , */
/* '030201AP_SK_SM546_T45.bsp' , */
/* '981005_PLTEPH-DE405S.bsp', */
/* 'cpck05Mar2004.tpc' ) */
/* End of meta-kernel */
/* Example code begins here. */
/* PROGRAM EX1_XFMSTA */
/* IMPLICIT NONE */
/* C */
/* C Local parameters */
/* C */
/* C METAKR is the meta-kernel's filename. */
/* C */
/* CHARACTER*(*) METAKR */
/* PARAMETER ( METAKR = 'xfmsta_ex1.tm' ) */
/* CHARACTER*(*) FORM */
/* PARAMETER ( FORM = '(F16.6, F16.6, F16.6)' ) */
/* C */
/* C Local variables */
/* C */
/* C STAREC is the state of Phoebe with respect to CASSINI in */
/* C rectangular coordinates. STALAT is the state rotated into */
/* C latitudinal coordinates. STREC2 is the state transformed */
/* C back into rectangular coordinates from latitudinal. */
/* C */
/* DOUBLE PRECISION STAREC (6) */
/* DOUBLE PRECISION STALAT (6) */
/* DOUBLE PRECISION STREC2 (6) */
/* C */
/* C ET is the ephemeris time (TDB) corresponding to the */
/* C observation. */
/* C */
/* DOUBLE PRECISION ET */
/* DOUBLE PRECISION LT */
/* INTEGER I */
/* C */
/* C The required kernels must be loaded. */
/* C */
/* CALL FURNSH ( METAKR ) */
/* C */
/* C Calculate the state at 2004 Jun 11 19:32:00 UTC. */
/* C */
/* CALL STR2ET ( '2004-JUN-11-19:32:00', ET ) */
/* C */
/* C Calculate the apparent state of Phoebe as seen by */
/* C CASSINI in the J2000 frame. */
/* C */
/* CALL SPKEZR ( 'PHOEBE', ET, 'IAU_PHOEBE', 'LT+S', */
/* . 'CASSINI', STAREC, LT ) */
/* C */
/* C Transform the state from rectangular to latitudinal. */
/* C Notice that since neither the input nor output */
/* C coordinate frames are 'geodetic' or 'planetographic', */
/* C the input for the body name is a blank string. */
/* C */
/* CALL XFMSTA ( STAREC, 'RECTANGULAR', 'LATITUDINAL', ' ', */
/* . STALAT ) */
/* C */
/* C Transform the state back to rectangular from latitudinal */
/* C for verification. This result should be very similar to */
/* C STAREC. */
/* C */
/* CALL XFMSTA ( STALAT, 'LATITUDINAL', 'RECTANGULAR',' ', */
/* . STREC2 ) */
/* C */
/* C Report the results. */
/* C */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Phoebe as seen by CASSINI - rectangular' */
/* WRITE (*,*) ' Position [km]:' */
/* WRITE (*,FORM) (STAREC(I), I = 1, 3) */
/* WRITE (*,*) ' Velocity [km/s]:' */
/* WRITE (*,FORM) (STAREC(I), I = 4, 6) */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Phoebe as seen by CASSINI - latitudinal' */
/* WRITE (*,*) ' Position [km, rad, rad]:' */
/* WRITE (*,FORM) (STALAT(I), I = 1, 3) */
/* WRITE (*,*) ' Velocity [km/s, rad/s, rad/s]:' */
/* WRITE (*,FORM) (STALAT(I), I = 4, 6) */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Verification: ' */
/* WRITE (*,*) 'Phoebe as seen by CASSINI - rectangular' */
/* WRITE (*,*) ' Position [km]:' */
/* WRITE (*,FORM) (STREC2(I), I = 1, 3) */
/* WRITE (*,*) ' Velocity [km/s]:' */
/* WRITE (*,FORM) (STREC2(I), I = 4, 6) */
/* END */
/* When this program was executed using gfortran on a PC Linux */
/* 64 bit environment, the output was: */
/* Phoebe as seen by CASSINI - rectangular */
/* Position [km]: */
/* -1982.639762 -934.530471 -166.562595 */
/* Velocity [km/s]: */
/* 3.970832 -3.812496 -2.371663 */
/* Phoebe as seen by CASSINI - latitudinal */
/* Position [km, rad, rad]: */
/* 2198.169858 -2.701121 -0.075846 */
/* Velocity [km/s, rad/s, rad/s]: */
/* -1.780939 0.002346 -0.001144 */
/* Verification: */
/* Phoebe as seen by CASSINI - rectangular */
/* Position [km]: */
/* -1982.639762 -934.530471 -166.562595 */
/* Velocity [km/s]: */
/* 3.970832 -3.812496 -2.371663 */
/* 2) Transform a given state from cylindrical to planetographic */
/* coordinates with respect to Earth. */
/* Use the meta-kernel shown below to load the required SPICE */
/* kernels. */
/* KPL/MK */
/* File name: xfmsta_ex2.tm */
/* This meta-kernel is intended to support operation of SPICE */
/* example programs. The kernels shown here should not be */
/* assumed to contain adequate or correct versions of data */
/* required by SPICE-based user applications. */
/* In order for an application to use this meta-kernel, the */
/* kernels referenced here must be present in the user's */
/* current working directory. */
/* The names and contents of the kernels referenced */
/* by this meta-kernel are as follows: */
/* File name Contents */
/* --------- -------- */
/* cpck05Mar2004.tpc Planet orientation and */
/* radii */
/* \begindata */
/* KERNELS_TO_LOAD = ( 'cpck05Mar2004.tpc' ) */
/* \begintext */
/* End of meta-kernel */
/* Example code begins here. */
/* PROGRAM EX2_XFMSTA */
/* IMPLICIT NONE */
/* C */
/* C Local parameters */
/* C */
/* C METAKR is the meta-kernel's filename. */
/* C */
/* CHARACTER*(*) METAKR */
/* PARAMETER ( METAKR = 'xfmsta_ex2.tm' ) */
/* CHARACTER*(*) FORM */
/* PARAMETER ( FORM = '(F16.6, F16.6, F16.6)' ) */
/* C */
/* C Local variables */
/* C */
/* C STACYL is the state in cylindrical coordinates. */
/* C */
/* DOUBLE PRECISION STACYL (6) */
/* C */
/* C STAPLN is the state transformed into planetographic */
/* C coordinates. */
/* C */
/* DOUBLE PRECISION STAPLN (6) */
/* C */
/* C STCYL2 is the state transformed back into */
/* C cylindrical coordinates from planetographic. */
/* C */
/* DOUBLE PRECISION STCYL2 (6) */
/* INTEGER I */
/* DATA STACYL / 1.0D0, 0.5D0, 0.5D0, 0.2D0, 0.1D0, -0.2D0 / */
/* C */
/* C The required kernels must be loaded. */
/* C */
/* CALL FURNSH ( METAKR ) */
/* C */
/* C Transform the state from cylindrical to planetographic. */
/* C Note that since one of the coordinate systems is */
/* C planetographic, the body name must be input. */
/* C */
/* CALL XFMSTA ( STACYL, 'CYLINDRICAL', 'PLANETOGRAPHIC', */
/* . 'EARTH', STAPLN ) */
/* C */
/* C Transform the state back to cylindrical from */
/* C planetographic for verification. The result should be very */
/* C close to STACYL. */
/* C */
/* CALL XFMSTA ( STAPLN, 'PLANETOGRAPHIC', 'CYLINDRICAL', */
/* . 'EARTH', STCYL2 ) */
/* C */
/* C Report the results. */
/* C */
/* WRITE (*,*) 'Cylindrical state' */
/* WRITE (*,*) ' Position [km, rad, km]:' */
/* WRITE (*,FORM) (STACYL(I), I = 1, 3) */
/* WRITE (*,*) ' Velocity [km/s, rad/s, km/s]:' */
/* WRITE (*,FORM) (STACYL(I), I = 4, 6) */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Planetographic state' */
/* WRITE (*,*) ' Position [rad, rad, km]:' */
/* WRITE (*,FORM) (STAPLN(I), I = 1, 3) */
/* WRITE (*,*) ' Velocity [rad/s, rad/s, km/s]:' */
/* WRITE (*,FORM) (STAPLN(I), I = 4, 6) */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Verification: Cylindrical state' */
/* WRITE (*,*) ' Position [km, rad, km]:' */
/* WRITE (*,FORM) (STCYL2(I), I = 1, 3) */
/* WRITE (*,*) ' Velocity [km/s, rad/s, km/s]:' */
/* WRITE (*,FORM) (STCYL2(I), I = 4, 6) */
/* END */
/* When this program was executed using gfortran on a PC Linux */
/* 64 bit environment, the output was: */
/* Cylindrical state */
/* Position [km, rad, km]: */
/* 1.000000 0.500000 0.500000 */
/* Velocity [km/s, rad/s, km/s]: */
/* 0.200000 0.100000 -0.200000 */
/* Planetographic state */
/* Position [rad, rad, km]: */
/* 0.500000 1.547727 -6356.238467 */
/* Velocity [rad/s, rad/s, km/s]: */
/* 0.100000 -0.004721 -0.195333 */
/* Verification: Cylindrical state */
/* Position [km, rad, km]: */
/* 1.000000 0.500000 0.500000 */
/* Velocity [km/s, rad/s, km/s]: */
/* 0.200000 0.100000 -0.200000 */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* S.C. Krening (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0 22-APR-2014 (SCK)(BVS) */
/* -& */
/* $ Index_Entries */
/* state transformation between coordinate systems */
/* convert state */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Potentially large numbers produced by transforming the */
/* velocity using the Jacobian must not exceed DPMAX()/MARGIN: */
/* The size of each coordinate system name must not exceed */
/* CHSIZ characters. */
/* NCOSYS is the number of coordinate systems supported by */
/* this routine. */
/* The following integer parameters represent the coordinate */
/* systems supported by this routine. */
/* Saved body name length. */
/* Local variables */
/* COSYS is the array of supported coordinate system names. */
/* ISYSU and OSYSU are the input and output coordinate systems */
/* from the user that are made insensitive to case or leading and */
/* trailing spaces. */
/* IPOS and IVEL are the input position and velocity translated */
/* into rectangular. */
/* For transformations including either geodetic or planetographic */
/* coordinate systems, RADII is an array of the radii values */
/* associated with the input body. These values will be loaded */
/* from the kernel pool. */
/* JACOBI is the Jacobian matrix that converts the velocity */
/* coordinates between systems. */
/* The flattening coefficient, F, is calculated when either */
/* geodetic or planetographic coordinate systems are included */
/* in the transformation. */
/* SQTMP and TOOBIG are used to check for possible numeric */
/* overflow situations. */
/* BODYID and DIM are only used when the input or output coordinate */
/* systems are geodetic or planetographic. The BODYID is the NAID ID */
/* associated with the input body name. DIM is used while retrieving */
/* the radii from the kernel pool. */
/* ISYS and OSYS are the integer codes corresponding to the */
/* input and output coordinate systems. I and J are iterators. */
/* Saved name/ID item declarations. */
/* Saved variables */
/* Saved name/ID items. */
/* Assign the names of the coordinate systems to a character */
/* array in which each coordinate system name is located at */
/* the index of the integer ID of the coordinate system. */
/* Initial values. */
/* There are three main sections of this routine: */
/* 1) Error handling and initialization. */
/* 2) Conversion of the input to rectangular coordinates. */
/* 3) Conversion from rectangular to the output coordinates. */
/* Error handling and initialization */
/* ---------------------------------------------------------------- */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("XFMSTA", (ftnlen)6);
/* Initialization. */
if (first) {
/* Initialize counter. */
zzctruin_(svctr1);
first = FALSE_;
}
/* Remove initial and trailing spaces. */
/* Convert the input coordinate systems to upper case. */
ljucrs_(&c__0, icosys, isysu, icosys_len, (ftnlen)40);
ljucrs_(&c__0, ocosys, osysu, ocosys_len, (ftnlen)40);
/* Check to see if the input and output coordinate systems */
/* provided by the user are acceptable. Store the integer */
/* code of the input and output coordinate systems into */
/* ISYS and OSYS. */
isys = isrchc_(isysu, &c__6, cosys, (ftnlen)40, (ftnlen)40);
osys = isrchc_(osysu, &c__6, cosys, (ftnlen)40, (ftnlen)40);
/* If the coordinate systems are not acceptable, an error is */
/* signaled. */
if (isys == 0 || osys == 0) {
if (isys == 0 && osys == 0) {
/* Both the input and the output coordinate systems were not */
/* recognized. */
setmsg_("Input coordinate system # and output coordinate system "
"# are not recognized.", (ftnlen)76);
errch_("#", icosys, (ftnlen)1, icosys_len);
errch_("#", ocosys, (ftnlen)1, ocosys_len);
sigerr_("SPICE(COORDSYSNOTREC)", (ftnlen)21);
chkout_("XFMSTA", (ftnlen)6);
return 0;
} else if (isys == 0) {
/* The input coordinate system was not recognized. */
setmsg_("Input coordinate system # was not recognized", (ftnlen)
44);
errch_("#", icosys, (ftnlen)1, icosys_len);
sigerr_("SPICE(COORDSYSNOTREC)", (ftnlen)21);
chkout_("XFMSTA", (ftnlen)6);
return 0;
} else {
/* The output coordinate system was not recognized. */
setmsg_("Output coordinate system # was not recognized", (ftnlen)
45);
errch_("#", ocosys, (ftnlen)1, ocosys_len);
sigerr_("SPICE(COORDSYSNOTREC)", (ftnlen)21);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
}
/* If the input and output coordinate systems are equal, set the */
/* output equal to the input since no conversion needs to take */
/* place. */
if (isys == osys) {
vequg_(istate, &c__6, ostate);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* If converting to or from either geodetic or planetographic, the */
/* NAIF ID must be found from the input body name BODY. If the */
/* body name does not have a valid NAIF ID code, an error is */
/* signaled. If the NAIF ID is valid, the radii of the body are */
/* located and the flattening coefficient is calculated. */
if (osys == 5 || osys == 6 || isys == 5 || isys == 6) {
/* Find the NAIF ID code */
zzbods2c_(svctr1, svbody, &svbdid, &svfnd1, body, &bodyid, &found, (
ftnlen)36, body_len);
/* If the body's name was found, find the body's radii and */
/* compute flattening coefficient. Otherwise, signal an error. */
if (found) {
bodvcd_(&bodyid, "RADII", &c__3, &dim, radii, (ftnlen)5);
if (failed_()) {
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* If either radius is less than or equal to zero, an error is */
/* signaled. */
if (radii[2] <= 0. || radii[0] <= 0.) {
setmsg_("At least one radii is less than or equal to zero. T"
"he equatorial radius has a value of # and the polar "
"radius has has a value of #.", (ftnlen)131);
errdp_("#", radii, (ftnlen)1);
errdp_("#", &radii[2], (ftnlen)1);
sigerr_("SPICE(INVALIDRADIUS)", (ftnlen)20);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* If the difference of the equatorial and polar radii */
/* divided by the equatorial radius is greater than DPMAX, */
/* a numeric overflow may occur, so an error is signaled. */
if (sqrt((d__1 = radii[0] - radii[2], abs(d__1))) / sqrt((abs(
radii[0]))) >= sqrt(dpmax_())) {
setmsg_("The equatorial radius for # has a value of # and a "
"polar radius of #. The flattening coefficient cannot"
" be calculated due to numeric overflow.", (ftnlen)142)
;
errch_("#", body, (ftnlen)1, body_len);
errdp_("#", radii, (ftnlen)1);
errdp_("#", &radii[2], (ftnlen)1);
sigerr_("SPICE(INVALIDRADIUS)", (ftnlen)20);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
f = (radii[0] - radii[2]) / radii[0];
} else {
setmsg_("The input body name # does not have a valid NAIF ID cod"
"e.", (ftnlen)57);
errch_("#", body, (ftnlen)1, body_len);
sigerr_("SPICE(IDCODENOTFOUND)", (ftnlen)21);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
}
/* Conversion of the input to rectangular coordinates */
/* ---------------------------------------------------------------- */
/* First, the position and velocity coordinates will be converted */
/* into rectangular coordinates. If the input system is not */
/* rectangular, then the velocity coordinates must be translated */
/* into rectangular using the Jacobian. If the input system is */
/* rectangular, then the input state must simply be saved into IPOS */
/* and IVEL. */
/* TOOBIG is used for preventing numerical overflow. The square */
/* roots of values are used to safely check if overflow will occur. */
toobig = sqrt(dpmax_() / 100.);
if (isys != 1) {
/* To rectangular... */
if (isys == 2) {
/* ... from cylindrical */
cylrec_(istate, &istate[1], &istate[2], ipos);
drdcyl_(istate, &istate[1], &istate[2], jacobi);
} else if (isys == 3) {
/* ... from latitudinal */
latrec_(istate, &istate[1], &istate[2], ipos);
drdlat_(istate, &istate[1], &istate[2], jacobi);
} else if (isys == 4) {
/* ... from spherical */
sphrec_(istate, &istate[1], &istate[2], ipos);
drdsph_(istate, &istate[1], &istate[2], jacobi);
} else if (isys == 5) {
/* ... from geodetic */
georec_(istate, &istate[1], &istate[2], radii, &f, ipos);
if (failed_()) {
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
drdgeo_(istate, &istate[1], &istate[2], radii, &f, jacobi);
} else if (isys == 6) {
/* ... from planetographic */
pgrrec_(body, istate, &istate[1], &istate[2], radii, &f, ipos,
body_len);
if (failed_()) {
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
drdpgr_(body, istate, &istate[1], &istate[2], radii, &f, jacobi,
body_len);
} else {
setmsg_("This error should never occur. This is an intermediate "
"step in which a non-rectangular input state should be tr"
"ansferred to rectangular. The input coordinate system i"
"s not recognized, yet was not caught by an earlier check."
, (ftnlen)224);
sigerr_("SPICE(BUG1)", (ftnlen)11);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* Some DRD* routines are not error free. Be safe and check */
/* FAILED to not use un-initialized JACOBI. */
if (failed_()) {
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* If the multiplication of the Jacobian and velocity can cause */
/* overflow, signal an error. */
for (i__ = 1; i__ <= 3; ++i__) {
for (j = 1; j <= 3; ++j) {
sqtmp = sqrt((d__1 = jacobi[(i__1 = i__ + j * 3 - 4) < 9 && 0
<= i__1 ? i__1 : s_rnge("jacobi", i__1, "xfmsta_", (
ftnlen)1054)], abs(d__1))) * sqrt((d__2 = istate[(
i__2 = j + 2) < 6 && 0 <= i__2 ? i__2 : s_rnge("ista"
"te", i__2, "xfmsta_", (ftnlen)1054)], abs(d__2)));
if (sqtmp > toobig) {
setmsg_("The product of the Jacobian and velocity may ca"
"use numeric overflow.", (ftnlen)68);
sigerr_("SPICE(NUMERICOVERFLOW)", (ftnlen)22);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
}
}
/* Transform the velocity into rectangular coordinates. */
mxv_(jacobi, &istate[3], ivel);
} else if (isys == 1) {
/* If the input coordinate system is rectangular, the input */
/* position does not need to be translated into rectangular. */
vequ_(istate, ipos);
vequ_(&istate[3], ivel);
} else {
setmsg_("This error should never occur. This is an ELSE statement. I"
"f the input coordinate system is not rectangular, the IF sho"
"uld be executed. If the input coordinate system is rectangul"
"ar, the ELSE IF should be executed.", (ftnlen)214);
sigerr_("SPICE(BUG2)", (ftnlen)11);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* Conversion from rectangular into the output coordinates */
/* ---------------------------------------------------------------- */
/* Convert to the output coordinate system. If the output */
/* coordinate system is not rectangular, four calculations must */
/* be made: */
/* 1) Verify the position and velocity are not along the z-axis. */
/* If the position and velocity are along the z-axis, the */
/* velocity can still be converted even though the */
/* Jacobian is not defined. If the position is along the */
/* z-axis but the velocity is not, the velocity cannot be */
/* converted to the output coordinate system. */
/* 2) Calculate the Jacobian from rectangular to the output */
/* coordinate system and verify the product of the Jacobian */
/* and velocity will not cause numeric overflow. */
/* 3) Transform the position to the output coordinate system. */
/* 4) Transform the velocity to the output coordinates using */
/* the Jacobian and the rectangular velocity IVEL. */
if (osys != 1) {
/* From rectangular for the case when the input position is along */
/* the z-axis ... */
if (abs(ipos[0]) + abs(ipos[1]) == 0.) {
if (abs(ivel[0]) + abs(ivel[1]) == 0.) {
/* If the velocity is along the z-axis, then the velocity */
/* can be computed in the output coordinate frame even */
/* though the Jacobian is not defined. */
if (osys == 2) {
/* ... to cylindrical */
vpack_(&c_b56, &c_b56, &ivel[2], &ostate[3]);
reccyl_(ipos, ostate, &ostate[1], &ostate[2]);
} else if (osys == 3) {
/* ... to latitudinal */
vpack_(&ivel[2], &c_b56, &c_b56, &ostate[3]);
reclat_(ipos, ostate, &ostate[1], &ostate[2]);
} else if (osys == 4) {
/* ... to spherical */
vpack_(&ivel[2], &c_b56, &c_b56, &ostate[3]);
recsph_(ipos, ostate, &ostate[1], &ostate[2]);
} else if (osys == 5) {
/* ... to geodetic */
vpack_(&c_b56, &c_b56, &ivel[2], &ostate[3]);
recgeo_(ipos, radii, &f, ostate, &ostate[1], &ostate[2]);
} else if (osys == 6) {
/* ... to planetographic */
vpack_(&c_b56, &c_b56, &ivel[2], &ostate[3]);
recpgr_(body, ipos, radii, &f, ostate, &ostate[1], &
ostate[2], body_len);
} else {
setmsg_("This error should never occur. This is an inter"
"mediate step in which a position and velocity al"
"ong the z-axis are converted to a non-rectangula"
"r coordinate system from rectangular. The output"
" coordinate system is not recognized, yet was no"
"t caught by an earlier check.", (ftnlen)268);
sigerr_("SPICE(BUG3)", (ftnlen)11);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* The output state has been calculated for the special */
/* case of the position and velocity existing along the */
/* z-axis. */
chkout_("XFMSTA", (ftnlen)6);
return 0;
} else {
/* The Jacobian is undefined and the velocity cannot be */
/* converted since it is not along the z-axis. */
/* Signal an error. */
setmsg_("Invalid input state: z axis.", (ftnlen)28);
sigerr_("SPICE(INVALIDSTATE)", (ftnlen)19);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
}
/* From rectangular for cases when the input position is not along */
/* the z-axis ... */
if (osys == 2) {
/* ... to cylindrical */
dcyldr_(ipos, &ipos[1], &ipos[2], jacobi);
reccyl_(ipos, ostate, &ostate[1], &ostate[2]);
} else if (osys == 3) {
/* ... to latitudinal */
dlatdr_(ipos, &ipos[1], &ipos[2], jacobi);
reclat_(ipos, ostate, &ostate[1], &ostate[2]);
} else if (osys == 4) {
/* ... to spherical */
dsphdr_(ipos, &ipos[1], &ipos[2], jacobi);
recsph_(ipos, ostate, &ostate[1], &ostate[2]);
} else if (osys == 5) {
/* ... to geodetic */
dgeodr_(ipos, &ipos[1], &ipos[2], radii, &f, jacobi);
recgeo_(ipos, radii, &f, ostate, &ostate[1], &ostate[2]);
} else if (osys == 6) {
/* ... to planetographic */
dpgrdr_(body, ipos, &ipos[1], &ipos[2], radii, &f, jacobi,
body_len);
recpgr_(body, ipos, radii, &f, ostate, &ostate[1], &ostate[2],
body_len);
} else {
setmsg_("This error should never occur. This is an intermediate "
"step in which a state is converted to a non-rectangular "
"coordinate system from rectangular. The output coordinat"
"e system is not recognized, yet was not caught by an ear"
"lier check.", (ftnlen)234);
sigerr_("SPICE(BUG4)", (ftnlen)11);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* Many D*DR and REC* routines are not error free. Be safe and */
/* check FAILED to not use un-initialized JACOBI. */
if (failed_()) {
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
/* If the multiplication of the Jacobian and velocity can cause */
/* overflow, signal an error. */
for (i__ = 1; i__ <= 3; ++i__) {
for (j = 1; j <= 3; ++j) {
sqtmp = sqrt((d__1 = jacobi[(i__1 = i__ + j * 3 - 4) < 9 && 0
<= i__1 ? i__1 : s_rnge("jacobi", i__1, "xfmsta_", (
ftnlen)1314)], abs(d__1))) * sqrt((d__2 = ivel[(i__2 =
j - 1) < 3 && 0 <= i__2 ? i__2 : s_rnge("ivel", i__2,
"xfmsta_", (ftnlen)1314)], abs(d__2)));
if (sqtmp > toobig) {
setmsg_("The product of the Jacobian and velocity may ca"
"use numeric overflow.", (ftnlen)68);
sigerr_("SPICE(NUMERICOVERFLOW)", (ftnlen)22);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
}
}
/* Calculate the velocity in the output coordinate system. */
mxv_(jacobi, ivel, &ostate[3]);
} else if (osys == 1) {
/* If the output coordinate system is rectangular, the position */
/* and velocity components of the output state are set equal to */
/* the rectangular IPOS and IVEL, respectively, because the */
/* components have already been converted to rectangular. */
vequ_(ipos, ostate);
vequ_(ivel, &ostate[3]);
} else {
setmsg_("This error should never occur. This is an ELSE statement. I"
"f the output coordinate system is not rectangular, the IF sh"
"ould be executed. If the output coordinate system is rectang"
"ular, the ELSE IF should be executed.", (ftnlen)216);
sigerr_("SPICE(BUG5)", (ftnlen)11);
chkout_("XFMSTA", (ftnlen)6);
return 0;
}
chkout_("XFMSTA", (ftnlen)6);
return 0;
} /* xfmsta_ */
/* $Procedure SUBSOL ( Sub-solar point ) */
/* Subroutine */ int subsol_(char *method, char *target, doublereal *et, char
*abcorr, char *obsrvr, doublereal *spoint, ftnlen method_len, ftnlen
target_len, ftnlen abcorr_len, ftnlen obsrvr_len)
{
/* Initialized data */
static doublereal origin[3] = { 0.,0.,0. };
doublereal radii[3];
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), ltime_(doublereal *, integer *, char *, integer
*, doublereal *, doublereal *, ftnlen);
logical found;
extern logical eqstr_(char *, char *, ftnlen, ftnlen);
doublereal sunlt;
extern /* Subroutine */ int bods2c_(char *, integer *, logical *, ftnlen);
integer obscde;
doublereal lt;
extern /* Subroutine */ int bodvcd_(integer *, char *, integer *, integer
*, doublereal *, ftnlen);
integer frcode;
extern /* Subroutine */ int cidfrm_(integer *, integer *, char *, logical
*, ftnlen);
integer nradii;
char frname[80];
integer trgcde;
doublereal ettarg;
extern /* Subroutine */ int nearpt_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int spkpos_(char *, doublereal *, char *, char *,
char *, doublereal *, doublereal *, ftnlen, ftnlen, ftnlen,
ftnlen), surfpt_(doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, logical *);
doublereal alt, pos[3];
/* $ Abstract */
/* Deprecated: This routine has been superseded by the SPICELIB */
/* routine SUBSLR. This routine is supported for purposes of */
/* backward compatibility only. */
/* Determine the coordinates of the sub-solar point on a target */
/* body as seen by a specified observer at a specified epoch, */
/* optionally corrected for planetary (light time) and stellar */
/* aberration. */
/* $ 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 */
/* FRAMES */
/* PCK */
/* SPK */
/* TIME */
/* $ Keywords */
/* GEOMETRY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* METHOD I Computation method. */
/* TARGET I Name of target body. */
/* ET I Epoch in ephemeris seconds past J2000 TDB. */
/* ABCORR I Aberration correction. */
/* OBSRVR I Name of observing body. */
/* SPOINT O Sub-solar point on the target body. */
/* $ Detailed_Input */
/* METHOD is a short string specifying the computation method */
/* to be used. The choices are: */
/* 'Near point' The sub-solar point is defined */
/* as the nearest point on the */
/* target to the sun. */
/* 'Intercept' The sub-observer point is */
/* defined as the target surface */
/* intercept of the line */
/* containing the target's center */
/* and the sun's center. */
/* In both cases, the intercept computation treats the */
/* surface of the target body as a triaxial ellipsoid. */
/* The ellipsoid's radii must be available in the kernel */
/* pool. */
/* Neither case nor white space are significant in */
/* METHOD. For example, the string ' NEARPOINT' is */
/* valid. */
/* TARGET is the name of the target body. TARGET is */
/* case-insensitive, and leading and trailing blanks in */
/* TARGET are not significant. Optionally, you may */
/* supply a string containing the integer ID code for */
/* the object. For example both 'MOON' and '301' are */
/* legitimate strings that indicate the moon is the */
/* target body. */
/* This routine assumes that the target body is modeled */
/* by a tri-axial ellipsoid, and that a PCK file */
/* containing its radii has been loaded into the kernel */
/* pool via FURNSH. */
/* ET is the epoch in ephemeris seconds past J2000 at which */
/* the sub-solar point on the target body is to be */
/* computed. */
/* ABCORR indicates the aberration corrections to be applied */
/* when computing the observer-target state. ABCORR */
/* may be any of the following. */
/* 'NONE' Apply no correction. Return the */
/* geometric sub-solar point on the target */
/* body. */
/* 'LT' Correct for planetary (light time) */
/* aberration. Both the state and rotation */
/* of the target body are corrected for one */
/* way light time from target to observer. */
/* The state of the sun relative to the */
/* target is corrected for one way light */
/* from the sun to the target; this state */
/* is evaluated at the epoch obtained by */
/* retarding ET by the one way light time */
/* from target to observer. */
/* 'LT+S' Correct for planetary (light time) and */
/* stellar aberrations. Light time */
/* corrections are the same as in the 'LT' */
/* case above. The target state is */
/* additionally corrected for stellar */
/* aberration as seen by the observer, and */
/* the sun state is corrected for stellar */
/* aberration as seen from the target. */
/* 'CN' Converged Newtonian light time */
/* corrections. This is the same as LT */
/* corrections but with further iterations */
/* to a converged Newtonian light time */
/* solution. Given that relativistic */
/* effects may be as large as the higher */
/* accuracy achieved by this computation, */
/* this is correction is seldom worth the */
/* additional computations required unless */
/* the user incorporates additional */
/* relativistic corrections. Light */
/* time corrections are applied as in the */
/* 'LT' case. */
/* 'CN+S' Converged Newtonian light time */
/* corrections and stellar aberration. */
/* Light time and stellar aberration */
/* corrections are applied as in the */
/* 'LT+S' case. */
/* OBSRVR is the name of the observing body, typically a */
/* spacecraft, the earth, or a surface point on the */
/* earth. OBSRVR is case-insensitive, and leading and */
/* trailing blanks in OBSRVR are not significant. */
/* Optionally, you may supply a string containing the */
/* integer ID code for the object. For example both */
/* 'EARTH' and '399' are legitimate strings that indicate */
/* the earth is the observer. */
/* $ Detailed_Output */
/* SPOINT is the sub-solar point on the target body at ET */
/* expressed relative to the body-fixed frame of the */
/* target body. */
/* The sub-solar point is defined either as the point on */
/* the target body that is closest to the sun, or the */
/* target surface intercept of the line containing the */
/* target's center and the sun's center; the input */
/* argument METHOD selects the definition to be used. */
/* The body-fixed frame, which is time-dependent, is */
/* evaluated at ET if ABCORR is 'NONE'; otherwise the */
/* frame is evaluated at ET-LT, where LT is the one way */
/* light time from target to observer. */
/* The state of the target body is corrected for */
/* aberration as specified by ABCORR; the corrected */
/* state is used in the geometric computation. As */
/* indicated above, the rotation of the target is */
/* retarded by one way light time if ABCORR specifies */
/* that light time correction is to be done. */
/* The state of the sun as seen from the observing */
/* body is also corrected for aberration as specified */
/* by ABCORR. The corrections, when selected, are */
/* applied at the epoch ET-LT, where LT is the one way */
/* light time from target to observer. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* If any of the listed errors occur, the output arguments are */
/* left unchanged. */
/* 1) If the input argument METHOD is not recognized, the error */
/* SPICE(DUBIOUSMETHOD) is signaled. */
/* 2) If either of the input body names TARGET or OBSRVR cannot be */
/* mapped to NAIF integer codes, the error SPICE(IDCODENOTFOUND) */
/* is signaled. */
/* 3) If OBSRVR and TARGET map to the same NAIF integer ID codes, the */
/* error SPICE(BODIESNOTDISTINCT) is signaled. */
/* 4) If frame definition data enabling the evaluation of the state */
/* of the target relative to the observer in target body-fixed */
/* coordinates have not been loaded prior to calling SUBSOL, the */
/* error will be diagnosed and signaled by a routine in the call */
/* tree of this routine. */
/* 5) If the specified aberration correction is not recognized, the */
/* error will be diagnosed and signaled by a routine in the call */
/* tree of this routine. */
/* 6) If insufficient ephemeris data have been loaded prior to */
/* calling SUBSOL, the error will be diagnosed and signaled by a */
/* routine in the call tree of this routine. */
/* 7) If the triaxial radii of the target body have not been loaded */
/* into the kernel pool prior to calling SUBSOL, the error will be */
/* diagnosed and signaled by a routine in the call tree of this */
/* routine. */
/* 8) The target must be an extended body: if any of the radii of */
/* the target body are non-positive, the error will be diagnosed */
/* and signaled by routines in the call tree of this routine. */
/* 9) If PCK data supplying a rotation model for the target body */
/* have not been loaded prior to calling SUBSOL, the error will be */
/* diagnosed and signaled by a routine in the call tree of this */
/* routine. */
/* $ Files */
/* Appropriate SPK, PCK, and frame data must be available to */
/* the calling program before this routine is called. Typically */
/* the data are made available by loading kernels; however the */
/* data may be supplied via subroutine interfaces if applicable. */
/* The following data are required: */
/* - SPK data: ephemeris data for sun, target, and observer must */
/* be loaded. If aberration corrections are used, the states of */
/* sun, target, and observer relative to the solar system */
/* barycenter must be calculable from the available ephemeris */
/* data. Ephemeris data are made available by loading */
/* one or more SPK files via FURNSH. */
/* - PCK data: triaxial radii for the target body must be loaded */
/* into the kernel pool. Typically this is done by loading a */
/* text PCK file via FURNSH. */
/* - Further PCK data: a rotation model for the target body must */
/* be loaded. This may be provided in a text or binary PCK */
/* file which is loaded via FURNSH. */
/* - Frame data: if a frame definition is required to convert */
/* the sun, observer, and target states to the body-fixed frame */
/* of the target, that definition must be available in the */
/* kernel pool. Typically the definition is supplied by loading */
/* a frame kernel via FURNSH. */
/* In all cases, kernel data are normally loaded once per program */
/* run, NOT every time this routine is called. */
/* $ Particulars */
/* SUBSOL computes the sub-solar point on a target body, as seen by */
/* a specified observer. */
/* There are two different popular ways to define the sub-solar */
/* point: "nearest point on target to the sun" or "target surface */
/* intercept of line containing target and sun." These coincide */
/* when the target is spherical and generally are distinct otherwise. */
/* When comparing sub-point computations with results from sources */
/* other than SPICE, it's essential to make sure the same geometric */
/* definitions are used. */
/* $ Examples */
/* In the following example program, the file MGS.BSP is a */
/* hypothetical binary SPK ephemeris file containing data for the */
/* Mars Global Surveyor orbiter. The SPK file de405s.bsp contains */
/* data for the planet barycenters as well as the Earth, Moon, and */
/* Sun for the time period including the date 1997 Dec 31 12:000 */
/* UTC. MGS0000A.TPC is a planetary constants kernel file */
/* containing radii and rotation model constants. MGS00001.TLS is */
/* a leapseconds file. (File names shown here that are specific */
/* to MGS are not names of actual files.) */
/* IMPLICIT NONE */
/* CHARACTER*25 METHOD ( 2 ) */
/* INTEGER I */
/* DOUBLE PRECISION DPR */
/* DOUBLE PRECISION ET */
/* DOUBLE PRECISION LAT */
/* DOUBLE PRECISION LON */
/* DOUBLE PRECISION RADIUS */
/* DOUBLE PRECISION SPOINT ( 3 ) */
/* DATA METHOD / 'Intercept', 'Near point' / */
/* C */
/* C Load kernel files. */
/* C */
/* CALL FURNSH ( 'MGS00001.TLS' ) */
/* CALL FURNSH ( 'MGS0000A.TPC' ) */
/* CALL FURNSH ( 'de405s.bsp' ) */
/* CALL FURNSH ( 'MGS.BSP' ) */
/* C */
/* C Convert the UTC request time to ET (seconds past */
/* C J2000, TDB). */
/* C */
/* CALL STR2ET ( '1997 Dec 31 12:00:00', ET ) */
/* C */
/* C Compute sub-spacecraft point using light time and stellar */
/* C aberration corrections. Use the "target surface intercept" */
/* C definition of sub-spacecraft point on the first loop */
/* C iteration, and use the "near point" definition on the */
/* C second. */
/* C */
/* DO I = 1, 2 */
/* CALL SUBSOL ( METHOD(I), */
/* . 'MARS', ET, 'LT+S', 'MGS', SPOINT ) */
/* C */
/* C Convert rectangular coordinates to planetocentric */
/* C latitude and longitude. Convert radians to degrees. */
/* C */
/* CALL RECLAT ( SPOINT, RADIUS, LON, LAT ) */
/* LON = LON * DPR () */
/* LAT = LAT * DPR () */
/* C */
/* C Write the results. */
/* C */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Computation method: ', METHOD(I) */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) ' Radius (km) = ', RADIUS */
/* WRITE (*,*) ' Planetocentric Latitude (deg) = ', LAT */
/* WRITE (*,*) ' Planetocentric Longitude (deg) = ', LON */
/* WRITE (*,*) ' ' */
/* END DO */
/* END */
/* $ Restrictions */
/* The appropriate kernel data must have been loaded before this */
/* routine is called. See the Files section above. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* J.E. McLean (JPL) */
/* $ Version */
/* - SPICELIB Version 1.2.3, 18-MAY-2010 (BVS) */
/* Index line now states that this routine is deprecated. */
/* - SPICELIB Version 1.2.2, 17-MAR-2009 (EDW) */
/* Typo correction in Required_Reading, changed */
/* FRAME to FRAMES. */
/* - SPICELIB Version 1.2.1, 07-FEB-2008 (NJB) */
/* Abstract now states that this routine is deprecated. */
/* - SPICELIB Version 1.2.0, 24-OCT-2005 (NJB) */
/* Call to BODVAR was replaced with call to BODVCD. */
/* - SPICELIB Version 1.1.0, 22-JUL-2004 (NJB) */
/* Updated to support representations of integers in the input */
/* arguments TARGET and OBSRVR. Deleted references in header to */
/* kernel-specific loaders. Made miscellaneous minor corrections */
/* to header comments. */
/* - SPICELIB Version 1.0.2, 12-DEC-2002 (NJB) */
/* Corrected and updated code example in header. */
/* - SPICELIB Version 1.0.1, 1-NOV-1999 (WLT) */
/* Declared routine LTIME to be external. */
/* - SPICELIB Version 1.0.0, 03-SEP-1999 (NJB) (JEM) */
/* -& */
/* $ Index_Entries */
/* DEPRECATED sub-solar point */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 22-JUL-2004 (NJB) */
/* Updated to support representations of integers in the */
/* input arguments TARGET and OBSRVR: calls to BODN2C */
/* were replaced by calls to BODS2C. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Saved variables */
/* Initial values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SUBSOL", (ftnlen)6);
}
/* Obtain integer codes for the target and observer. */
bods2c_(target, &trgcde, &found, target_len);
if (! found) {
setmsg_("The target, '#', is not a recognized name for an ephemeris "
"object. The cause of this problem may be that you need an up"
"dated version of the SPICE Toolkit. ", (ftnlen)155);
errch_("#", target, (ftnlen)1, target_len);
sigerr_("SPICE(IDCODENOTFOUND)", (ftnlen)21);
chkout_("SUBSOL", (ftnlen)6);
return 0;
}
bods2c_(obsrvr, &obscde, &found, obsrvr_len);
if (! found) {
setmsg_("The observer, '#', is not a recognized name for an ephemeri"
"s object. The cause of this problem may be that you need an "
"updated version of the SPICE Toolkit. ", (ftnlen)157);
errch_("#", obsrvr, (ftnlen)1, obsrvr_len);
sigerr_("SPICE(IDCODENOTFOUND)", (ftnlen)21);
chkout_("SUBSOL", (ftnlen)6);
return 0;
}
/* Check the input body codes. If they are equal, signal */
/* an error. */
if (obscde == trgcde) {
setmsg_("In computing the sub-observer point, the observing body and"
" target body are the same. Both are #.", (ftnlen)97);
errch_("#", obsrvr, (ftnlen)1, obsrvr_len);
sigerr_("SPICE(BODIESNOTDISTINCT)", (ftnlen)24);
chkout_("SUBSOL", (ftnlen)6);
return 0;
}
/* Get the radii of the target body from the kernel pool. */
bodvcd_(&trgcde, "RADII", &c__3, &nradii, radii, (ftnlen)5);
/* Find the name of the body-fixed frame associated with the */
/* target body. We'll want the state of the target relative to */
/* the observer in this body-fixed frame. */
cidfrm_(&trgcde, &frcode, frname, &found, (ftnlen)80);
if (! found) {
setmsg_("No body-fixed frame is associated with target body #; a fra"
"me kernel must be loaded to make this association. Consult "
"the FRAMES Required Reading for details.", (ftnlen)159);
errch_("#", target, (ftnlen)1, target_len);
sigerr_("SPICE(NOFRAME)", (ftnlen)14);
chkout_("SUBSOL", (ftnlen)6);
return 0;
}
/* If we're using aberration corrections, we'll need the */
/* one way light time from the target to the observer. Otherwise, */
/* we set the time time to zero. */
if (eqstr_(abcorr, "NONE", abcorr_len, (ftnlen)4)) {
lt = 0.;
ettarg = *et;
} else {
ltime_(et, &obscde, "<-", &trgcde, &ettarg, <, (ftnlen)2);
}
/* Determine the position of the sun in target body-fixed */
/* coordinates. */
/* Call SPKEZ to compute the position of the sun as seen from the */
/* target body and the light time between them SUNLT. This state is */
/* evaluated at the target epoch ETTARG. We request that the */
/* coordinates of the target-sun position vector POS be returned */
/* relative to the body fixed reference frame associated with the */
/* target body, using aberration corrections specified by the input */
/* argument ABCORR. */
spkpos_("SUN", &ettarg, frname, abcorr, target, pos, &sunlt, (ftnlen)3, (
ftnlen)80, abcorr_len, target_len);
/* Find the sub-solar point using the specified geometric definition. */
if (eqstr_(method, "Near point", method_len, (ftnlen)10)) {
/* Locate the nearest point to the sun on the target. */
nearpt_(pos, radii, &radii[1], &radii[2], spoint, &alt);
} else if (eqstr_(method, "Intercept", method_len, (ftnlen)9)) {
surfpt_(origin, pos, radii, &radii[1], &radii[2], spoint, &found);
/* Since the line in question passes through the center of the */
/* target, there will always be a surface intercept. So we should */
/* never have FOUND = .FALSE. */
if (! found) {
setmsg_("Call to SURFPT returned FOUND=FALSE even though vertex "
"of ray is at target center. This indicates a bug. Please"
" contact NAIF.", (ftnlen)125);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("SUBSOL", (ftnlen)6);
return 0;
}
} else {
setmsg_("The computation method # was not recognized. Allowed values"
" are \"Near point\" and \"Intercept.\"", (ftnlen)93);
errch_("#", method, (ftnlen)1, method_len);
sigerr_("SPICE(DUBIOUSMETHOD)", (ftnlen)20);
chkout_("SUBSOL", (ftnlen)6);
return 0;
}
chkout_("SUBSOL", (ftnlen)6);
return 0;
} /* subsol_ */
/* $Procedure EKRCEC ( EK, read column entry element, character ) */
/* Subroutine */ int ekrcec_(integer *handle, integer *segno, integer *recno,
char *column, integer *nvals, char *cvals, logical *isnull, ftnlen
column_len, ftnlen cvals_len)
{
integer unit;
extern /* Subroutine */ int zzekcdsc_(integer *, integer *, char *,
integer *, ftnlen), zzeksdsc_(integer *, integer *, integer *),
zzektrdp_(integer *, integer *, integer *, integer *);
extern integer zzekesiz_(integer *, integer *, integer *, integer *);
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
integer class__, cvlen;
logical found;
integer dtype;
extern logical failed_(void);
integer coldsc[11], segdsc[24];
extern /* Subroutine */ int dashlu_(integer *, integer *);
integer recptr;
extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen), errfnm_(char *, integer *, ftnlen), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen), zzekrd03_(integer *,
integer *, integer *, integer *, integer *, char *, logical *,
ftnlen), zzekrd06_(integer *, integer *, integer *, integer *,
integer *, integer *, char *, logical *, logical *, ftnlen),
zzekrd09_(integer *, integer *, integer *, integer *, integer *,
char *, logical *, ftnlen);
/* $ Abstract */
/* Read data from a character column in a specified EK record. */
/* $ 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 */
/* FILES */
/* 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 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 attached to EK file. */
/* SEGNO I Index of segment containing record. */
/* RECNO I Record from which data is to be read. */
/* COLUMN I Column name. */
/* NVALS O Number of values in column entry. */
/* CVALS O Character values in column entry. */
/* ISNULL O Flag indicating whether column entry is null. */
/* $ Detailed_Input */
/* HANDLE is an EK file handle. The file may be open for */
/* read or write access. */
/* SEGNO is the index of the segment from which data is to */
/* be read. */
/* RECNO is the index of the record from which data is to be */
/* read. This record number is relative to the start */
/* of the segment indicated by SEGNO; the first */
/* record in the segment has index 1. */
/* COLUMN is the name of the column from which data is to be */
/* read. */
/* $ Detailed_Output */
/* NVALS, */
/* CVALS are, respectively, the number of values found in */
/* the specified column entry and the set of values */
/* themselves. The array CVALS must have sufficient */
/* string length to accommodate the longest string */
/* in the returned column entry. */
/* For columns having fixed-size entries, when a */
/* a column entry is null, NVALS is still set to the */
/* column entry size. For columns having variable- */
/* size entries, NVALS is set to 1 for null entries. */
/* ISNULL is a logical flag indicating whether the returned */
/* column entry is null. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If HANDLE is invalid, the error will be diagnosed by routines */
/* called by this routine. */
/* 2) If SEGNO is out of range, the error will diagnosed by routines */
/* called by this routine. */
/* 3) If RECNO is out of range, the error will diagnosed by routines */
/* called by this routine. */
/* 4) If COLUMN is not the name of a declared column, the error */
/* will be diagnosed by routines called by this routine. */
/* 5) If COLUMN specifies a column of whose data type is not */
/* character, the error SPICE(WRONGDATATYPE) will be */
/* signalled. */
/* 6) If COLUMN specifies a column of whose class is not */
/* a character class known to this routine, the error */
/* SPICE(NOCLASS) will be signalled. */
/* 7) If an attempt is made to read an uninitialized column entry, */
/* the error will be diagnosed by routines called by this */
/* routine. A null entry is considered to be initialized, but */
/* entries do not contain null values by default. */
/* 8) If an I/O error occurs while reading or writing the indicated */
/* file, the error will be diagnosed by routines called by this */
/* routine. */
/* 9) If any element of the column entry would be truncated when */
/* assigned to an element of CVALS, 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 is a utility that allows an EK file to be read */
/* directly without using the high-level query interface. */
/* $ Examples */
/* 1) Read the value in the third record of the column CCOL in */
/* the fifth segment of an EK file designated by HANDLE. */
/* CALL EKRCEC ( HANDLE, 5, 3, 'CCOL', N, CVAL, ISNULL ) */
/* $ Restrictions */
/* 1) EK files open for write access are not necessarily readable. */
/* In particular, a column entry can be read only if it has been */
/* initialized. The caller is responsible for determining */
/* when it is safe to read from files open for write access. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.2.0, 20-JUN-1999 (WLT) */
/* Removed unbalanced call to CHKOUT. */
/* - SPICELIB Version 1.1.0, 28-JUL-1997 (NJB) */
/* Bug fix: Record number, not record pointer, is now supplied */
/* to look up data in the class 9 case. Miscellaneous header */
/* changes were made as well. Check for string truncation on */
/* output has been added. */
/* - SPICELIB Version 1.0.0, 26-SEP-1995 (NJB) */
/* -& */
/* $ Index_Entries */
/* read character data from EK column */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 28-JUL-1997 (NJB) */
/* Bug fix: Record number, not record pointer, is now supplied */
/* to look up data in the class 9 case. For class 9 columns, */
/* column entry locations are calculated directly from record */
/* numbers, no indirection is used. */
/* Miscellaneous header changes were made as well. */
/* The routines */
/* ZZEKRD03 */
/* ZZEKRD06 */
/* ZZEKRD09 */
/* now check for string truncation on output and signal errors */
/* if truncation occurs. */
/* -& */
/* SPICELIB functions */
/* Non-SPICELIB functions */
/* Local variables */
/* Use discovery check-in. */
/* First step: find the descriptor for the named segment. Using */
/* this descriptor, get the column descriptor. */
zzeksdsc_(handle, segno, segdsc);
zzekcdsc_(handle, segdsc, column, coldsc, column_len);
if (failed_()) {
return 0;
}
/* This column had better be of character type. */
dtype = coldsc[1];
if (dtype != 1) {
chkin_("EKRCEC", (ftnlen)6);
dashlu_(handle, &unit);
setmsg_("Column # is of type #; EKRCEC only works with character col"
"umns. RECNO = #; SEGNO = #; EK = #.", (ftnlen)95);
errch_("#", column, (ftnlen)1, column_len);
errint_("#", &dtype, (ftnlen)1);
errint_("#", recno, (ftnlen)1);
errint_("#", segno, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(WRONGDATATYPE)", (ftnlen)20);
chkout_("EKRCEC", (ftnlen)6);
return 0;
}
/* Now it's time to read data from the file. Call the low-level */
/* reader appropriate to the column's class. */
class__ = coldsc[0];
if (class__ == 3) {
/* Look up the record pointer for the target record. */
zzektrdp_(handle, &segdsc[6], recno, &recptr);
zzekrd03_(handle, segdsc, coldsc, &recptr, &cvlen, cvals, isnull,
cvals_len);
*nvals = 1;
} else if (class__ == 6) {
zzektrdp_(handle, &segdsc[6], recno, &recptr);
*nvals = zzekesiz_(handle, segdsc, coldsc, &recptr);
zzekrd06_(handle, segdsc, coldsc, &recptr, &c__1, nvals, cvals,
isnull, &found, cvals_len);
} else if (class__ == 9) {
/* Records in class 9 columns are identified by a record number */
/* rather than a pointer. */
zzekrd09_(handle, segdsc, coldsc, recno, &cvlen, cvals, isnull,
cvals_len);
*nvals = 1;
} else {
/* This is an unsupported character column class. */
*segno = segdsc[1];
chkin_("EKRCEC", (ftnlen)6);
dashlu_(handle, &unit);
setmsg_("Class # from input column descriptor is not a supported cha"
"racter class. COLUMN = #; RECNO = #; SEGNO = #; EK = #.", (
ftnlen)115);
errint_("#", &class__, (ftnlen)1);
errch_("#", column, (ftnlen)1, column_len);
errint_("#", recno, (ftnlen)1);
errint_("#", segno, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(NOCLASS)", (ftnlen)14);
chkout_("EKRCEC", (ftnlen)6);
return 0;
}
return 0;
} /* ekrcec_ */
/* $Procedure INSLAC ( Insert at location in a character array ) */
/* Subroutine */ int inslac_(char *elts, integer *ne, integer *loc, char *
array, integer *na, ftnlen elts_len, ftnlen array_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer size, i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), sigerr_(char *,
ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen),
errint_(char *, integer *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Insert one or more elements into a character array at the */
/* indicated location. */
/* $ 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 */
/* ARRAY, ASSIGNMENT */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ELTS I Elements to be inserted. */
/* NE I Number of elements to be inserted. */
/* LOC I Location of the first inserted element. */
/* ARRAY I/O Input/output array. */
/* NA I/O Number of elements in the input/output array. */
/* $ Detailed_Input */
/* ELTS contains one or more elements which are to be */
/* inserted into the input array. */
/* NE is the number of elements to be inserted. */
/* LOC is the location in the array at which the first */
/* element of ELTS is to be inserted. LOC must be */
/* within the interval [1, NA+1]. To append to */
/* ARRAY, set LOC equal to NA+1. */
/* ARRAY on input, is the original array. */
/* NA on input, is the number of elements in ARRAY. */
/* $ Detailed_Output */
/* ARRAY on output, is the original array with the elements */
/* of ELT inserted into positions LOC through LOC+NE-1. */
/* The original elements in these positions are moved */
/* back to make room for the inserted elements. If the */
/* new elements are longer than the declared lengths */
/* of the elements of ARRAY, the new elements are */
/* truncated on the right. */
/* NA on output, is the number of elements in ARRAY. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* The elements in positions LOC through LOC+NE-1 are moved back */
/* by NE spaces to make room for the new elements, which are then */
/* inserted into the vacated spaces. */
/* $ Examples */
/* Let */
/* ELTS(1) = 'very' NA = 4 ARRAY(1) = 'I' */
/* ELTS(2) = 'big' ARRAY(2) = 'saw' */
/* ELTS(3) = 'brown' ARRAY(3) = 'a' */
/* ARRAY(4) = 'dog' */
/* Then the call */
/* CALL INSLAC ( ELTS, 3, 4, ARRAY, NA ) */
/* yields the following result: */
/* NA = 7 ARRAY(1) = 'I' */
/* ARRAY(2) = 'saw' */
/* ARRAY(3) = 'a' */
/* ARRAY(4) = 'very' */
/* ARRAY(5) = 'big' */
/* ARRAY(6) = 'brown' */
/* ARRAY(7) = 'dog' */
/* The following calls to INSLAC signal errors. */
/* CALL INSLAC ( ELTS, 3, -1, ARRAY, NA ) */
/* CALL INSLAC ( ELTS, 3, 6, ARRAY, NA ) */
/* CALL INSLAC ( ELTS, 3, 2, ARRAY, -1 ) */
/* CALL INSLAC ( ELTS, 3, -1, ARRAY, -1 ) */
/* $ Restrictions */
/* The array must be large enough to contain both the original */
/* and the inserted elements. */
/* $ Exceptions */
/* 1) The dimension of the array is set equal to zero if its */
/* input value is less than one. */
/* 2) If LOC is not in the interval [1, NA+1], the error */
/* SPICE(INVALIDINDEX) is signalled. */
/* 3) If the number of elements to be inserted is less than one, */
/* the array is not modified. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* I.M. Underwood (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */
/* -& */
/* $ Index_Entries */
/* insert at location in a character array */
/* -& */
/* $ Revisions */
/* - Beta Version 2.0.0, 30-DEC-1988 (HAN) */
/* If the location at which the elements are to be inserted is */
/* not in the interval [1, NA+1], an error is signalled. */
/* Locations not within that interval refer to non-exixtent */
/* array elements. (To append to the array, the location */
/* should be equal to NA+1.) */
/* A negative dimension bug was fixed. The results of the */
/* old version were unpredictable if the input array dimension */
/* was negative. To avoid this problem the maximum of zero and */
/* the input dimension becomes the dimension used by the */
/* the routine. In this case, the only valid location at which */
/* to insert is 1. If it is not 1, an error is signalled */
/* when the location is checked. */
/* -& */
/* SPICELIB functions */
/* Other functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("INSLAC", (ftnlen)6);
}
/* Check the dimension of the array. */
size = max(0,*na);
/* Make sure the location at which the elements are to be inserted */
/* is not out of range. If it is, signal an error and bail out. */
if (*loc < 1 || *loc > size + 1) {
setmsg_("Location was *.", (ftnlen)15);
errint_("*", loc, (ftnlen)1);
sigerr_("SPICE(INVALIDINDEX)", (ftnlen)19);
chkout_("INSLAC", (ftnlen)6);
return 0;
}
/* If the number of elements to be inserted is greater than zero, */
/* insert them. If not, do not modify the array. */
if (*ne > 0) {
/* Move the trailing elements back to make room for the new ones. */
i__1 = *loc;
for (i__ = size; i__ >= i__1; --i__) {
s_copy(array + (i__ + *ne - 1) * array_len, array + (i__ - 1) *
array_len, array_len, array_len);
}
/* Now put the new elements in the vacated spaces. */
i__1 = *ne;
for (i__ = 1; i__ <= i__1; ++i__) {
s_copy(array + (*loc + i__ - 2) * array_len, elts + (i__ - 1) *
elts_len, array_len, elts_len);
}
/* Update the number of elements in the array. */
*na = size + *ne;
}
chkout_("INSLAC", (ftnlen)6);
return 0;
} /* inslac_ */
/* $Procedure LNKHL ( LNK, head of list ) */
integer lnkhl_(integer *node, integer *pool)
{
/* System generated locals */
integer ret_val;
/* Local variables */
integer prev;
extern /* Subroutine */ int chkin_(char *, ftnlen), sigerr_(char *,
ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen),
errint_(char *, integer *, ftnlen);
/* $ Abstract */
/* Return the head node of the list containing a specified node. */
/* $ 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 */
/* LNK */
/* $ Keywords */
/* LIST */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* NODE I Number of a node. */
/* POOL I A doubly linked list pool. */
/* LBPOOL P Lower bound of pool column indices. */
/* The function returns the number of the head node of the list */
/* containing NODE. */
/* $ Detailed_Input */
/* NODE is the number of a node in POOL. Normally, */
/* NODE will designate an allocated node, but NODE */
/* is permitted to be less than or equal to zero. */
/* POOL is a doubly linked list pool. */
/* $ Detailed_Output */
/* The function returns the number of the head node of the list */
/* containing NODE. If NODE is non-positive, the function returns */
/* zero. */
/* $ Parameters */
/* LBPOOL is the lower bound of the column indices of the POOL */
/* array. The columns indexed LBPOOL to 0 are reserved */
/* as a control area for the pool. */
/* $ Exceptions */
/* 1) If the NODE is less than or equal to zero, NODE is not */
/* considered to be erroneous. The value 0 is returned. */
/* 2) If NODE is greater than the size of the pool, the error */
/* SPICE(INVALIDNODE) is signalled. The value 0 is returned. */
/* 3) If NODE is not the number of an allocated node, the error */
/* SPICE(UNALLOCATEDNODE) is signalled. The value 0 is returned. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine provides a convenient way to find the head of a list */
/* in a doubly linked list pool. The need to find the head of a */
/* list arises in applications such as buffer management. For */
/* example, in a system using a "least recently used" buffer */
/* replacement policy, the head of a list may point to the most */
/* recently accessed buffer element. */
/* $ Examples */
/* 1) If POOL is a doubly linked list pool that contains the list */
/* 3 <--> 7 <--> 1 <--> 44 */
/* any of function references */
/* HEAD = LNKHL ( 3, POOL ) */
/* HEAD = LNKHL ( 7, POOL ) */
/* HEAD = LNKHL ( 44, POOL ) */
/* will assign the value 3 to HEAD. */
/* 2) If POOL is a doubly linked list pool that contains the */
/* singleton list consisting of the allocated node */
/* 44 */
/* the function reference */
/* HEAD = LNKHL ( 44, POOL ) */
/* will assign the value 44 to HEAD. */
/* $ Restrictions */
/* Linked list pools must be initialized via the routine */
/* LNKINI. Failure to initialize a linked list pool */
/* will almost certainly lead to confusing results. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 19-DEC-1995 (NJB) (WLT) */
/* -& */
/* $ Index_Entries */
/* return head of linked list */
/* -& */
/* Local parameters */
/* The control area contains 3 elements. They are: */
/* The "size" of the pool, that is, the number */
/* of nodes in the pool. */
/* The number of free nodes in the pool. */
/* The "free pointer," which is the column index of the first free */
/* node. */
/* Parameters defining the row and column indices of these control */
/* elements are given below. */
/* Each assigned node consists of a backward pointer and a forward */
/* pointer. */
/* +-------------+ +-------------+ +-------------+ */
/* | forward--> | | forward--> | | forward--> | */
/* +-------------+ ... +-------------+ ... +-------------+ */
/* | <--backward | | <--backward | | <--backward | */
/* +-------------+ +-------------+ +-------------+ */
/* node 1 node I node SIZE */
/* Free nodes say that that's what they are. The way they say it */
/* is by containing the value FREE in their backward pointers. */
/* Needless to say, FREE is a value that cannot be a valid pointer. */
/* Local variables */
/* If the node is non-positive, we regard it as the nil node. */
if (*node < 1) {
ret_val = 0;
return ret_val;
/* If the node is out of range, something's very wrong. */
} else if (*node > pool[10]) {
ret_val = 0;
chkin_("LNKHL", (ftnlen)5);
setmsg_("NODE was #; valid range is 1 to #.", (ftnlen)34);
errint_("#", node, (ftnlen)1);
errint_("#", &pool[10], (ftnlen)1);
sigerr_("SPICE(INVALIDNODE)", (ftnlen)18);
chkout_("LNKHL", (ftnlen)5);
return ret_val;
/* We don't do free nodes. */
} else if (pool[(*node << 1) + 11] == 0) {
ret_val = 0;
chkin_("LNKHL", (ftnlen)5);
setmsg_("NODE was #; backward pointer = #; forward pointer = #. \"FR"
"EE\" is #)", (ftnlen)67);
errint_("#", node, (ftnlen)1);
errint_("#", &pool[(*node << 1) + 11], (ftnlen)1);
errint_("#", &pool[(*node << 1) + 10], (ftnlen)1);
errint_("#", &c__0, (ftnlen)1);
sigerr_("SPICE(UNALLOCATEDNODE)", (ftnlen)22);
chkout_("LNKHL", (ftnlen)5);
return ret_val;
}
/* Find the head of the list. */
ret_val = *node;
prev = pool[(*node << 1) + 11];
while(prev > 0) {
ret_val = prev;
prev = pool[(ret_val << 1) + 11];
}
/* LNKHL is now the head of the list. */
return ret_val;
} /* lnkhl_ */
/* $Procedure SSIZEI ( Set the size of an integer cell ) */
/* Subroutine */ int ssizei_(integer *size, integer *cell)
{
integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), sigerr_(char *,
ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen),
errint_(char *, integer *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Set the size (maximum cardinality) of an integer cell. */
/* $ 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 */
/* CELLS */
/* $ Keywords */
/* CELLS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* SIZE I Size (maximum cardinality) of the cell. */
/* CELL O The cell. */
/* $ Detailed_Input */
/* SIZE is the size (maximum number of elements) of the cell. */
/* $ Detailed_Output */
/* CELL is a cell. */
/* On output, the size of the cell is SIZE. The */
/* cardinality of the cell is 0. The rest of the */
/* control area is zeroed out. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* The set cardinality (SCARDC, SCARDD, and SCARDI) and set size */
/* (SSIZEC, SSIZED, and SSIZEI) routines are typically used to */
/* initialize cells for subsequent use. Since all cell routines */
/* expect to find the size and cardinality of a cell in place, */
/* no cell can be used until both have been set. */
/* $ Examples */
/* In the example below, the size and cardinality of the character */
/* cell FRED are set in the main module of the program FLNSTN. */
/* Both are subsequently retrieved, and the cardinality changed, */
/* in one of its subroutines, WILMA. */
/* PROGRAM FLNSTN */
/* CHARACTER*30 FRED ( LBCELL:100 ) */
/* . */
/* . */
/* CALL SSIZEC ( 100, FRED ) */
/* . */
/* . */
/* CALL WILMA ( FRED ) */
/* . */
/* . */
/* STOP */
/* END */
/* SUBROUTINE WILMA ( FRED ) */
/* CHARACTER*(*) FRED ( LBCELL:* ) */
/* INTEGER SIZE */
/* INTEGER CARD */
/* INTEGER CARDC */
/* INTEGER SIZEC */
/* . */
/* . */
/* SIZE = SIZEC ( FRED ) */
/* CARD = CARDC ( FRED ) */
/* . */
/* . */
/* CALL SCARDC ( MIN ( SIZE, CARD ), FRED ) */
/* CALL EXCESS ( CARD-SIZE, 'cell' ) */
/* . */
/* . */
/* RETURN */
/* END */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Files */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* C.A. Curzon (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (CAC) (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* set the size of an integer cell */
/* -& */
/* $ Revisions */
/* - Beta Version 2.0.0, 13-MAR-1989 (NJB) */
/* Check for invalid size value added. An error */
/* is signalled if the value is out of range. The cardinality */
/* is now automatically reset to 0. The rest of the control */
/* area is now zeroed out. */
/* The examples have been updated to illustrate set initialization */
/* without the use of the EMPTYx routines, which have been */
/* removed from the library. Errors in the examples have been */
/* removed, also. */
/* -& */
/* SPICELIB functions */
/* Local variables */
if (return_()) {
return 0;
} else {
chkin_("SSIZEI", (ftnlen)6);
}
/* The size must be non-negative. Other values will be snubbed. */
if (*size < 0) {
setmsg_("Attempt to set size of cell to invalid value. The value wa"
"s #.", (ftnlen)63);
errint_("#", size, (ftnlen)1);
sigerr_("SPICE(INVALIDSIZE)", (ftnlen)18);
chkout_("SSIZEI", (ftnlen)6);
return 0;
}
/* Not much to this. */
cell[4] = *size;
cell[5] = 0;
for (i__ = -5; i__ <= -2; ++i__) {
cell[i__ + 5] = 0;
}
chkout_("SSIZEI", (ftnlen)6);
return 0;
} /* ssizei_ */
/* $Procedure REMSUB ( Remove a substring ) */
/* Subroutine */ int remsub_(char *in, integer *left, integer *right, char *
out, ftnlen in_len, ftnlen out_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer i__, j, l, r__;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer inlen;
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
integer outlen;
extern logical return_(void);
/* $ Abstract */
/* Remove the substring (LEFT:RIGHT) from a character string. */
/* $ 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 */
/* ASSIGNMENT, CHARACTER, STRING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* IN I Input string. */
/* LEFT I Position of first character to be removed. */
/* RIGHT I Position of last character to be removed. */
/* OUT O Output string. */
/* $ Detailed_Input */
/* IN is an input character string, from which a substring */
/* is to be removed. */
/* LEFT, */
/* RIGHT are the ends of the substring to be removed. */
/* $ Detailed_Output */
/* OUT is the output string. This is equivalent to the */
/* string that would be created by the concatenation */
/* OUT = IN(1 : LEFT-1) // IN(RIGHT+1 : ) */
/* If the string is too long to fit into OUT, it is */
/* truncated on the right. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* Move the characters, beginning with RIGHT, one at a time to the */
/* positions immediately following LEFT. This has the same effect */
/* as the concatenation */
/* OUT = IN(1 : LEFT-1) // IN(RIGHT+1 : ) */
/* Because this operation is not standard for strings of length (*), */
/* this routine does not use concatenation. */
/* $ Examples */
/* The following examples illustrate the use of REMSUB. */
/* IN LEFT RIGHT OUT */
/* ----------------- ---- ----- ------------------------ */
/* 'ABCDEFGHIJ' 3 5 'ABFGHIJ' */
/* 'The best rabbit' 5 8 'The rabbit' */
/* 'The other woman' 1 4 'other woman' */
/* 'An Apple a day' 2 2 'A apple a day' */
/* 'An Apple a day' 5 2 An error is signalled. */
/* 'An Apple a day' 0 0 An error is signalled. */
/* 'An Apple a day' -3 3 An error is signalled. */
/* Whenever an error has been signalled, the contents of OUT are */
/* unpredictable. */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* If LEFT > RIGHT, RIGHT < 1, LEFT < 1, RIGHT > LEN(IN), or */
/* LEFT > LEN(IN), the error SPICE(INVALIDINDEX) is signalled. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* remove a substring */
/* -& */
/* $ Revisions */
/* - Beta Version 2.0.0, 5-JAN-1989 (HAN) */
/* Error handling was added to detect invalid character */
/* positions. If LEFT > RIGHT, RIGHT < 1, LEFT < 1, */
/* RIGHT > LEN(IN), or LEFT > LEN(IN), an error is signalled. */
/* -& */
/* SPICELIB functions */
/* Other functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("REMSUB", (ftnlen)6);
}
/* If a character position is out of range, signal an error. */
if (*left > *right || *right < 1 || *left < 1 || *right > i_len(in,
in_len) || *left > i_len(in, in_len)) {
setmsg_("Left location was *. Right location was *.", (ftnlen)42);
errint_("*", left, (ftnlen)1);
errint_("*", right, (ftnlen)1);
sigerr_("SPICE(INVALIDINDEX)", (ftnlen)19);
chkout_("REMSUB", (ftnlen)6);
return 0;
} else {
l = *left;
r__ = *right;
}
/* How much of the input string will we use? And how big is the */
/* output string? */
inlen = lastnb_(in, in_len);
outlen = i_len(out, out_len);
/* Copy the first part of the input string. (One character at a */
/* time, in case this is being done in place.) */
/* Computing MIN */
i__2 = l - 1;
i__1 = min(i__2,outlen);
for (i__ = 1; i__ <= i__1; ++i__) {
*(unsigned char *)&out[i__ - 1] = *(unsigned char *)&in[i__ - 1];
}
/* Now move the rest of the string over. */
i__ = l;
j = r__ + 1;
while(i__ <= outlen && j <= inlen) {
*(unsigned char *)&out[i__ - 1] = *(unsigned char *)&in[j - 1];
++i__;
++j;
}
/* Pad with blanks, if necessary. */
if (i__ <= outlen) {
s_copy(out + (i__ - 1), " ", out_len - (i__ - 1), (ftnlen)1);
}
chkout_("REMSUB", (ftnlen)6);
return 0;
} /* remsub_ */
/* $Procedure PCKW02 ( Write PCK segment, type 2 ) */
/* Subroutine */ int pckw02_(integer *handle, integer *body, char *frame,
doublereal *first, doublereal *last, char *segid, doublereal *intlen,
integer *n, integer *polydg, doublereal *cdata, doublereal *btime,
ftnlen frame_len, ftnlen segid_len)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer i__, k;
extern /* Subroutine */ int etcal_(doublereal *, char *, ftnlen), chkin_(
char *, ftnlen), dafps_(integer *, integer *, doublereal *,
integer *, doublereal *);
doublereal descr[5];
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
doublereal ltime;
extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen);
doublereal rsize;
char etstr[40];
extern /* Subroutine */ int dafada_(doublereal *, integer *), dafbna_(
integer *, doublereal *, char *, ftnlen), dafena_(void);
extern logical failed_(void);
extern /* Subroutine */ int chckid_(char *, integer *, char *, ftnlen,
ftnlen);
integer refcod, ninrec;
doublereal radius, numrec;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), irfnum_(char *, integer *, ftnlen), setmsg_(char *,
ftnlen), errint_(char *, integer *, ftnlen);
extern logical return_(void);
char netstr[40];
doublereal dcd[2];
integer icd[5];
doublereal mid;
/* $ Abstract */
/* Write a type 2 segment to a PCK binary file given */
/* the file handle, body, frame, time range covered by the */
/* segment, and the Chebyshev polynomial coefficeients. */
/* $ 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 */
/* NAIF_IDS */
/* SPC */
/* PCK */
/* $ Keywords */
/* PCK */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle of binary PCK file open for writing. */
/* BODY I NAIF code for ephemeris object. */
/* FRAME I Reference frame name. */
/* FIRST I Start time of interval covered by segment. */
/* LAST I End time of interval covered by segment. */
/* SEGID I Segment identifier. */
/* INTLEN I Length of time covered by logical record. */
/* N I Number of logical records in segment. */
/* POLYDG I Chebyshev polynomial degree. */
/* CDATA I Array of Chebyshev coefficients. */
/* BTIME I Begin time of first logical record. */
/* $ Detailed_Input */
/* HANDLE is the DAF handle of an PCK file to which a type 2 */
/* segment is to be added. The PCK file must be open */
/* for writing. */
/* BODY is the NAIF integer code for an ephemeris object */
/* whose orientation is described by the segment to */
/* be created. */
/* FRAME is the NAIF name for a reference frame relative to */
/* which the orientation information for BODY is */
/* specified. */
/* FIRST, */
/* LAST are, respectively, the start and stop times of */
/* the time interval over which the segment defines */
/* the orientation of body. */
/* SEGID is the segment identifier. A PCK segment */
/* identifier may contain up to 40 characters. */
/* INTLEN Length of time, in seconds, covered by each set of */
/* Chebyshev polynomial coefficients (each logical */
/* record). Each set of Chebyshev coefficents must */
/* cover this fixed time interval, INTLEN. */
/* N is the number of sets of Chebyshev polynomial */
/* coefficents (number of logical records) */
/* to be stored in the segment. There is one set */
/* of Chebyshev coefficients for each time period. */
/* POLYDG Degree of each set of Chebyshev polynomials. */
/* CDATA Array containing all the sets of Chebyshev */
/* polynomial coefficients to be contained in the */
/* segment of the PCK file. The coefficients are */
/* stored in CDATA in order as follows: */
/* the (degree + 1) coefficients for the first */
/* Euler angle of the first logical record */
/* the coefficients for the second Euler angle */
/* the coefficients for the third Euler angle */
/* the coefficients for the first Euler angle for */
/* the second logical record, ... */
/* and so on. */
/* BTIME Begin time (seconds past J2000 TDB) of first set */
/* of Chebyshev polynomial coefficients (first */
/* logical record). */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the number of sets of coefficients is not positive */
/* 'SPICE(NUMCOEFFSNOTPOS)' is signalled. */
/* 2) If the interval length is not positive, 'SPICE(INTLENNOTPOS)' */
/* is signalled. */
/* 3) If the integer code for the reference frame is not recognized, */
/* 'SPICE(INVALIDREFFRAME)' is signalled. */
/* 4) If segment stop time is not greater then the begin time, */
/* 'SPICE(BADDESCRTIMES)' is signalled. */
/* 5) If the time of the first record is not greater than */
/* or equal to the descriptor begin time, 'SPICE(BADDESCRTIMES)' */
/* is signalled. */
/* 6) If the end time of the last record is not greater than */
/* or equal to the descriptor end time, 'SPICE(BADDESCRTIMES)' is */
/* signalled. */
/* $ Files */
/* A new type 2 PCK segment is written to the PCK file attached */
/* to HANDLE. */
/* $ Particulars */
/* This routine writes an PCK type 2 data segment to the designated */
/* PCK file, according to the format described in the PCK Required */
/* Reading. */
/* Each segment can contain data for only one body and reference */
/* frame. The Chebyshev polynomial degree and length of time covered */
/* by each logical record are also fixed. However, an arbitrary */
/* number of logical records of Chebyshev polynomial coefficients can */
/* be written in each segment. Minimizing the number of segments in */
/* a PCK file will help optimize how the SPICE system accesses the */
/* file. */
/* $ Examples */
/* Suppose that you have sets of Chebyshev polynomial coefficients */
/* in an array CDATA pertaining to the position of the moon (NAIF ID */
/* = 301) in the J2000 reference frame, and want to put these into a */
/* type 2 segment in an existing PCK file. The following code could */
/* be used to add one new type 2 segment. To add multiple segments, */
/* put the call to PCKW02 in a loop. */
/* C */
/* C First open the PCK file and get a handle for it. */
/* C */
/* CALL DAFOPW ( PCKNAM, HANDLE ) */
/* C */
/* C Create a segment identifier. */
/* C */
/* SEGID = 'MY_SAMPLE_PCK_TYPE_2_SEGMENT' */
/* C */
/* C Write the segment. */
/* CALL PCKW02 ( HANDLE, 301, 'J2000', */
/* . FIRST, LAST, SEGID, INTLEN, */
/* . N, POLYDG, CDATA, BTIME) */
/* C */
/* C Close the file. */
/* C */
/* CALL DAFCLS ( HANDLE ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.S. Zukor (JPL) */
/* $ Version */
/* - SPICELIB Version 2.0.0, 1-AUG-1995 (KSZ) */
/* The calling sequence was corrected so that REF is */
/* a character string and BTIME contains only the start */
/* time of the first record. Comments updated, and new */
/* routine CHCKID is called to check segment identifier. */
/* - SPICELIB Version 1.0.0, 11-MAR-1994 (KSZ) */
/* -& */
/* $ Index_Entries */
/* write pck type_2 data segment */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 1-AUG-1995 (KSZ) */
/* The calling sequence was corrected so that REF is */
/* a character string and BTIME contains only the start */
/* time of the first record. Comments updated, and new */
/* routine CHCKID is called to check segment identifier. */
/* -& */
/* SPICELIB functions */
/* Local Parameters */
/* DTYPE is the PCK data type. */
/* NS is the size of a packed PCK segment descriptor. */
/* ND is the number of double precision components in an PCK */
/* segment descriptor. PCK uses ND = 2. */
/* NI is the number of integer components in an PCK segment */
/* descriptor. PCK uses NI = 5. */
/* SIDLEN is the maximum number of characters allowed in an */
/* PCK segment identifier. */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("PCKW02", (ftnlen)6);
}
/* The number of sets of coefficients must be positive. */
if (*n <= 0) {
setmsg_("The number of sets of Euler anglecoefficients is not positi"
"ve. N = #", (ftnlen)68);
errint_("#", n, (ftnlen)1);
sigerr_("SPICE(NUMCOEFFSNOTPOS)", (ftnlen)22);
chkout_("PCKW02", (ftnlen)6);
return 0;
}
/* The interval length must be positive. */
if (*intlen <= 0.) {
setmsg_("The interval length is not positive.N = #", (ftnlen)41);
errdp_("#", intlen, (ftnlen)1);
sigerr_("SPICE(INTLENNOTPOS)", (ftnlen)19);
chkout_("PCKW02", (ftnlen)6);
return 0;
}
/* Get the NAIF integer code for the reference frame. */
irfnum_(frame, &refcod, frame_len);
if (refcod == 0) {
setmsg_("The reference frame # is not supported.", (ftnlen)39);
errch_("#", frame, (ftnlen)1, frame_len);
sigerr_("SPICE(INVALIDREFFRAME)", (ftnlen)22);
chkout_("PCKW02", (ftnlen)6);
return 0;
}
/* The segment stop time must be greater than the begin time. */
if (*first > *last) {
setmsg_("The segment start time: # is greater than the segment end t"
"ime: #", (ftnlen)65);
etcal_(first, etstr, (ftnlen)40);
errch_("#", etstr, (ftnlen)1, (ftnlen)40);
etcal_(last, netstr, (ftnlen)40);
errch_("#", netstr, (ftnlen)1, (ftnlen)40);
sigerr_("SPICE(BADDESCRTIMES)", (ftnlen)20);
chkout_("PCKW02", (ftnlen)6);
return 0;
}
/* The begin time of the first record must be less than or equal */
/* to the begin time of the segment. */
if (*first < *btime) {
setmsg_("The segment descriptor start time: # is less than the begin"
"ning time of the segment data: #", (ftnlen)91);
etcal_(first, etstr, (ftnlen)40);
errch_("#", etstr, (ftnlen)1, (ftnlen)40);
etcal_(btime, etstr, (ftnlen)40);
errch_("#", etstr, (ftnlen)1, (ftnlen)40);
sigerr_("SPICE(BADDESCRTIMES)", (ftnlen)20);
chkout_("PCKW02", (ftnlen)6);
return 0;
}
/* The end time of the final record must be greater than or */
/* equal to the end time of the segment. */
ltime = *btime + *n * *intlen;
if (*last > ltime) {
setmsg_("The segment descriptor end time: # is greater than the end "
"time of the segment data: #", (ftnlen)86);
etcal_(last, etstr, (ftnlen)40);
errch_("#", etstr, (ftnlen)1, (ftnlen)40);
etcal_(<ime, etstr, (ftnlen)40);
errch_("#", etstr, (ftnlen)1, (ftnlen)40);
sigerr_("SPICE(BADDESCRTIMES)", (ftnlen)20);
chkout_("PCKW02", (ftnlen)6);
return 0;
}
/* Now check the validity of the segment identifier. */
chckid_("PCK segment identifier", &c__40, segid, (ftnlen)22, segid_len);
if (failed_()) {
chkout_("PCKW02", (ftnlen)6);
return 0;
}
/* Store the start and end times to be associated */
/* with this segment. */
dcd[0] = *first;
dcd[1] = *last;
/* Create the integer portion of the descriptor. */
icd[0] = *body;
icd[1] = refcod;
icd[2] = 2;
/* Pack the segment descriptor. */
dafps_(&c__2, &c__5, dcd, icd, descr);
/* Begin a new segment of PCK type 2 form: */
/* Record 1 */
/* Record 2 */
/* ... */
/* Record N */
/* INIT ( initial epoch of first record ) */
/* INTLEN ( length of interval covered by each record ) */
/* RSIZE ( number of data elements in each record ) */
/* N ( number of records in segment ) */
/* Each record will have the form: */
/* MID ( midpoint of time interval ) */
/* RADIUS ( radius of time interval ) */
/* X coefficients, Y coefficients, Z coefficients */
dafbna_(handle, descr, segid, segid_len);
/* Calculate the number of entries in a record. */
ninrec = (*polydg + 1) * 3;
/* Fill segment with N records of data. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Calculate the midpoint and radius of the time of each */
/* record, and put that at the beginning of each record. */
radius = *intlen / 2;
mid = *btime + radius + (i__ - 1) * *intlen;
dafada_(&mid, &c__1);
dafada_(&radius, &c__1);
/* Put one set of coefficients into the segment. */
k = (i__ - 1) * ninrec + 1;
dafada_(&cdata[k - 1], &ninrec);
}
/* Store the initial epoch of the first record. */
dafada_(btime, &c__1);
/* Store the length of interval covered by each record. */
dafada_(intlen, &c__1);
/* Store the size of each record (total number of array elements). */
rsize = (doublereal) (ninrec + 2);
dafada_(&rsize, &c__1);
/* Store the number of records contained in the segment. */
numrec = (doublereal) (*n);
dafada_(&numrec, &c__1);
/* End this segment. */
dafena_();
chkout_("PCKW02", (ftnlen)6);
return 0;
} /* pckw02_ */
/* $Procedure EXPFNM_1 ( Expand a filename ) */
/* Subroutine */ int expfnm_1__(char *infil, char *outfil, ftnlen infil_len,
ftnlen outfil_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen);
/* Local variables */
integer need, keep;
char word[255];
integer blank;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
integer inlen, slash;
extern integer rtrim_(char *, ftnlen);
integer dirlen;
extern /* Subroutine */ int getenv_(char *, char *, ftnlen, ftnlen);
integer wrdlen;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), repsub_(char *, integer *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen), setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen);
integer outlen;
extern logical return_(void);
char dir[255];
extern integer pos_(char *, char *, integer *, ftnlen, ftnlen);
/* $ Abstract */
/* Given a filename, expand it to be a full filename. */
/* $ 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 */
/* FILES */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* INFIL I The filename to be expanded. */
/* OUTFIL O The expanded filename. */
/* $ Detailed_Input */
/* INFIL is the filename to be expanded. */
/* $ Detailed_Output */
/* OUTFIL is the expanded filename. If no expansion could be */
/* done, the value of OUTFIL is equal to the value of */
/* INFIL. OUTFIL may not overwrite INFIL. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input filename is blank, begins with blank characters, */
/* or has embedded blanks in it, the error SPICE(BADFILENAME) */
/* is signalled. */
/* 2) If the expanded filename is too long to fit into the */
/* output string, the error SPICE(STRINGTOOSMALL) is signalled. */
/* 3) The output string may not overwrite the input string. */
/* 4) If no expansion of the input filename can be done, the */
/* output filename is assigned the value of the input filename. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The input filename may not be blank, begin with blank characters, */
/* nor may it it contain embedded blanks. As a general rule, */
/* SPICELIB routines do not allow blank characters as part of a */
/* filename. */
/* Unix platforms: */
/* On the Unix platforms, a filename containing an environment */
/* variable must be expanded completely before FORTRAN can do */
/* anything with it. FORTRAN interacts directly with the kernel, and */
/* as a result does not pass input filenames through the shell */
/* for expansion of environment variables. */
/* VAX/VMS, Alpha/OpenVMS platforms: */
/* The operating system does filname expansion itself, so this */
/* routine currently does not expand the name. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* Unix platforms: */
/* This routine cannot be used to expand a file name whose form */
/* is '~xxx', where xxx is an account name. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* $ Version */
/* - Beta Version 3.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - Beta Version 3.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - Beta Version 3.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - Beta Version 3.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - Beta Version 3.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - Beta Version 3.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - Beta Version 3.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - Beta Version 3.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - Beta Version 3.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - Beta Version 3.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - Beta Version 3.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - Beta Version 3.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - Beta Version 3.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - Beta Version 3.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - Beta Version 3.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - Beta Version 3.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - Beta Version 3.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - Beta Version 3.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - Beta Version 3.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - Beta Version 3.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - Beta Version 3.0.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - Beta Version 3.0.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are WIN-NT */
/* - Beta Version 3.0.3, 21-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - Beta Version 3.0.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - Beta Version 3.0.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - Beta Version 3.0.0, 05-APR-1998 (NJB) */
/* Added references to the PC-LINUX environment. */
/* - Beta Version 2.1.0, 5-JAN-1995 (HAN) */
/* Removed Sun Solaris environment since it is now the same */
/* as the Sun OS 4.1.x environment. */
/* Removed DEC Alpha/OpenVMS environment since it is now the */
/* same as the VAX environment. */
/* - Beta Version 2.0.0, 08-JUL-1994 (HAN) */
/* The capability of resolving a Unix filename that contains */
/* an environment variable directory specificiation plus a */
/* filename has been added. */
/* - Beta Version 1.0.0, 06-APR-1992 (HAN) */
/* -& */
/* $ Index_Entries */
/* expand a filename */
/* -& */
/* SPICELIB functions */
/* Parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("EXPFNM_1", (ftnlen)8);
}
/* If the input filename is blank, that's an error. */
if (s_cmp(infil, " ", infil_len, (ftnlen)1) == 0) {
setmsg_("The input filename '#' was blank.", (ftnlen)33);
errch_("#", infil, (ftnlen)1, infil_len);
sigerr_("SPICE(BADFILENAME)", (ftnlen)18);
chkout_("EXPFNM_1", (ftnlen)8);
return 0;
}
/* If there are blanks anywhere in the filename, SPICELIB */
/* considers the filename to be invalid. */
blank = pos_(infil, " ", &c__1, rtrim_(infil, infil_len), (ftnlen)1);
if (blank != 0) {
setmsg_("The input filename '#' had blank characters in it.", (ftnlen)
50);
errch_("#", infil, (ftnlen)1, infil_len);
sigerr_("SPICE(BADFILENAME)", (ftnlen)18);
chkout_("EXPFNM_1", (ftnlen)8);
return 0;
}
/* Look for a slash in the filename. */
slash = pos_(infil, "/", &c__1, infil_len, (ftnlen)1);
/* If we found a slash in a position other than the first */
/* character position, we want to examine the word that */
/* comes before it just in case it is an environment */
/* variable. */
if (slash > 1) {
s_copy(word, infil, (ftnlen)255, slash - 1);
getenv_(word, dir, (ftnlen)255, (ftnlen)255);
/* If the word was an environment variable, then construct */
/* the expanded filename. If it wasn't, just return the original */
/* input filename. */
if (s_cmp(dir, " ", (ftnlen)255, (ftnlen)1) != 0) {
s_copy(outfil, infil, outfil_len, infil_len);
inlen = rtrim_(infil, infil_len);
wrdlen = rtrim_(word, (ftnlen)255);
dirlen = rtrim_(dir, (ftnlen)255);
outlen = i_len(outfil, outfil_len);
keep = inlen - wrdlen;
need = keep + dirlen;
/* If the output filename length is not long enough for */
/* the substitution, signal an error. Otherwise, substitute */
/* in the new value. */
if (need > outlen) {
setmsg_("The expanded filename for the input filename '#' ex"
"ceeded the length of the output filename. The expand"
"ed name was # characters too long.", (ftnlen)137);
errch_("#", infil, (ftnlen)1, infil_len);
i__1 = need - outlen;
errint_("#", &i__1, (ftnlen)1);
sigerr_("SPICE(STRINGTOOSMALL)", (ftnlen)21);
chkout_("EXPFNM_1", (ftnlen)8);
return 0;
} else {
i__1 = slash - 1;
repsub_(infil, &c__1, &i__1, dir, outfil, infil_len, rtrim_(
dir, (ftnlen)255), outfil_len);
}
} else {
s_copy(outfil, infil, outfil_len, infil_len);
}
} else {
/* No slashes are in the filename, so it's just an easy case. */
/* It's possible that the entire filename is an environment */
/* variable. If it's not, then just return the input filename. */
getenv_(infil, outfil, infil_len, outfil_len);
if (s_cmp(outfil, " ", outfil_len, (ftnlen)1) == 0) {
s_copy(outfil, infil, outfil_len, infil_len);
}
}
chkout_("EXPFNM_1", (ftnlen)8);
return 0;
} /* expfnm_1__ */
/* $Procedure DAFT2B ( DAF, text to binary ) */
/* Subroutine */ int daft2b_(integer *text, char *binary, integer *resv,
ftnlen binary_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void), s_cmp(char *, char *, ftnlen, ftnlen), s_rnge(char *
, integer, char *, integer);
/* Local variables */
char name__[1000*2];
integer more, i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), dafps_(integer *,
integer *, doublereal *, integer *, doublereal *);
char tarch[8];
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
integer chunk, isize, lsize;
char ttype[8];
extern /* Subroutine */ int idw2at_(char *, char *, char *, ftnlen,
ftnlen, ftnlen), dafada_(doublereal *, integer *);
doublereal dc[125];
extern /* Subroutine */ int dafbna_(integer *, doublereal *, char *,
ftnlen);
integer ic[250];
extern /* Subroutine */ int dafena_(void);
integer nd;
extern logical failed_(void);
integer ni, handle;
extern /* Subroutine */ int dafcls_(integer *);
char ifname[60*2];
extern /* Subroutine */ int dafopn_(char *, integer *, integer *, char *,
integer *, integer *, ftnlen, ftnlen);
doublereal buffer[1024];
char idword[8];
extern /* Subroutine */ int errfnm_(char *, integer *, ftnlen), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
extern logical return_(void);
doublereal sum[125];
/* Fortran I/O blocks */
static cilist io___5 = { 1, 0, 1, 0, 0 };
static cilist io___6 = { 1, 0, 1, 0, 0 };
static cilist io___13 = { 1, 0, 1, 0, 0 };
static cilist io___15 = { 1, 0, 1, 0, 0 };
static cilist io___17 = { 1, 0, 1, 0, 0 };
static cilist io___20 = { 1, 0, 1, 0, 0 };
static cilist io___23 = { 1, 0, 1, 0, 0 };
static cilist io___25 = { 1, 0, 1, 0, 0 };
static cilist io___27 = { 1, 0, 1, 0, 0 };
static cilist io___28 = { 1, 0, 1, 0, 0 };
static cilist io___29 = { 1, 0, 1, 0, 0 };
static cilist io___30 = { 1, 0, 1, 0, 0 };
/* $ Abstract */
/* Deprecated. The routine DAFTB supersedes this routine. */
/* NAIF supports this routine only to provide backward */
/* compatibility. */
/* Reconstruct a binary DAF from a text file opened by */
/* the calling program. */
/* $ 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 */
/* $ Keywords */
/* FILES */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* TEXT I Logical unit connected to text file. */
/* BINARY I Name of a binary DAF to be created. */
/* RESV I Number of records to reserve. */
/* BSIZE P Buffer size. */
/* $ Detailed_Input */
/* TEXT is a logical unit number, to which a text file has */
/* been connected by the calling program, and into */
/* which the contents of binary DAF have been */
/* written. The file pointer should be placed just */
/* before the file ID word. */
/* BINARY is the name of a binary DAF to be created. */
/* The binary DAF contains the same data as the */
/* text file, but in a form more suitable for use */
/* by application programs. */
/* RESV is the number of records to be reserved in the */
/* binary DAF. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* BSIZE is the size of the buffer used to read array elements */
/* from the text file. No single group of elements should */
/* contains more than BSIZE elements. */
/* $ Exceptions */
/* 1) If for some reason the text file cannot be read, */
/* the error SPICE(DAFREADFAIL) is signalled. */
/* 2) If the architecture of the file is not DAF, as specified by */
/* the ID word, the error SPICE(NOTADAFFILE) will be signalled. */
/* 3) If the text file does not contain matching internal file */
/* names, the error SPICE(DAFNOIFNMATCH) is signalled. */
/* 4) If the text file does not contain matching array names, */
/* the error SPICE(DAFNONAMEMATCH) is signalled. */
/* 5) If the buffer size is not sufficient, the error */
/* SPICE(DAFOVERFLOW) is signalled. */
/* $ Files */
/* See arguments TEXT, BINARY. */
/* $ Particulars */
/* This routine has been made obsolete by the new DAF text to binary */
/* conversion routine DAFTB. This routine remains available for */
/* reasons of backward compatibility. We strongly recommend that you */
/* use the new conversion routines for any new software development. */
/* Please see the header of the routine DAFTB for details. */
/* This routine is necessary for converting older DAF text files into */
/* their equivalent binary formats, as DAFTB uses a different text */
/* file format that is incompatible with the text file format */
/* expected by this routine. */
/* Any binary DAF may be transferred between heterogeneous */
/* Fortran environments by converting it to an equivalent file */
/* containing only ASCII characters. Such a file can be transferred */
/* almost universally, using any number of established protocols */
/* (Kermit, FTP, and so on). Once transferred, the ASCII file can */
/* be reconverted to a binary DAF, using the representations */
/* native to the new host environment. */
/* There are two pairs of routines that can be used to convert */
/* DAFs between binary and ASCII. The first pair, DAFB2A */
/* and DAFA2B, works with complete files. That is, DAFB2A creates */
/* a complete ASCII file containing all of the information in */
/* a particular binary DAF, and nothing else; this file can */
/* be fed directly into DAFA2B to produce a complete binary DAF. */
/* In each case, the names of the files are specified. */
/* A related pair of routines, DAFB2T and DAFT2B, assume that */
/* the ASCII data are to be stored in the midst of a text file. */
/* This allows the calling program to surround the data with */
/* standardized labels, to append several binary DAFs into a */
/* single text file, and so on. */
/* Note that you must select the number of records to be reserved */
/* in the binary DAF. The contents of reserved records are ignored */
/* by the normal transfer process. */
/* $ Examples */
/* DAFB2A and DAFA2B are typically used for simple transfers. */
/* If A.DAF is a binary DAF in environment 1, it can be transferred */
/* to environment 2 in three steps. */
/* 1) Convert it to ASCII: */
/* CALL DAFB2A ( 'A.DAF', 'A.ASCII' ) */
/* 2) Transfer the ASCII file, using FTP, Kermit, or some other */
/* file transfer utility: */
/* ftp> put a.ascii */
/* 3) Convert it to binary on the new machine, */
/* CALL DAFA2B ( 'A.ASCII', 'A.DAF', RESV ) */
/* Note that DAFB2A and DAFA2B work in any standard Fortran-77 */
/* environment. */
/* If the file needs to contain other information---a standard */
/* label, for instance---the first and third steps must be modified */
/* to use DAFB2T and DAFT2B. The first step becomes */
/* (Open a text file) */
/* (Write the label) */
/* CALL DAFB2T ( BINARY, UNIT ) */
/* (Close the text file) */
/* The third step becomes */
/* (Open the text file) */
/* (Read the label) */
/* CALL DAFT2B ( UNIT, BINARY, RESV ) */
/* (Close the text file) */
/* $ Restrictions */
/* DAFT2B cannot be executed while any other DAF is open */
/* for writing. */
/* $ Literature_References */
/* NAIF Document 167.0, "Double Precision Array Files (DAF) */
/* Specification and User's Guide" */
/* $ Author_and_Institution */
/* K. R. Gehringer (JPL) */
/* J.E. McLean (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 3.0.1, 26-JUL-2012 (EDW) */
/* Edited Abstract section to use "Deprecated" keyword */
/* and state replacement routine. */
/* Eliminated unneeded Revisions section. */
/* - SPICELIB Version 3.0.0, 04-OCT-1993 (KRG) */
/* Removed the error SPICE(DAFNOIDWORD) as it was no longer */
/* relevant. */
/* Added the error SPICE(NOTADAFFILE) if this routine is called */
/* with a file that does not contain an ID word identifying the */
/* file as a DAF file. */
/* There were no checks of the IOSTAT variable after attempting to */
/* read from the text file, a single test of the IOSTAT variable */
/* was made at the end of the routine. This was not adequate to */
/* detect errors when writing to the text file. So after all of */
/* these read statements, an IF ... END IF block was added to */
/* signal an error if IOSTAT .NE. 0. */
/* IF ( IOSTAT .NE. 0 ) THEN */
/* CALL SETMSG ( 'The attempt to read from file ''#''' // */
/* . ' failed. IOSTAT = #.' ) */
/* CALL ERRFNM ( '#', UNIT ) */
/* CALL SIGERR ( 'SPICE(DAFREADFAIL)' ) */
/* CALL CHKOUT ( 'DAFT2B' ) */
/* RETURN */
/* END IF */
/* Removed the code from the end of the routine that purported to */
/* check for read errors: */
/* C */
/* C If any read screws up, they should all screw up. Why */
/* C make a billion separate checks? */
/* C */
/* IF ( IOSTAT .NE. 0 ) THEN */
/* CALL SETMSG ( 'Value of IOSTAT was: #. ' ) */
/* CALL ERRINT ( '#', IOSTAT ) */
/* CALL SIGERR ( 'SPICE(DAFREADFAIL)' ) */
/* END IF */
/* The answer to the question is: */
/* You have to do a billion separate checks because the IOSTAT */
/* value is only valid for the most recently executed read. */
/* Added a statment to the $ Particulars section to the effect */
/* that this routine has been made obsolete by the introduction of */
/* the routine DAFTB, and that we strongly recommend the use of */
/* the new routine. This routine must, however, be used when */
/* converting older text files to binary, as the old and new */
/* formats are not compatible. */
/* Modified the $ Abstract section to reflect the fact that this */
/* routine is obsolete and maintained for purposes of backward */
/* compatibility only. */
/* - SPICELIB Version 2.0.2, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 2.0.1, 6-AUG-1990 (HAN) */
/* Header documentation was corrected. This routine will */
/* convert a file containing either ID word, 'NAIF/DAF' or */
/* 'NAIF/NIP'. (Previous versions of SPICELIB software used */
/* the ID word 'NAIF/NIP'.) */
/* - SPICELIB Version 2.0.0, 2-AUG-1990 (JEM) */
/* The previous version of this routine always failed and */
/* signalled the error SPICE(DAFNOIDWORD) because of a faulty */
/* logical expression in an error-checking IF statement. */
/* The error SPICE(DAFNOIDWORD) should be signalled if the */
/* next non-blank line in the text file does not begin with the */
/* word 'NAIF/DAF' AND does not begin with the word 'NAIF/NIP'. */
/* Previously the logic was incorrect causing the error to be */
/* signalled every time no matter what the word was. The */
/* correction consisted of replacing '.OR.' with '.AND.' */
/* in the logical expression. */
/* - SPICELIB Version 1.0.1, 22-MAR-1990 (HAN) */
/* Literature references added to the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */
/* -& */
/* $ Index_Entries */
/* text daf to binary */
/* -& */
/* SPICELIB functions */
/* Local Parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("DAFT2B", (ftnlen)6);
}
s_copy(idword, " ", (ftnlen)8, (ftnlen)1);
s_copy(tarch, " ", (ftnlen)8, (ftnlen)1);
s_copy(ttype, " ", (ftnlen)8, (ftnlen)1);
/* We should be positioned and ready to read the file ID word from */
/* the text file, so let's try it. */
io___5.ciunit = *text;
iostat = s_rsle(&io___5);
if (iostat != 0) {
goto L100001;
}
iostat = do_lio(&c__9, &c__1, idword, (ftnlen)8);
if (iostat != 0) {
goto L100001;
}
iostat = e_rsle();
L100001:
if (iostat != 0) {
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
/* Split the ID word into an architecture and type, and verify that */
/* the architecture is 'DAF'. If it is not, this is the wrong */
/* routine, and an error will be signalled. */
idw2at_(idword, tarch, ttype, (ftnlen)8, (ftnlen)8, (ftnlen)8);
if (s_cmp(tarch, "DAF", (ftnlen)8, (ftnlen)3) != 0) {
setmsg_("File architecture is not 'DAF' for file '#'", (ftnlen)43);
errfnm_("#", text, (ftnlen)1);
sigerr_("SPICE(NOTADAFFILE)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
io___6.ciunit = *text;
iostat = s_rsle(&io___6);
if (iostat != 0) {
goto L100002;
}
iostat = do_lio(&c__3, &c__1, (char *)&nd, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100002;
}
iostat = do_lio(&c__3, &c__1, (char *)&ni, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100002;
}
iostat = do_lio(&c__9, &c__1, ifname, (ftnlen)60);
if (iostat != 0) {
goto L100002;
}
iostat = e_rsle();
L100002:
if (iostat != 0) {
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
/* Open the new binary file. */
dafopn_(binary, &nd, &ni, ifname, resv, &handle, binary_len, (ftnlen)60);
if (failed_()) {
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
/* Each array is preceded by a '1', which indicates that more */
/* arrays are to come. The array itself begins with the name */
/* and the summary components, and ends with the name again. */
/* The contents are written in arbitrary chunks. The final */
/* chunk is followed by a '0', which indicates that no chunks */
/* remain. The names must match, or the array should not */
/* be terminated normally. */
/* If the chunks in the file are bigger than the local buffer */
/* size, we are in trouble. */
lsize = nd + (ni - 1) / 2 + 1;
isize = lsize << 3;
io___13.ciunit = *text;
iostat = s_rsle(&io___13);
if (iostat != 0) {
goto L100003;
}
iostat = do_lio(&c__3, &c__1, (char *)&more, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100003;
}
iostat = e_rsle();
L100003:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
while(more > 0) {
io___15.ciunit = *text;
iostat = s_rsle(&io___15);
if (iostat != 0) {
goto L100004;
}
iostat = do_lio(&c__9, &c__1, name__, isize);
if (iostat != 0) {
goto L100004;
}
iostat = e_rsle();
L100004:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
io___17.ciunit = *text;
iostat = s_rsle(&io___17);
if (iostat != 0) {
goto L100005;
}
i__1 = nd;
for (i__ = 1; i__ <= i__1; ++i__) {
iostat = do_lio(&c__5, &c__1, (char *)&dc[(i__2 = i__ - 1) < 125
&& 0 <= i__2 ? i__2 : s_rnge("dc", i__2, "daft2b_", (
ftnlen)465)], (ftnlen)sizeof(doublereal));
if (iostat != 0) {
goto L100005;
}
}
iostat = e_rsle();
L100005:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
io___20.ciunit = *text;
iostat = s_rsle(&io___20);
if (iostat != 0) {
goto L100006;
}
i__2 = ni - 2;
for (i__ = 1; i__ <= i__2; ++i__) {
iostat = do_lio(&c__3, &c__1, (char *)&ic[(i__1 = i__ - 1) < 250
&& 0 <= i__1 ? i__1 : s_rnge("ic", i__1, "daft2b_", (
ftnlen)480)], (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100006;
}
}
iostat = e_rsle();
L100006:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
dafps_(&nd, &ni, dc, ic, sum);
dafbna_(&handle, sum, name__, isize);
if (failed_()) {
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
io___23.ciunit = *text;
iostat = s_rsle(&io___23);
if (iostat != 0) {
goto L100007;
}
iostat = do_lio(&c__3, &c__1, (char *)&chunk, (ftnlen)sizeof(integer))
;
if (iostat != 0) {
goto L100007;
}
iostat = e_rsle();
L100007:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
while(chunk > 0) {
if (chunk > 1024) {
dafcls_(&handle);
setmsg_("Buffer size exceeded. Increase to #.", (ftnlen)36);
errint_("#", &chunk, (ftnlen)1);
sigerr_("SPICE(DAFOVERFLOW)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
} else {
io___25.ciunit = *text;
iostat = s_rsle(&io___25);
if (iostat != 0) {
goto L100008;
}
i__1 = chunk;
for (i__ = 1; i__ <= i__1; ++i__) {
iostat = do_lio(&c__5, &c__1, (char *)&buffer[(i__2 = i__
- 1) < 1024 && 0 <= i__2 ? i__2 : s_rnge("buffer",
i__2, "daft2b_", (ftnlen)533)], (ftnlen)sizeof(
doublereal));
if (iostat != 0) {
goto L100008;
}
}
iostat = e_rsle();
L100008:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTA"
"T = #.", (ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
dafada_(buffer, &chunk);
if (failed_()) {
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
}
io___27.ciunit = *text;
iostat = s_rsle(&io___27);
if (iostat != 0) {
goto L100009;
}
iostat = do_lio(&c__3, &c__1, (char *)&chunk, (ftnlen)sizeof(
integer));
if (iostat != 0) {
goto L100009;
}
iostat = e_rsle();
L100009:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = "
"#.", (ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
}
io___28.ciunit = *text;
iostat = s_rsle(&io___28);
if (iostat != 0) {
goto L100010;
}
iostat = do_lio(&c__9, &c__1, name__ + 1000, isize);
if (iostat != 0) {
goto L100010;
}
iostat = e_rsle();
L100010:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
if (s_cmp(name__, name__ + 1000, isize, isize) != 0) {
dafcls_(&handle);
setmsg_("Array name mismatch: # and #.", (ftnlen)29);
errch_("#", name__, (ftnlen)1, isize);
errch_("#", name__ + 1000, (ftnlen)1, isize);
sigerr_("SPICE(DAFNONAMEMATCH)", (ftnlen)21);
chkout_("DAFT2B", (ftnlen)6);
return 0;
} else {
dafena_();
if (failed_()) {
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
}
io___29.ciunit = *text;
iostat = s_rsle(&io___29);
if (iostat != 0) {
goto L100011;
}
iostat = do_lio(&c__3, &c__1, (char *)&more, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100011;
}
iostat = e_rsle();
L100011:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
}
/* The final '0' indicates that no arrays remain. The first shall */
/* be last: the internal file name brings up the rear. If it doesn't */
/* match the one at the front, complain. */
io___30.ciunit = *text;
iostat = s_rsle(&io___30);
if (iostat != 0) {
goto L100012;
}
iostat = do_lio(&c__9, &c__1, ifname + 60, (ftnlen)60);
if (iostat != 0) {
goto L100012;
}
iostat = e_rsle();
L100012:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
if (s_cmp(ifname, ifname + 60, (ftnlen)60, (ftnlen)60) != 0) {
dafcls_(&handle);
setmsg_("Internal file name mismatch: # and #", (ftnlen)36);
errch_("#", ifname, (ftnlen)1, (ftnlen)60);
errch_("#", ifname + 60, (ftnlen)1, (ftnlen)60);
sigerr_("SPICE(DAFNOIFNMATCH)", (ftnlen)20);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
/* Close the DAF file we just created. */
dafcls_(&handle);
chkout_("DAFT2B", (ftnlen)6);
return 0;
} /* daft2b_ */
/* $Procedure ZZDYNFID ( Fetch frame ID kernel variable ) */
/* Subroutine */ int zzdynfid_(char *frname, integer *frcode, char *item,
integer *idcode, ftnlen frname_len, ftnlen item_len)
{
integer n;
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern logical beint_(char *, ftnlen);
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen),
repmc_(char *, char *, char *, char *, ftnlen, ftnlen, ftnlen,
ftnlen);
logical found;
extern /* Subroutine */ int repmi_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
char dtype[1];
extern integer rtrim_(char *, ftnlen);
extern logical failed_(void);
integer codeln, nameln;
char kvname[32], cdestr[32];
integer itemln, reqnam;
extern /* Subroutine */ int chkout_(char *, ftnlen);
extern logical return_(void);
char outnam[32];
integer reqnum;
extern /* Subroutine */ int intstr_(integer *, char *, ftnlen), dtpool_(
char *, logical *, integer *, char *, ftnlen, ftnlen), setmsg_(
char *, ftnlen), errint_(char *, integer *, ftnlen), sigerr_(char
*, ftnlen), gcpool_(char *, integer *, integer *, integer *, char
*, logical *, ftnlen, ftnlen), namfrm_(char *, integer *, ftnlen),
prsint_(char *, integer *, ftnlen), gipool_(char *, integer *,
integer *, integer *, integer *, logical *, ftnlen);
/* $ 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. */
/* Look up a frame definition kernel variable whose associated */
/* value is a frame name or frame ID code. The returned value is */
/* always an ID code. The kernel variable name can refer to */
/* the frame being defined by either name or ID code. */
/* If the kernel variable is not present, or if the variable */
/* is not a frame name or a numeric value, signal an error. */
/* $ 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 */
/* FRAMES */
/* KERNEL */
/* PRIVATE */
/* UTILITY */
/* $ Declarations */
/* $ Abstract */
/* Include file zzdyn.inc */
/* SPICE private file intended solely for the support of SPICE */
/* routines. Users should not include this file directly due */
/* to the volatile nature of this file */
/* The parameters defined below are used by the SPICELIB dynamic */
/* frame subsystem. */
/* $ 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 */
/* This file declares parameters required by the dynamic */
/* frame routines of the SPICELIB frame subsystem. */
/* $ Restrictions */
/* The parameter BDNMLN is this routine must be kept */
/* consistent with the parameter MAXL defined in */
/* zzbodtrn.inc */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.1.0, 12-JAN-2005 (NJB) */
/* Parameters KWX, KWY, KWZ renamed to KVX, KVY, KVZ. */
/* - SPICELIB Version 1.0.0, 22-DEC-2004 (NJB) */
/* -& */
/* String length parameters */
/* ======================== */
/* Kernel variable name length. This parameter must be */
/* kept consistent with the parameter MAXLEN used in the */
/* POOL umbrella routine. */
/* Length of a character kernel pool datum. This parameter must be */
/* kept consistent with the parameter MAXCHR used in the POOL */
/* umbrella routine. */
/* Reference frame name length. This parameter must be */
/* kept consistent with the parameter WDSIZE used in the */
/* FRAMEX umbrella routine. */
/* Body name length. This parameter is used to provide a level */
/* of indirection so the dynamic frame source code doesn't */
/* have to change if the name of this SPICELIB-scope parameter */
/* is changed. The value MAXL used here is defined in the */
/* INCLUDE file */
/* zzbodtrn.inc */
/* Current value of MAXL = 36 */
/* Numeric parameters */
/* =================================== */
/* The parameter MAXCOF is the maximum number of polynomial */
/* coefficients that may be used to define an Euler angle */
/* in an "Euler frame" definition */
/* The parameter LBSEP is the default angular separation limit for */
/* the vectors defining a two-vector frame. The angular separation */
/* of the vectors must differ from Pi and 0 by at least this amount. */
/* The parameter QEXP is used to determine the width of */
/* the interval DELTA used for the discrete differentiation */
/* of velocity in the routines ZZDYNFRM, ZZDYNROT, and their */
/* recursive analogs. This parameter is appropriate for */
/* 64-bit IEEE double precision numbers; when SPICELIB */
/* is hosted on platforms where longer mantissas are supported, */
/* this parameter (and hence this INCLUDE file) will become */
/* platform-dependent. */
/* The choice of QEXP is based on heuristics. It's believed to */
/* be a reasonable choice obtainable without expensive computation. */
/* QEXP is the largest power of 2 such that */
/* 1.D0 + 2**QEXP = 1.D0 */
/* Given an epoch T0 at which a discrete derivative is to be */
/* computed, this choice provides a value of DELTA that usually */
/* contributes no round-off error in the computation of the function */
/* evaluation epochs */
/* T0 +/- DELTA */
/* while providing the largest value of DELTA having this form that */
/* causes the order of the error term O(DELTA**2) in the quadratric */
/* function approximation to round to zero. Note that the error */
/* itself will normally be small but doesn't necessarily round to */
/* zero. Note also that the small function approximation error */
/* is not a measurement of the error in the discrete derivative */
/* itself. */
/* For ET values T0 > 2**27 seconds past J2000, the value of */
/* DELTA will be set to */
/* T0 * 2**QEXP */
/* For smaller values of T0, DELTA should be set to 1.D0. */
/* Frame kernel parameters */
/* ======================= */
/* Parameters relating to kernel variable names (keywords) start */
/* with the letters */
/* KW */
/* Parameters relating to kernel variable values start with the */
/* letters */
/* KV */
/* Generic parameters */
/* --------------------------------- */
/* Token used to build the base frame keyword: */
/* Frame definition style parameters */
/* --------------------------------- */
/* Token used to build the frame definition style keyword: */
/* Token indicating parameterized dynamic frame. */
/* Freeze epoch parameters */
/* --------------------------------- */
/* Token used to build the freeze epoch keyword: */
/* Rotation state parameters */
/* --------------------------------- */
/* Token used to build the rotation state keyword: */
/* Token indicating rotating rotation state: */
/* Token indicating inertial rotation state: */
/* Frame family parameters */
/* --------------------------------- */
/* Token used to build the frame family keyword: */
/* Token indicating mean equator and equinox of date frame. */
/* Token indicating mean ecliptic and equinox of date frame. */
/* Token indicating true equator and equinox of date frame. */
/* Token indicating two-vector frame. */
/* Token indicating Euler frame. */
/* "Of date" frame family parameters */
/* --------------------------------- */
/* Token used to build the precession model keyword: */
/* Token used to build the nutation model keyword: */
/* Token used to build the obliquity model keyword: */
/* Mathematical models used to define "of date" frames will */
/* likely accrue over time. We will simply assign them */
/* numbers. */
/* Token indicating the Lieske earth precession model: */
/* Token indicating the IAU 1980 earth nutation model: */
/* Token indicating the IAU 1980 earth mean obliqity of */
/* date model. Note the name matches that of the preceding */
/* nutation model---this is intentional. The keyword */
/* used in the kernel variable definition indicates what */
/* kind of model is being defined. */
/* Two-vector frame family parameters */
/* --------------------------------- */
/* Token used to build the vector axis keyword: */
/* Tokens indicating axis values: */
/* Prefixes used for primary and secondary vector definition */
/* keywords: */
/* Token used to build the vector definition keyword: */
/* Token indicating observer-target position vector: */
/* Token indicating observer-target velocity vector: */
/* Token indicating observer-target near point vector: */
/* Token indicating constant vector: */
/* Token used to build the vector observer keyword: */
/* Token used to build the vector target keyword: */
/* Token used to build the vector frame keyword: */
/* Token used to build the vector aberration correction keyword: */
/* Token used to build the constant vector specification keyword: */
/* Token indicating rectangular coordinates used to */
/* specify constant vector: */
/* Token indicating latitudinal coordinates used to */
/* specify constant vector: */
/* Token indicating RA/DEC coordinates used to */
/* specify constant vector: */
/* Token used to build the cartesian vector literal keyword: */
/* Token used to build the constant vector latitude keyword: */
/* Token used to build the constant vector longitude keyword: */
/* Token used to build the constant vector right ascension keyword: */
/* Token used to build the constant vector declination keyword: */
/* Token used to build the angular separation tolerance keyword: */
/* See the section "Physical unit parameters" below for additional */
/* parameters applicable to two-vector frames. */
/* Euler frame family parameters */
/* --------------------------------- */
/* Token used to build the epoch keyword: */
/* Token used to build the Euler axis sequence keyword: */
/* Tokens used to build the Euler angle coefficients keywords: */
/* See the section "Physical unit parameters" below for additional */
/* parameters applicable to Euler frames. */
/* Physical unit parameters */
/* --------------------------------- */
/* Token used to build the units keyword: */
/* Token indicating radians: */
/* Token indicating degrees: */
/* End of include file zzdyn.inc */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- ------------------------------------------------- */
/* FRNAME I Frame name. */
/* FRCODE I Frame ID code. */
/* ITEM I Item associated with frame definition. */
/* IDCODE O Output kernel variable. */
/* $ Detailed_Input */
/* FRNAME is the name of the reference frame with which */
/* the requested variable is associated. This frame */
/* may be thought of as the frame associated with */
/* "left hand side" of the kernel variable */
/* assignment. */
/* FRCODE is the frame ID code of the reference frame with */
/* which the requested variable is associated. This */
/* is the ID code corresponding to FRNAME. */
/* ITEM is a string identifying the specific datum */
/* to be fetched. The kernel variable name */
/* has the form */
/* FRAME_<frame ID code>_<ITEM> */
/* or */
/* FRAME_<frame name>_<ITEM> */
/* The former of the two names takes precedence: */
/* this routine will look for a numeric variable */
/* of that name first. */
/* The value associated with the kernel variable */
/* must be one of */
/* - a reference frame ID code */
/* - a string representation of an integer, */
/* for example '5' */
/* - a reference frame name */
/* $ Detailed_Output */
/* IDCODE is the frame ID code associated with the value of */
/* the requested kernel variable. This frame may be */
/* regarded as being associated with the "right hand */
/* side." of the kernel variable assignment. The */
/* kernel variable name of the form */
/* FRAME_<frame ID code>_<ITEM> */
/* will be looked up first; if this variable */
/* is found and has numeric type, the associated */
/* value will be returned. If this variable is */
/* found and has character type, the value will */
/* be converted to a frame ID code, and that */
/* code will be returned. */
/* If this variable is not found, the variable */
/* FRAME_<frame name>_<ITEM> */
/* will be looked up. If this variable is found and */
/* has numeric type, the associated value will be */
/* returned. If this variable is found and has */
/* character type, the value will be converted to a */
/* frame ID code, and that code will be returned. */
/* If a numeric value associated with the selected */
/* kernel variable is not integral, it will be */
/* rounded to the closest integer. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If neither the frame-ID-based or frame-name-based form of the */
/* requested kernel variable name matches a kernel variable */
/* present in the kernel pool, the error SPICE(KERNELVARNOTFOUND) */
/* will be signaled. */
/* 2) If either the frame-ID-based or frame-name-based form of the */
/* requested kernel variable name has length greater than KVNMLN, */
/* the excessively long name will not be searched for. A search */
/* will still be done using the alternative form of the name if */
/* that form has length less than or equal to KVNMLN. */
/* 3) If both the frame-ID-based and frame-name-based forms of the */
/* requested kernel variable name have length greater than KVNMLN, */
/* the error SPICE(VARNAMETOOLONG) will be signaled. */
/* 4) If kernel variable matching one form of the requested kernel */
/* variable names is found, but that variable has more than one */
/* associated value, the error SPICE(BADVARIABLESIZE) will be */
/* signaled. */
/* 5) If a name match is found for a character kernel variable, but */
/* the value associated with the variable cannot be mapped to a */
/* frame ID code or an integer, the error SPICE(NOTRANSLATION) */
/* is signaled. */
/* 6) If a name match is found for a numeric kernel variable, */
/* but that variable has a value that cannot be rounded to an */
/* integer representable on the host platform, an error will */
/* be signaled by a routine in the call tree of this routine. */
/* $ Files */
/* 1) Kernel variables fetched by this routine are normally */
/* introduced into the kernel pool by loading one or more */
/* frame kernels. See the Frames Required Reading for */
/* details. */
/* $ Particulars */
/* This routine centralizes logic for kernel variable lookups that */
/* must be performed by the SPICELIB frame subsystem. Part of the */
/* functionality of this routine consists of handling error */
/* conditions such as the unavailability of required kernel */
/* variables; hence no "found" flag is returned to the caller. */
/* As indicated above, the requested kernel variable may have a name */
/* of the form */
/* FRAME_<frame ID code>_<ITEM> */
/* or */
/* FRAME_<frame name>_<ITEM> */
/* Because most frame definition keywords have the first form, this */
/* routine looks for a name of that form first. */
/* Note that although this routine considers the two forms of the */
/* names to be synonymous, from the point of view of the kernel pool */
/* data structure, these names are distinct. Hence kernel variables */
/* having names of both forms, but having possibly different */
/* attributes, can be simultaneously present in the kernel pool. */
/* Intentional use of this kernel pool feature is discouraged. */
/* $ Examples */
/* 1) See ZZDYNFRM. */
/* 2) Applications of this routine include finding ID codes of */
/* frames associated with velocity vectors or constant vectors */
/* serving to define two-vector dynamic frames. */
/* $ Restrictions */
/* 1) This is a SPICE private routine; the routine is subject */
/* to change without notice. User applications should not */
/* call this routine. */
/* 2) An array-valued kernel variable matching the "ID code form" */
/* of the requested kernel variable name could potentially */
/* mask a scalar-valued kernel variable matching the "name */
/* form" of the requested name. This problem can be prevented */
/* by sensible frame kernel design. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 18-DEC-2004 (NJB) */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* TEMPLN is the length of the keyword template, minus */
/* the sum of the lengths of the two substitution markers ('#'). */
/* Local variables */
if (return_()) {
return 0;
}
chkin_("ZZDYNFID", (ftnlen)8);
/* Prepare to check the name of the kernel variable we're about */
/* to look up. */
/* Convert the frame code to a string. */
intstr_(frcode, cdestr, (ftnlen)32);
if (failed_()) {
chkout_("ZZDYNFID", (ftnlen)8);
return 0;
}
/* Get the lengths of the input frame code, name and item. */
/* Compute the length of the ID-based kernel variable name; */
/* check this length against the maximum allowed value. If */
/* the name is too long, proceed to look up the form of the */
/* kernel variable name based on the frame name. */
codeln = rtrim_(cdestr, (ftnlen)32);
nameln = rtrim_(frname, frname_len);
itemln = rtrim_(item, item_len);
reqnum = codeln + itemln + 7;
if (reqnum <= 32) {
/* First try looking for a kernel variable including the frame ID */
/* code. */
/* Note the template is */
/* 'FRAME_#_#' */
repmi_("FRAME_#_#", "#", frcode, kvname, (ftnlen)9, (ftnlen)1, (
ftnlen)32);
repmc_(kvname, "#", item, kvname, (ftnlen)32, (ftnlen)1, item_len, (
ftnlen)32);
dtpool_(kvname, &found, &n, dtype, (ftnlen)32, (ftnlen)1);
} else {
/* The ID-based name is too long. We can't find the variable if */
/* we can't look it up. */
found = FALSE_;
}
if (! found) {
/* We need to look up the frame name-based kernel variable. */
/* Determine the length of the name of this variable; make */
/* sure it's not too long. */
reqnam = nameln + itemln + 7;
if (reqnam > 32 && reqnum > 32) {
/* Both forms of the name are too long. */
setmsg_("Kernel variable FRAME_#_# has length #; kernel variable"
" FRAME_#_# has length #; maximum allowed length is #. N"
"either variable could be searched for in the kernel pool"
" due to these name length errors.", (ftnlen)200);
errint_("#", frcode, (ftnlen)1);
errch_("#", item, (ftnlen)1, item_len);
errint_("#", &reqnum, (ftnlen)1);
errch_("#", frname, (ftnlen)1, frname_len);
errch_("#", item, (ftnlen)1, item_len);
errint_("#", &reqnam, (ftnlen)1);
errint_("#", &c__32, (ftnlen)1);
sigerr_("SPICE(VARNAMETOOLONG)", (ftnlen)21);
chkout_("ZZDYNFID", (ftnlen)8);
return 0;
} else if (reqnam > 32) {
/* We couldn't find the variable having the ID-based name, */
/* and the frame name-based variable name is too long to */
/* look up. */
/* Note that at this point KVNAME contains the ID-based */
/* kernel variable name. */
setmsg_("Kernel variable # was expected to be present in the ker"
"nel pool but was not found. The alternative form of ker"
"nel variable name FRAME_#_# was not searched for because"
" this name has excessive length (# characters vs allowed"
" maximum of #). One of these variables is needed to def"
"ine the parameterized dynamic frame #. Usually this typ"
"e of problem is due to a missing keyword assignment in a"
" frame kernel. Another, less likely, possibility is tha"
"t other errors in a frame kernel have confused the frame"
" subsystem into wrongly deciding these variables are nee"
"ded.", (ftnlen)563);
errch_("#", kvname, (ftnlen)1, (ftnlen)32);
errch_("#", frname, (ftnlen)1, frname_len);
errch_("#", item, (ftnlen)1, item_len);
errint_("#", &reqnam, (ftnlen)1);
errint_("#", &c__32, (ftnlen)1);
errch_("#", frname, (ftnlen)1, frname_len);
sigerr_("SPICE(KERNELVARNOTFOUND)", (ftnlen)24);
chkout_("ZZDYNFID", (ftnlen)8);
return 0;
}
/* Now try looking for a kernel variable including the frame */
/* name. */
repmc_("FRAME_#_#", "#", frname, kvname, (ftnlen)9, (ftnlen)1,
frname_len, (ftnlen)32);
repmc_(kvname, "#", item, kvname, (ftnlen)32, (ftnlen)1, item_len, (
ftnlen)32);
dtpool_(kvname, &found, &n, dtype, (ftnlen)32, (ftnlen)1);
if (! found && reqnum > 32) {
/* The kernel variable's presence (in one form or the other) */
/* is mandatory: signal an error. The error message */
/* depends on which variables we were able to try to */
/* look up. In this case, we never tried to look up the */
/* frame ID-based name. */
/* Note that at this point KVNAME contains the name-based */
/* kernel variable name. */
setmsg_("Kernel variable # was expected to be present in the ker"
"nel pool but was not found. The alternative form of ker"
"nel variable name FRAME_#_# was not searched for because"
" this name has excessive length (# characters vs allowed"
" maximum of #). One of these variables is needed to def"
"ine the parameterized dynamic frame #. Usually this typ"
"e of problem is due to a missing keyword assignment in a"
" frame kernel. Another, less likely, possibility is tha"
"t other errors in a frame kernel have confused the frame"
" subsystem into wrongly deciding these variables are nee"
"ded.", (ftnlen)563);
errch_("#", kvname, (ftnlen)1, (ftnlen)32);
errint_("#", frcode, (ftnlen)1);
errch_("#", item, (ftnlen)1, item_len);
errint_("#", &reqnum, (ftnlen)1);
errint_("#", &c__32, (ftnlen)1);
errch_("#", frname, (ftnlen)1, frname_len);
sigerr_("SPICE(KERNELVARNOTFOUND)", (ftnlen)24);
chkout_("ZZDYNFID", (ftnlen)8);
return 0;
} else if (! found) {
/* We tried to look up both names and failed. */
setmsg_("At least one of the kernel variables FRAME_#_# or FRAME"
"_#_# was expected to be present in the kernel pool but n"
"either was found. One of these variables is needed to de"
"fine the parameterized dynamic frame #. Usually this ty"
"pe of problem is due to a missing keyword assignment in "
"a frame kernel. Another, less likely, possibility is th"
"at other errors in a frame kernel have confused the fram"
"e subsystem into wrongly deciding these variables are ne"
"eded.", (ftnlen)452);
errint_("#", frcode, (ftnlen)1);
errch_("#", item, (ftnlen)1, item_len);
errch_("#", frname, (ftnlen)1, frname_len);
errch_("#", item, (ftnlen)1, item_len);
errch_("#", frname, (ftnlen)1, frname_len);
sigerr_("SPICE(KERNELVARNOTFOUND)", (ftnlen)24);
chkout_("ZZDYNFID", (ftnlen)8);
return 0;
}
}
/* Getting to this point means we found a kernel variable. The name */
/* of the variable is KVNAME. The data type is DTYPE and the */
/* cardinality is N. */
if (*(unsigned char *)dtype == 'C') {
/* Rather than using BADKPV, we check the cardinality of the */
/* kernel variable in-line so we can create a more detailed error */
/* message if need be. */
if (n > 1) {
setmsg_("The kernel variable # has used to define frame # was ex"
"pected to have size not exceeding 1 but in fact has size"
" #. Usually this type of problem is due to an error in a"
" frame definition provided in a frame kernel.", (ftnlen)
212);
errch_("#", kvname, (ftnlen)1, (ftnlen)32);
errch_("#", frname, (ftnlen)1, frname_len);
errint_("#", &n, (ftnlen)1);
sigerr_("SPICE(BADVARIABLESIZE)", (ftnlen)22);
chkout_("ZZDYNFID", (ftnlen)8);
return 0;
}
/* Look up the kernel variable. */
gcpool_(kvname, &c__1, &c__1, &n, outnam, &found, (ftnlen)32, (ftnlen)
32);
if (! found) {
setmsg_("The kernel variable # has used to define frame # was no"
"t found after DTPOOL indicated it was present in pool.", (
ftnlen)109);
errch_("#", kvname, (ftnlen)1, (ftnlen)32);
errch_("#", frname, (ftnlen)1, frname_len);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZDYNFID", (ftnlen)8);
return 0;
}
/* Convert the output frame name to a frame code. */
namfrm_(outnam, idcode, (ftnlen)32);
if (*idcode == 0) {
/* If IDCODE is zero, that means NAMFRM couldn't translate */
/* the name. Perhaps the name is an integer? */
if (beint_(outnam, (ftnlen)32)) {
prsint_(outnam, idcode, (ftnlen)32);
} else {
/* We're outta aces. */
setmsg_("The kernel variable # used to define frame # is ass"
"igned the character value #. This value was expecte"
"d to be a reference frame name, but NAMFRM cannot tr"
"anslate this name to a frame ID code.", (ftnlen)192);
errch_("#", kvname, (ftnlen)1, (ftnlen)32);
errch_("#", frname, (ftnlen)1, frname_len);
errch_("#", outnam, (ftnlen)1, (ftnlen)32);
sigerr_("SPICE(NOTRANSLATION)", (ftnlen)20);
chkout_("ZZDYNFID", (ftnlen)8);
return 0;
}
}
/* IDCODE has been assigned a value at this point. */
} else {
/* The variable has numeric type. */
if (n > 1) {
setmsg_("The kernel variable # has used to define frame # was ex"
"pected to have size not exceeding 1 but in fact has size"
" #. Usually this type of problem is due to an error in a"
" frame definition provided in a frame kernel.", (ftnlen)
212);
errch_("#", kvname, (ftnlen)1, (ftnlen)32);
errch_("#", frname, (ftnlen)1, frname_len);
errint_("#", &n, (ftnlen)1);
sigerr_("SPICE(BADVARIABLESIZE)", (ftnlen)22);
chkout_("ZZDYNFID", (ftnlen)8);
return 0;
}
/* Look up the kernel variable. */
gipool_(kvname, &c__1, &c__1, &n, idcode, &found, (ftnlen)32);
if (! found) {
setmsg_("The kernel variable # has used to define frame # was no"
"t found after DTPOOL indicated it was present in pool.", (
ftnlen)109);
errch_("#", kvname, (ftnlen)1, (ftnlen)32);
errch_("#", frname, (ftnlen)1, frname_len);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZDYNFID", (ftnlen)8);
return 0;
}
}
chkout_("ZZDYNFID", (ftnlen)8);
return 0;
} /* zzdynfid_ */
/* $Procedure SPKS10 ( S/P Kernel, subset, type 10 ) */
/* Subroutine */ int spks10_(integer *srchan, doublereal *srcdsc, integer *
dsthan, doublereal *dstdsc, char *dstsid, ftnlen dstsid_len)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
char time[40];
integer i__;
extern /* Subroutine */ int etcal_(doublereal *, char *, ftnlen), chkin_(
char *, ftnlen), dafus_(doublereal *, integer *, integer *,
doublereal *, integer *), errch_(char *, char *, ftnlen, ftnlen);
doublereal dtemp[2];
logical found;
integer itemp[6];
doublereal myref;
extern /* Subroutine */ int sgwes_(integer *);
integer dummy;
extern logical failed_(void);
integer begidx;
doublereal begtim, packet[14];
integer endidx, nepoch;
doublereal endtim;
extern /* Subroutine */ int sgfcon_(integer *, doublereal *, integer *,
integer *, doublereal *), sgbwfs_(integer *, doublereal *, char *,
integer *, doublereal *, integer *, integer *, ftnlen), chkout_(
char *, ftnlen), sigerr_(char *, ftnlen), sgfrvi_(integer *,
doublereal *, doublereal *, doublereal *, integer *, logical *),
setmsg_(char *, ftnlen), sgmeta_(integer *, doublereal *, integer
*, integer *), sgfpkt_(integer *, doublereal *, integer *,
integer *, doublereal *, integer *), sgfref_(integer *,
doublereal *, integer *, integer *, doublereal *);
doublereal consts[8];
extern /* Subroutine */ int sgwfpk_(integer *, integer *, doublereal *,
integer *, doublereal *);
extern logical return_(void);
/* $ Abstract */
/* Extract a subset of the data in a type 10 SPK segment into a new */
/* type 10 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 */
/* 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. */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* SRCHAN I Handle of the SPK file with the source segment. */
/* SRCDSC I Descriptor for the source segment. */
/* DSTHAN I Handle of the SPK file for the destination segment. */
/* DSTDSC I Descriptor for the destination segment. */
/* DSTSID I Segment identifier for the new segment. */
/* $ Detailed_Input */
/* SRCHAN The handle of the SPK file containing the source segment. */
/* SRCDSC The SPK descriptor for the source segment. */
/* DSTHAN The handle of the SPK file containing the new segment. */
/* DSTDSC The SPK descriptor for the destination segment. It */
/* contains the desired start and stop times for the */
/* requested subset. */
/* DSTSID The segment identifier for the destination segment. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Files */
/* See arguments SRCHAN, DSTHAN. */
/* $ Particulars */
/* This subroutine copies a subset of the data form one SPK segment */
/* to another. */
/* The exact structure of a segment of SPK type 10 is detailed in */
/* the SPK Required Reading. Please see this document for details. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* 1) We assume that the source descriptor actually describes a */
/* segment in the source SPK file containing the time coverage */
/* that is desired for the subsetting operation. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 30-JUN-1997 (KRG) */
/* -& */
/* $ Index_Entries */
/* subset type_10 spk segment */
/* -& */
/* SPICELIB functions */
/* Local Parameters */
/* DAF ND and NI values for SPK files. */
/* The number of geophysical constants: */
/* The number of elements per two-line set: */
/* Local Variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SPKS10", (ftnlen)6);
}
/* First, unpack the destination segment descriptor and set some */
/* local variables. */
dafus_(dstdsc, &c__2, &c__6, dtemp, itemp);
begtim = dtemp[0];
endtim = dtemp[1];
/* Get the constants for the input segment and send them to the */
/* output segment by beginning a fixed packet size segment. */
sgfcon_(srchan, srcdsc, &c__1, &c__8, consts);
sgbwfs_(dsthan, dstdsc, dstsid, &c__8, consts, &c__14, &c__4, dstsid_len);
if (failed_()) {
chkout_("SPKS10", (ftnlen)6);
return 0;
}
/* Get the beginning and ending indices for the packets we need for */
/* the destination segment. Note we need to get the preceding */
/* and succeeding packets (if there are any) corresponding to the */
/* start and end times of the output segments */
sgfrvi_(srchan, srcdsc, &begtim, &myref, &begidx, &found);
if (! found) {
etcal_(&begtim, time, (ftnlen)40);
setmsg_("An error has occurred while attempting to subset the a type"
" 10 SPK segment. The error occurred while attempting to loca"
"te a packet for the epoch #. There does not appear to be su"
"ch a packet. ", (ftnlen)192);
errch_("#", time, (ftnlen)1, (ftnlen)40);
sigerr_("SPICE(CANNOTGETPACKET)", (ftnlen)22);
chkout_("SPKS10", (ftnlen)6);
return 0;
}
if (myref > begtim) {
/* Computing MAX */
i__1 = 1, i__2 = begidx - 1;
begidx = max(i__1,i__2);
}
sgfrvi_(srchan, srcdsc, &endtim, &myref, &endidx, &found);
if (! found) {
etcal_(&endtim, time, (ftnlen)40);
setmsg_("An error has occurred while attempting to subset the a type"
" 10 SPK segment. The error occurred while attempting to loca"
"te a packet for the epoch #. There does not appear to be su"
"ch a packet. ", (ftnlen)192);
errch_("#", time, (ftnlen)1, (ftnlen)40);
sigerr_("SPICE(CANNOTGETPACKET)", (ftnlen)22);
chkout_("SPKS10", (ftnlen)6);
return 0;
}
/* Get the total number of epochs. */
sgmeta_(srchan, srcdsc, &c__7, &nepoch);
if (myref < endtim) {
/* Computing MIN */
i__1 = nepoch, i__2 = endidx + 1;
endidx = min(i__1,i__2);
}
/* Now we get the data one record at a time from the source segment */
/* and write it out to the destination segment. */
i__1 = endidx;
for (i__ = begidx; i__ <= i__1; ++i__) {
sgfpkt_(srchan, srcdsc, &i__, &i__, packet, &dummy);
sgfref_(srchan, srcdsc, &i__, &i__, &myref);
sgwfpk_(dsthan, &c__1, packet, &c__1, &myref);
}
/* Now all we need to do is end the segment. */
sgwes_(dsthan);
chkout_("SPKS10", (ftnlen)6);
return 0;
} /* spks10_ */
/* $Procedure INSRTC ( Insert an item into a character set ) */
/* Subroutine */ int insrtc_(char *item, char *a, ftnlen item_len, ftnlen
a_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer i_len(char *, ftnlen), s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer card, slen, last, size, i__;
extern integer cardc_(char *, ftnlen);
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern integer sizec_(char *, ftnlen);
logical in;
extern /* Subroutine */ int scardc_(integer *, char *, ftnlen);
extern integer lstlec_(char *, integer *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Insert an item into a character set. */
/* $ 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 */
/* SETS */
/* $ Keywords */
/* CELLS, SETS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ITEM I Item to be inserted. */
/* A I/O Insertion set. */
/* $ Detailed_Input */
/* ITEM is an item which is to be inserted into the */
/* specified set. ITEM may or may not already be an */
/* element of the set. If ITEM is longer than the */
/* length SLEN of the elements of A, only the substring */
/* consisting of the first SLEN characters of ITEM will */
/* be inserted into the set; any trailing non-blank */
/* characters in ITEM are ignored. */
/* A is a set. */
/* On input, A may or may not contain the input item */
/* as an element. */
/* $ Detailed_Output */
/* A on output contains the union of the input set and */
/* the singleton set containing the input item, unless */
/* there was not sufficient room in the set for the */
/* item to be included, in which case the set is not */
/* changed and an error is signaled. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the insertion of the item into the set causes an excess */
/* of elements, the error SPICE(SETEXCESS) is signaled. */
/* 2) If the item to be inserted has greater length than the string */
/* length of the elements of the set, the item will be truncated */
/* on the right when it is inserted. The insertion point of */
/* the element will be determined by the comparison of the */
/* truncated item to members of the set. If, after truncation, */
/* the item to be inserted matches an element already present */
/* in the set, no insertion occurs. */
/* $ Files */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* In the following example, the element 'PLUTO' is removed from */
/* the character set PLANETS and inserted into the character set */
/* ASTEROIDS. */
/* CALL REMOVC ( 'PLUTO', PLANETS ) */
/* CALL INSRTC ( 'PLUTO', ASTEROIDS ) */
/* If 'PLUTO' is not an element of PLANETS, then the contents of */
/* PLANETS are not changed. Similarly, if 'PLUTO' is already an */
/* element of ASTEROIDS, the contents of ASTEROIDS remain unchanged. */
/* Because inserting an element into a set can increase the */
/* cardinality of the set, an error may occur in the insertion */
/* routines. */
/* $ Literature_References */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* C.A. Curzon (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 2.0.0, 01-NOV-2005 (NJB) */
/* Bug fix: when the item to be inserted would, after */
/* truncation to the set's string length, match an item */
/* already in the set, no insertion is performed. Previously */
/* the truncated string was inserted, corrupting the set. */
/* Long error message was updated to include size of */
/* set into which insertion was attempted. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (CAC) (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* insert an item into a character set */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 01-NOV-2005 (NJB) */
/* Bug fix: when the item to be inserted would, after */
/* truncation to the set's string length, match an item */
/* already in the set, no insertion is performed. Previously */
/* the truncated string was inserted, corrupting the set. */
/* Long error message was updated to include size of */
/* set into which insertion was attempted. */
/* - Beta Version 1.1.0, 06-JAN-1989 (NJB) */
/* Calling protocol of EXCESS changed. Call to SETMSG removed. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Set up the error processing. */
if (return_()) {
return 0;
}
chkin_("INSRTC", (ftnlen)6);
/* What are the size and cardinality of the set? */
size = sizec_(a, a_len);
card = cardc_(a, a_len);
/* When we insert an item into the set, any trailing characters */
/* that don't fit are truncated. So in deciding where to insert */
/* the item, we ignore any characters that won't remain after */
/* insertion. */
/* We're going to consider only the initial substring of ITEM */
/* whose length doesn't exceed the string length of the set's */
/* members. */
/* Computing MIN */
i__1 = i_len(item, item_len), i__2 = i_len(a + a_len * 6, a_len);
slen = min(i__1,i__2);
/* Find the last element of the set which would come before the */
/* input item. This will be the item itself, if it is already an */
/* element of the set. */
last = lstlec_(item, &card, a + a_len * 6, slen, a_len);
/* Is the item already in the set? If not, it needs to be inserted. */
if (last > 0) {
in = s_cmp(a + (last + 5) * a_len, item, a_len, slen) == 0;
} else {
in = FALSE_;
}
if (! in) {
/* If there is room in the set for the new element, then move */
/* the succeeding elements back to make room. And update the */
/* cardinality for future reference. */
if (card < size) {
i__1 = last + 1;
for (i__ = card; i__ >= i__1; --i__) {
s_copy(a + (i__ + 6) * a_len, a + (i__ + 5) * a_len, a_len,
a_len);
}
s_copy(a + (last + 6) * a_len, item, a_len, slen);
i__1 = card + 1;
scardc_(&i__1, a, a_len);
} else {
setmsg_("An element could not be inserted into the set due to la"
"ck of space; set size is #.", (ftnlen)82);
errint_("#", &size, (ftnlen)1);
sigerr_("SPICE(SETEXCESS)", (ftnlen)16);
}
}
chkout_("INSRTC", (ftnlen)6);
return 0;
} /* insrtc_ */
/* through the second ) */
/* Subroutine */ int zzgfwsts_(doublereal *wndw1, doublereal *wndw2, char *
inclsn, doublereal *wndw3, ftnlen inclsn_len)
{
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
logical keep, left, open;
integer begp1, begp2, begp3, endp1, endp2, endp3, size1, size2;
extern integer cardd_(doublereal *);
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
logical right;
extern integer sized_(doublereal *);
extern /* Subroutine */ int scardd_(integer *, doublereal *);
char locinc[2];
logical closed;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), ssized_(integer *, doublereal *), setmsg_(char *, ftnlen)
, errint_(char *, integer *, ftnlen), cmprss_(char *, integer *,
char *, char *, ftnlen, ftnlen, ftnlen);
integer maxpts, ovflow;
extern logical return_(void);
/* $ 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 those intervals of the first window that are */
/* properly contained in an interval of the second. */
/* $ 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 */
/* INTERVALS, WINDOWS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- --------------------------------------------------- */
/* WNDW1 I Input window 1. */
/* WNDW2 I Input window 2. */
/* INCLSN I Flag indicating inclusion desired. */
/* WNDW3 I/O Result of sifting WNDW1 through WNDW2. */
/* $ Detailed_Input */
/* WNDW1 is an initialized SPICELIB window */
/* WNDW2 is an initialized SPICELIB window */
/* INCLSN is a string indicating how intervals of WNDW1 must */
/* be contained in WNDW2. Allowed values are: '[]', '(]', */
/* '[)', and '()', where a square bracket represents a */
/* closed interval and a curved bracket an open interval. */
/* Suppose that [a,b] is an interval of WNDW1 and that */
/* [c,d] is an interval of WNDW2. Then the table below */
/* shows the tests used to determine the inclusion of */
/* [a,b] in the interval from c to d. */
/* [] --- [a,b] is contained in [c,d] */
/* (] --- [a,b] is contained in (c,d] */
/* [) --- [a,b] is contained in [c,d) */
/* () --- [a,b] is contained in (c,d) */
/* if INCLSN is not one of these four values, the */
/* error SPICE(UNKNOWNINCLUSION) is signaled. */
/* WNDW3 is an initialized SPICELIB window, used on input */
/* only for the purpose of determining the amount */
/* of space declared for use in WNDW3. */
/* $ Detailed_Output */
/* WNDW3 is a window consisting those of intervals in WNDW1 */
/* that are wholly contained in some interval of WNDW2. */
/* $ Parameters */
/* LBCELL is the SPICELIB cell lower bound. */
/* $ Exceptions */
/* 1) If the window WNDW3 does not have sufficient space to */
/* contain the sifting of WNDW1 through WNDW2 the error */
/* 'SPICE(OUTOFROOM)' is signaled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine allows the user to specify two closed subsets of the */
/* real line and to find the intervals of one that are contained */
/* within the intervals of another. The subsets of the real line */
/* are assumed to be made up of disjoint unions of closed intervals. */
/* $ Examples */
/* Suppose that WNDW1 and WNDW2 are described by the tables below. */
/* WNDW1 WNDW2 */
/* 12.3 12.8 11.7 13.5 */
/* 17.8 20.4 17.2 18.3 */
/* 21.4 21.7 18.5 22.6 */
/* 38.2 39.8 40.1 45.6 */
/* 44.0 59.9 */
/* Then WNDW3 will be given by: */
/* WNDW3 */
/* 12.3 12.8 */
/* 21.4 21.7 */
/* $ Restrictions */
/* The set WNDW3 must not overwrite WNDW1 or WNDW2. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* L.S. Elson (JPL) */
/* $ Version */
/* SPICELIB Version 1.0.0, 05-MAR-2009 (NJB) (LSE) (WLT) */
/* -& */
/* $ Index_Entries */
/* Find intervals of a window contained in an interval of another */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local Variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("ZZGFWSTS", (ftnlen)8);
/* Store the maximum number of endpoints that can be loaded into */
/* WNDW3 */
maxpts = sized_(wndw3);
ssized_(&maxpts, wndw3);
/* Find the number of endpoints in each of the input windows. */
size1 = cardd_(wndw1);
size2 = cardd_(wndw2);
/* Initialize the place holders for each of the input windows. */
begp1 = 1;
begp2 = 1;
endp1 = 2;
endp2 = 2;
begp3 = -1;
endp3 = 0;
cmprss_(" ", &c__0, inclsn, locinc, (ftnlen)1, inclsn_len, (ftnlen)2);
open = s_cmp(locinc, "()", (ftnlen)2, (ftnlen)2) == 0;
left = s_cmp(locinc, "[)", (ftnlen)2, (ftnlen)2) == 0;
right = s_cmp(locinc, "(]", (ftnlen)2, (ftnlen)2) == 0;
closed = s_cmp(locinc, "[]", (ftnlen)2, (ftnlen)2) == 0;
if (! (open || left || right || closed)) {
setmsg_("The value of the inclusion flag must be one of the followin"
"g: '[]', '[)', '(]', or '()'. However the value supplied wa"
"s '#'. ", (ftnlen)126);
errch_("#", inclsn, (ftnlen)1, inclsn_len);
sigerr_("SPICE(UNKNOWNINCLUSION)", (ftnlen)23);
chkout_("ZZGFWSTS", (ftnlen)8);
return 0;
}
/* We haven't had a chance to overflow yet. */
ovflow = 0;
while(begp1 < size1 && begp2 < size2) {
/* Using the current interval endpoints determine the overlap of */
/* the two intervals. */
if (wndw1[endp1 + 5] < wndw2[begp2 + 5]) {
/* the end of the first interval precedes the beginning of the */
/* second */
begp1 += 2;
endp1 += 2;
} else if (wndw2[endp2 + 5] < wndw1[begp1 + 5]) {
/* the end of the second interval precedes the beginning of the */
/* first */
begp2 += 2;
endp2 += 2;
} else {
/* the intervals intersect. Is the first contained in the */
/* second? */
if (closed) {
keep = wndw1[begp1 + 5] >= wndw2[begp2 + 5] && wndw1[endp1 +
5] <= wndw2[endp2 + 5];
} else if (open) {
keep = wndw1[begp1 + 5] > wndw2[begp2 + 5] && wndw1[endp1 + 5]
< wndw2[endp2 + 5];
} else if (left) {
keep = wndw1[begp1 + 5] >= wndw2[begp2 + 5] && wndw1[endp1 +
5] < wndw2[endp2 + 5];
} else if (right) {
keep = wndw1[begp1 + 5] > wndw2[begp2 + 5] && wndw1[endp1 + 5]
<= wndw2[endp2 + 5];
}
if (keep) {
begp3 += 2;
endp3 += 2;
if (begp3 < maxpts) {
/* Adequate room is left in WNDW3 to include this */
/* interval */
wndw3[begp3 + 5] = wndw1[begp1 + 5];
wndw3[endp3 + 5] = wndw1[endp1 + 5];
} else {
ovflow += 2;
}
}
/* Determine which window pointers to increment */
if (wndw1[endp1 + 5] < wndw2[endp2 + 5]) {
/* The first interval lies before the end of the second */
begp1 += 2;
endp1 += 2;
} else if (wndw2[endp2 + 5] < wndw1[endp1 + 5]) {
/* The second interval lies before the end of the first */
begp2 += 2;
endp2 += 2;
} else {
/* The first and second intervals end at the same place */
begp1 += 2;
endp1 += 2;
begp2 += 2;
endp2 += 2;
}
}
}
if (ovflow > 0) {
setmsg_("The output schedule does not have sufficient memory to cont"
"ain the result of sifting the two given schedules. The outpu"
"t schedule requires space for # more values than what has be"
"en provided. ", (ftnlen)192);
errint_("#", &ovflow, (ftnlen)1);
sigerr_("SPICE(OUTOFROOM)", (ftnlen)16);
} else {
scardd_(&endp3, wndw3);
}
chkout_("ZZGFWSTS", (ftnlen)8);
return 0;
} /* zzgfwsts_ */
/* $Procedure ZZSPKAP0 ( S/P Kernel, apparent state ) */
/* Subroutine */ int zzspkap0_(integer *targ, doublereal *et, char *ref,
doublereal *sobs, char *abcorr, doublereal *starg, doublereal *lt,
ftnlen ref_len, ftnlen abcorr_len)
{
/* Initialized data */
static logical first = TRUE_;
static char flags[5*9] = "NONE " "LT " "LT+S " "CN " "CN+S " "XLT "
"XLT+S" "XCN " "XCN+S";
static char prvcor[5] = " ";
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char corr[5];
extern /* Subroutine */ int zzspksb0_(integer *, doublereal *, char *,
doublereal *, ftnlen);
static logical xmit;
extern /* Subroutine */ int vequ_(doublereal *, doublereal *);
char corr2[5];
integer i__, refid;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), errch_(char *, char *, ftnlen, ftnlen), moved_(
doublereal *, integer *, doublereal *);
static logical usecn;
doublereal sapos[3];
extern /* Subroutine */ int vsubg_(doublereal *, doublereal *, integer *,
doublereal *);
static logical uselt;
extern doublereal vnorm_(doublereal *), clight_(void);
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int stelab_(doublereal *, doublereal *,
doublereal *), sigerr_(char *, ftnlen), chkout_(char *, ftnlen),
stlabx_(doublereal *, doublereal *, doublereal *);
integer ltsign;
extern /* Subroutine */ int setmsg_(char *, ftnlen), irfnum_(char *,
integer *, ftnlen);
doublereal tstate[6];
integer maxitr;
extern /* Subroutine */ int cmprss_(char *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen);
extern logical return_(void);
static logical usestl;
extern logical odd_(integer *);
/* $ 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. */
/* Return the state (position and velocity) of a target body */
/* relative to an observer, optionally corrected for light time and */
/* stellar aberration. */
/* $ 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 */
/* -------- --- -------------------------------------------------- */
/* TARG I Target body. */
/* ET I Observer epoch. */
/* REF I Inertial reference frame of observer's state. */
/* SOBS I State of observer wrt. solar system barycenter. */
/* ABCORR I Aberration correction flag. */
/* STARG O State of target. */
/* LT O One way light time between observer and target. */
/* $ Detailed_Input */
/* TARG is the NAIF ID code for a target body. The target */
/* and observer define a state vector whose position */
/* component points from the observer to the target. */
/* ET is the ephemeris time, expressed as seconds past J2000 */
/* TDB, at which the state of the target body relative to */
/* the observer is to be computed. ET refers to time at */
/* the observer's location. */
/* REF is the inertial reference frame with respect to which */
/* the observer's state SOBS is expressed. REF must be */
/* recognized by the SPICE Toolkit. The acceptable */
/* frames are listed in the Frames Required Reading, as */
/* well as in the SPICELIB routine CHGIRF. */
/* Case and blanks are not significant in the string REF. */
/* SOBS is the geometric (uncorrected) state of the observer */
/* relative to the solar system barycenter at epoch ET. */
/* SOBS is a 6-vector: the first three components of */
/* SOBS represent a Cartesian position vector; the last */
/* three components represent the corresponding velocity */
/* vector. SOBS is expressed relative to the inertial */
/* reference frame designated by REF. */
/* Units are always km and km/sec. */
/* ABCORR indicates the aberration corrections to be applied */
/* to the state of the target body to account for one-way */
/* light time and stellar aberration. See the discussion */
/* in the Particulars section for recommendations on */
/* how to choose aberration corrections. */
/* ABCORR may be any of the following: */
/* 'NONE' Apply no correction. Return the */
/* geometric state of the target body */
/* relative to the observer. */
/* The following values of ABCORR apply to the */
/* "reception" case in which photons depart from the */
/* target's location at the light-time corrected epoch */
/* ET-LT and *arrive* at the observer's location at ET: */
/* 'LT' Correct for one-way light time (also */
/* called "planetary aberration") using a */
/* Newtonian formulation. This correction */
/* yields the state of the target at the */
/* moment it emitted photons arriving at */
/* the observer at ET. */
/* The light time correction involves */
/* iterative solution of the light time */
/* equation (see Particulars for details). */
/* The solution invoked by the 'LT' option */
/* uses one iteration. */
/* 'LT+S' Correct for one-way light time and */
/* stellar aberration using a Newtonian */
/* formulation. This option modifies the */
/* state obtained with the 'LT' option to */
/* account for the observer's velocity */
/* relative to the solar system */
/* barycenter. The result is the apparent */
/* state of the target---the position and */
/* velocity of the target as seen by the */
/* observer. */
/* 'CN' Converged Newtonian light time */
/* correction. In solving the light time */
/* equation, the 'CN' correction iterates */
/* until the solution converges (three */
/* iterations on all supported platforms). */
/* The 'CN' correction typically does not */
/* substantially improve accuracy because */
/* the errors made by ignoring */
/* relativistic effects may be larger than */
/* the improvement afforded by obtaining */
/* convergence of the light time solution. */
/* The 'CN' correction computation also */
/* requires a significantly greater number */
/* of CPU cycles than does the */
/* one-iteration light time correction. */
/* 'CN+S' Converged Newtonian light time */
/* and stellar aberration corrections. */
/* The following values of ABCORR apply to the */
/* "transmission" case in which photons *depart* from */
/* the observer's location at ET and arrive at the */
/* target's location at the light-time corrected epoch */
/* ET+LT: */
/* 'XLT' "Transmission" case: correct for */
/* one-way light time using a Newtonian */
/* formulation. This correction yields the */
/* state of the target at the moment it */
/* receives photons emitted from the */
/* observer's location at ET. */
/* 'XLT+S' "Transmission" case: correct for */
/* one-way light time and stellar */
/* aberration using a Newtonian */
/* formulation This option modifies the */
/* state obtained with the 'XLT' option to */
/* account for the observer's velocity */
/* relative to the solar system */
/* barycenter. The position component of */
/* the computed target state indicates the */
/* direction that photons emitted from the */
/* observer's location must be "aimed" to */
/* hit the target. */
/* 'XCN' "Transmission" case: converged */
/* Newtonian light time correction. */
/* 'XCN+S' "Transmission" case: converged */
/* Newtonian light time and stellar */
/* aberration corrections. */
/* Neither special nor general relativistic effects are */
/* accounted for in the aberration corrections applied */
/* by this routine. */
/* Case and blanks are not significant in the string */
/* ABCORR. */
/* $ Detailed_Output */
/* STARG is a Cartesian state vector representing the position */
/* and velocity of the target body relative to the */
/* specified observer. STARG is corrected for the */
/* specified aberrations, and is expressed with respect */
/* to the specified inertial reference frame. The first */
/* three components of STARG represent the x-, y- and */
/* z-components of the target's position; last three */
/* components form the corresponding velocity vector. */
/* The position component of STARG points from the */
/* observer's location at ET to the aberration-corrected */
/* location of the target. Note that the sense of the */
/* position vector is independent of the direction of */
/* radiation travel implied by the aberration */
/* correction. */
/* The velocity component of STARG is obtained by */
/* evaluating the target's geometric state at the light */
/* time corrected epoch, so for aberration-corrected */
/* states, the velocity is not precisely equal to the */
/* time derivative of the position. */
/* Units are always km and km/sec. */
/* LT is the one-way light time between the observer and */
/* target in seconds. If the target state is corrected */
/* for aberrations, then LT is the one-way light time */
/* between the observer and the light time corrected */
/* target location. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the value of ABCORR is not recognized, the error */
/* 'SPICE(SPKINVALIDOPTION)' is signaled. */
/* 2) If the reference frame requested is not a recognized */
/* inertial reference frame, the error 'SPICE(BADFRAME)' */
/* is signaled. */
/* 3) If the state of the target relative to the solar system */
/* barycenter cannot be computed, the error will be diagnosed */
/* by routines in the call tree of this routine. */
/* $ Files */
/* This routine computes states using SPK files that have been */
/* loaded into the SPICE system, normally via the kernel loading */
/* interface routine FURNSH. Application programs typically load */
/* kernels once before this routine is called, for example during */
/* program initialization; kernels need not be loaded repeatedly. */
/* See the routine FURNSH and the SPK and KERNEL Required Reading */
/* for further information on loading (and unloading) kernels. */
/* If any of the ephemeris data used to compute STARG are expressed */
/* relative to a non-inertial frame in the SPK files providing those */
/* data, additional kernels may be needed to enable the reference */
/* frame transformations required to compute the state. Normally */
/* these additional kernels are PCK files or frame kernels. Any */
/* such kernels must already be loaded at the time this routine is */
/* called. */
/* $ Particulars */
/* In space science or engineering applications one frequently */
/* wishes to know where to point a remote sensing instrument, such */
/* as an optical camera or radio antenna, in order to observe or */
/* otherwise receive radiation from a target. This pointing problem */
/* is complicated by the finite speed of light: one needs to point */
/* to where the target appears to be as opposed to where it actually */
/* is at the epoch of observation. We use the adjectives */
/* "geometric," "uncorrected," or "true" to refer to an actual */
/* position or state of a target at a specified epoch. When a */
/* geometric position or state vector is modified to reflect how it */
/* appears to an observer, we describe that vector by any of the */
/* terms "apparent," "corrected," "aberration corrected," or "light */
/* time and stellar aberration corrected." */
/* The SPICE Toolkit can correct for two phenomena affecting the */
/* apparent location of an object: one-way light time (also called */
/* "planetary aberration") and stellar aberration. Correcting for */
/* one-way light time is done by computing, given an observer and */
/* observation epoch, where a target was when the observed photons */
/* departed the target's location. The vector from the observer to */
/* this computed target location is called a "light time corrected" */
/* vector. The light time correction depends on the motion of the */
/* target, but it is independent of the velocity of the observer */
/* relative to the solar system barycenter. Relativistic effects */
/* such as light bending and gravitational delay are not accounted */
/* for in the light time correction performed by this routine. */
/* The velocity of the observer also affects the apparent location */
/* of a target: photons arriving at the observer are subject to a */
/* "raindrop effect" whereby their velocity relative to the observer */
/* is, using a Newtonian approximation, the photons' velocity */
/* relative to the solar system barycenter minus the velocity of the */
/* observer relative to the solar system barycenter. This effect is */
/* called "stellar aberration." Stellar aberration is independent */
/* of the velocity of the target. The stellar aberration formula */
/* used by this routine is non-relativistic. */
/* Stellar aberration corrections are applied after light time */
/* corrections: the light time corrected target position vector is */
/* used as an input to the stellar aberration correction. */
/* When light time and stellar aberration corrections are both */
/* applied to a geometric position vector, the resulting position */
/* vector indicates where the target "appears to be" from the */
/* observer's location. */
/* As opposed to computing the apparent position of a target, one */
/* may wish to compute the pointing direction required for */
/* transmission of photons to the target. This requires correction */
/* of the geometric target position for the effects of light time and */
/* stellar aberration, but in this case the corrections are computed */
/* for radiation traveling from the observer to the target. */
/* The "transmission" light time correction yields the target's */
/* location as it will be when photons emitted from the observer's */
/* location at ET arrive at the target. The transmission stellar */
/* aberration correction is the inverse of the traditional stellar */
/* aberration correction: it indicates the direction in which */
/* radiation should be emitted so that, using a Newtonian */
/* approximation, the sum of the velocity of the radiation relative */
/* to the observer and of the observer's velocity, relative to the */
/* solar system barycenter, yields a velocity vector that points in */
/* the direction of the light time corrected position of the target. */
/* The traditional aberration corrections applicable to observation */
/* and those applicable to transmission are related in a simple way: */
/* one may picture the geometry of the "transmission" case by */
/* imagining the "observation" case running in reverse time order, */
/* and vice versa. */
/* One may reasonably object to using the term "observer" in the */
/* transmission case, in which radiation is emitted from the */
/* observer's location. The terminology was retained for */
/* consistency with earlier documentation. */
/* Below, we indicate the aberration corrections to use for some */
/* common applications: */
/* 1) Find the apparent direction of a target for a remote-sensing */
/* observation: */
/* Use 'LT+S': apply both light time and stellar */
/* aberration corrections. */
/* Note that using light time corrections alone ('LT') is */
/* generally not a good way to obtain an approximation to an */
/* apparent target vector: since light time and stellar */
/* aberration corrections often partially cancel each other, */
/* it may be more accurate to use no correction at all than to */
/* use light time alone. */
/* 2) Find the corrected pointing direction to radiate a signal */
/* to a target: */
/* Use 'XLT+S': apply both light time and stellar */
/* aberration corrections for transmission. */
/* 3) Obtain an uncorrected state vector derived directly from */
/* data in an SPK file: */
/* Use 'NONE'. */
/* 4) Compute the apparent position of a target body relative */
/* to a star or other distant object: */
/* Use 'LT' or 'LT+S' as needed to match the correction */
/* applied to the position of the distant object. For */
/* example, if a star position is obtained from a catalog, */
/* the position vector may not be corrected for stellar */
/* aberration. In this case, to find the angular */
/* separation of the star and the limb of a planet, the */
/* vector from the observer to the planet should be */
/* corrected for light time but not stellar aberration. */
/* 5) Use a geometric state vector as a low-accuracy estimate */
/* of the apparent state for an application where execution */
/* speed is critical: */
/* Use 'NONE'. */
/* 6) While this routine cannot perform the relativistic */
/* aberration corrections required to compute states */
/* with the highest possible accuracy, it can supply the */
/* geometric states required as inputs to these computations: */
/* Use 'NONE', then apply high-accuracy aberration */
/* corrections (not available in the SPICE Toolkit). */
/* Below, we discuss in more detail how the aberration corrections */
/* applied by this routine are computed. */
/* Geometric case */
/* ============== */
/* ZZSPKAP0 begins by computing the geometric position T(ET) of */
/* the target body relative to the solar system barycenter (SSB). */
/* Subtracting the geometric position of the observer O(ET) gives */
/* the geometric position of the target body relative to the */
/* observer. The one-way light time, LT, is given by */
/* | T(ET) - O(ET) | */
/* LT = ------------------- */
/* c */
/* The geometric relationship between the observer, target, and */
/* solar system barycenter is as shown: */
/* SSB ---> O(ET) */
/* | / */
/* | / */
/* | / */
/* | / T(ET) - O(ET) */
/* V V */
/* T(ET) */
/* The returned state consists of the position vector */
/* T(ET) - O(ET) */
/* and a velocity obtained by taking the difference of the */
/* corresponding velocities. In the geometric case, the */
/* returned velocity is actually the time derivative of the */
/* position. */
/* Reception case */
/* ============== */
/* When any of the options 'LT', 'CN', 'LT+S', 'CN+S' is */
/* selected, ZZSPKAP0 computes the position of the target body at */
/* epoch ET-LT, where LT is the one-way light time. Let T(t) and */
/* O(t) represent the positions of the target and observer */
/* relative to the solar system barycenter at time t; then LT is */
/* the solution of the light-time equation */
/* | T(ET-LT) - O(ET) | */
/* LT = ------------------------ (1) */
/* c */
/* The ratio */
/* | T(ET) - O(ET) | */
/* --------------------- (2) */
/* c */
/* is used as a first approximation to LT; inserting (2) into the */
/* RHS of the light-time equation (1) yields the "one-iteration" */
/* estimate of the one-way light time. Repeating the process */
/* until the estimates of LT converge yields the "converged */
/* Newtonian" light time estimate. */
/* Subtracting the geometric position of the observer O(ET) gives */
/* the position of the target body relative to the observer: */
/* T(ET-LT) - O(ET). */
/* SSB ---> O(ET) */
/* | \ | */
/* | \ | */
/* | \ | T(ET-LT) - O(ET) */
/* | \ | */
/* V V V */
/* T(ET) T(ET-LT) */
/* The position component of the light-time corrected state */
/* is the vector */
/* T(ET-LT) - O(ET) */
/* The velocity component of the light-time corrected state */
/* is the difference */
/* T_vel(ET-LT) - O_vel(ET) */
/* where T_vel and O_vel are, respectively, the velocities of */
/* the target and observer relative to the solar system */
/* barycenter at the epochs ET-LT and ET. */
/* If correction for stellar aberration is requested, the target */
/* position is rotated toward the solar system barycenter- */
/* relative velocity vector of the observer. The rotation is */
/* computed as follows: */
/* Let r be the light time corrected vector from the observer */
/* to the object, and v be the velocity of the observer with */
/* respect to the solar system barycenter. Let w be the angle */
/* between them. The aberration angle phi is given by */
/* sin(phi) = v sin(w) / c */
/* Let h be the vector given by the cross product */
/* h = r X v */
/* Rotate r by phi radians about h to obtain the apparent */
/* position of the object. */
/* The velocity component of the output state STARG is */
/* not corrected for stellar aberration. */
/* Transmission case */
/* ================== */
/* When any of the options 'XLT', 'XCN', 'XLT+S', 'XCN+S' are */
/* selected, ZZSPKAP0 computes the position of the target body T */
/* at epoch ET+LT, where LT is the one-way light time. LT is the */
/* solution of the light-time equation */
/* | T(ET+LT) - O(ET) | */
/* LT = ------------------------ (3) */
/* c */
/* Subtracting the geometric position of the observer, O(ET), */
/* gives the position of the target body relative to the */
/* observer: T(ET-LT) - O(ET). */
/* SSB --> O(ET) */
/* / | * */
/* / | * T(ET+LT) - O(ET) */
/* / |* */
/* / *| */
/* V V V */
/* T(ET+LT) T(ET) */
/* The position component of the light-time corrected state */
/* is the vector */
/* T(ET+LT) - O(ET) */
/* The velocity component of the light-time corrected state */
/* is the difference */
/* T_vel(ET+LT) - O_vel(ET) */
/* where T_vel and O_vel are, respectively, the velocities of */
/* the target and observer relative to the solar system */
/* barycenter at the epochs ET+LT and ET. */
/* If correction for stellar aberration is requested, the target */
/* position is rotated away from the solar system barycenter- */
/* relative velocity vector of the observer. The rotation is */
/* computed as in the reception case, but the sign of the */
/* rotation angle is negated. */
/* The velocity component of the output state STARG is */
/* not corrected for stellar aberration. */
/* Neither special nor general relativistic effects are accounted */
/* for in the aberration corrections performed by this routine. */
/* $ Examples */
/* In the following code fragment, ZZSPKSB0 and ZZSPKAP0 are used */
/* to display the position of Io (body 501) as seen from the */
/* Voyager 2 spacecraft (Body -32) at a series of epochs. */
/* Normally, one would call the high-level reader SPKEZR to obtain */
/* state vectors. The example below illustrates the interface */
/* of this routine but is not intended as a recommendation on */
/* how to use the SPICE SPK subsystem. */
/* The use of integer ID codes is necessitated by the low-level */
/* interface of this routine. */
/* IO = 501 */
/* VGR2 = -32 */
/* DO WHILE ( EPOCH .LE. END ) */
/* CALL ZZSPKSB0 ( VGR2, EPOCH, 'J2000', STVGR2 ) */
/* CALL ZZSPKAP0 ( IO, EPOCH, 'J2000', STVGR2, */
/* . 'LT+S', STIO, LT ) */
/* CALL RECRAD ( STIO, RANGE, RA, DEC ) */
/* WRITE (*,*) RA * DPR(), DEC * DPR() */
/* EPOCH = EPOCH + DELTA */
/* END DO */
/* $ Restrictions */
/* 1) SPICE Private routine. */
/* 2) The kernel files to be used by ZZSPKAP0 must be loaded */
/* (normally by the SPICELIB kernel loader FURNSH) before */
/* this routine is called. */
/* 3) Unlike most other SPK state computation routines, this */
/* routine requires that the input state be relative to an */
/* inertial reference frame. Non-inertial frames are not */
/* supported by this routine. */
/* 4) In a future version of this routine, the implementation */
/* of the aberration corrections may be enhanced to improve */
/* accuracy. */
/* $ Literature_References */
/* SPK Required Reading. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* I.M. Underwood (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 12-DEC-2004 (NJB) */
/* Based on SPICELIB Version 3.0.1, 20-OCT-2003 (EDW) */
/* -& */
/* $ Index_Entries */
/* low-level aberration correction */
/* apparent state from spk file */
/* get apparent state */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 22-MAY-1995 (WLT) */
/* The routine was modified to support the options 'CN' and */
/* 'CN+S' aberration corrections. Moreover, diagnostics were */
/* added to check for reference frames that are not recognized */
/* inertial frames. */
/* - SPICELIB Version 1.1.1, 06-MAR-1991 (JML) */
/* In the example program, the calling sequence of ZZSPKAP0 */
/* was corrected. */
/* - SPICELIB Version 1.1.0, 25-MAY-1990 (HAN) */
/* The local variable CORR was added to eliminate a run-time */
/* error that occurred when ZZSPKAP0 was determining what */
/* corrections to apply to the state. If the literal string */
/* 'LT' was assigned to ABCORR, ZZSPKAP0 attempted to look at */
/* ABCORR(3:4). Because ABCORR is a passed length argument, its */
/* length is not guaranteed, and those positions may not exist. */
/* Searching beyond the bounds of a string resulted in a */
/* run-time error at NAIF because NAIF compiles SPICELIB using the */
/* CHECK=BOUNDS option for the DEC VAX/VMX DCL FORTRAN command. */
/* Also, without the local variable CORR, ZZSPKAP0 would have to */
/* modify the value of a passed argument, ABCORR. That's a no no. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Indices of flags in the FLAGS array: */
/* Local variables */
/* Saved variables */
/* Initial values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZSPKAP0", (ftnlen)8);
}
if (first || s_cmp(abcorr, prvcor, abcorr_len, (ftnlen)5) != 0) {
/* The aberration correction flag differs from the value it */
/* had on the previous call, if any. Analyze the new flag. */
/* Remove leading and embedded white space from the aberration */
/* correction flag, then convert to upper case. */
cmprss_(" ", &c__0, abcorr, corr2, (ftnlen)1, abcorr_len, (ftnlen)5);
ucase_(corr2, corr, (ftnlen)5, (ftnlen)5);
/* Locate the flag in our list of flags. */
i__ = isrchc_(corr, &c__9, flags, (ftnlen)5, (ftnlen)5);
if (i__ == 0) {
setmsg_("Requested aberration correction # is not supported.", (
ftnlen)51);
errch_("#", abcorr, (ftnlen)1, abcorr_len);
sigerr_("SPICE(SPKINVALIDOPTION)", (ftnlen)23);
chkout_("ZZSPKAP0", (ftnlen)8);
return 0;
}
/* The aberration correction flag is recognized; save it. */
s_copy(prvcor, abcorr, (ftnlen)5, abcorr_len);
/* Set logical flags indicating the attributes of the requested */
/* correction. */
xmit = i__ > 5;
uselt = i__ == 2 || i__ == 3 || i__ == 6 || i__ == 7;
usestl = i__ > 1 && odd_(&i__);
usecn = i__ == 4 || i__ == 5 || i__ == 8 || i__ == 9;
first = FALSE_;
}
/* See if the reference frame is a recognized inertial frame. */
irfnum_(ref, &refid, ref_len);
if (refid == 0) {
setmsg_("The requested frame '#' is not a recognized inertial frame. "
, (ftnlen)60);
errch_("#", ref, (ftnlen)1, ref_len);
sigerr_("SPICE(BADFRAME)", (ftnlen)15);
chkout_("ZZSPKAP0", (ftnlen)8);
return 0;
}
/* Determine the sign of the light time offset. */
if (xmit) {
ltsign = 1;
} else {
ltsign = -1;
}
/* Find the geometric state of the target body with respect to the */
/* solar system barycenter. Subtract the state of the observer */
/* to get the relative state. Use this to compute the one-way */
/* light time. */
zzspksb0_(targ, et, ref, starg, ref_len);
vsubg_(starg, sobs, &c__6, tstate);
moved_(tstate, &c__6, starg);
*lt = vnorm_(starg) / clight_();
/* To correct for light time, find the state of the target body */
/* at the current epoch minus the one-way light time. Note that */
/* the observer remains where he is. */
if (uselt) {
maxitr = 1;
} else if (usecn) {
maxitr = 3;
} else {
maxitr = 0;
}
i__1 = maxitr;
for (i__ = 1; i__ <= i__1; ++i__) {
d__1 = *et + ltsign * *lt;
zzspksb0_(targ, &d__1, ref, starg, ref_len);
vsubg_(starg, sobs, &c__6, tstate);
moved_(tstate, &c__6, starg);
*lt = vnorm_(starg) / clight_();
}
/* At this point, STARG contains the light time corrected */
/* state of the target relative to the observer. */
/* If stellar aberration correction is requested, perform it now. */
/* Stellar aberration corrections are not applied to the target's */
/* velocity. */
if (usestl) {
if (xmit) {
/* This is the transmission case. */
/* Compute the position vector obtained by applying */
/* "reception" stellar aberration to STARG. */
stlabx_(starg, &sobs[3], sapos);
vequ_(sapos, starg);
} else {
/* This is the reception case. */
/* Compute the position vector obtained by applying */
/* "reception" stellar aberration to STARG. */
stelab_(starg, &sobs[3], sapos);
vequ_(sapos, starg);
}
}
chkout_("ZZSPKAP0", (ftnlen)8);
return 0;
} /* zzspkap0_ */
/* $Procedure DPFMT ( Format a double precision number ) */
/* Subroutine */ int dpfmt_(doublereal *x, char *pictur, char *str, ftnlen
pictur_len, ftnlen str_len)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Builtin functions */
integer i_len(char *, ftnlen), s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char fill[1];
integer dpat;
char sign[1];
integer i__;
extern /* Subroutine */ int zzvsbstr_(integer *, integer *, logical *,
char *, logical *, ftnlen);
doublereal y;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), zzvststr_(doublereal *, char *, integer *,
ftnlen);
logical shift;
extern integer ncpos_(char *, char *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int dpstr_(doublereal *, integer *, char *,
ftnlen);
integer start;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen),
rjust_(char *, char *, ftnlen, ftnlen);
char mystr[32];
integer declen, sigdig;
logical needsn;
integer lastch, sgnlen, frstch, intlen, firstb;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
logical ovflow;
integer expsiz, sprsiz, exp__;
extern integer pos_(char *, char *, integer *, ftnlen, ftnlen);
/* $ Abstract */
/* Using a picture, create a formatted string that represents a */
/* double precision number. */
/* $ 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 */
/* ALPHANUMERIC */
/* CONVERSION */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* X I a double precision number. */
/* PICTUR I a string describing the appearance of the output */
/* STR O a string representing X as prescribed by PICTUR */
/* $ Detailed_Input */
/* X is any double precision number. */
/* PICTUR is a string used to describe the format of the */
/* output string. There are four special characters */
/* recognized by DPFMT --- a leading + or -, a leading */
/* zero ( '0' ) or a zero that follows a leading + or -, */
/* and the first decimal point of the string. */
/* All other non-blank characters are regarded as */
/* equivalent. The picture ends at the first blank */
/* character. The effects associated with the various */
/* characters in a picture are spelled out in the */
/* description of the output STRING. */
/* The following pictures are treated as errors. */
/* ' ', '+', '-', '.', '+.', '-.' */
/* $ Detailed_Output */
/* STRING is a string representing X that matches the input */
/* picture. The format of STRING is governed by PICTUR. */
/* It will represent X rounded to the level of precision */
/* specified by PICTUR. */
/* If the first character of the picture is a minus sign, */
/* the first character in the output string will be */
/* a blank if the number is non-negative, a minus sign */
/* if the number is negative. */
/* If the first character of the picture is a plus sign, */
/* the first character of the output string will be a */
/* plus if the number is positive, a blank if the number */
/* is zero, and a minus sign if the number is negative. */
/* If the first character of the string is NOT a sign */
/* (plus or minus) the first character of the output */
/* string will be a minus sign if the number is negative */
/* and will be the first character of the integer part */
/* of the number otherwise. */
/* The integer portion of STRING will contain the same */
/* number of characters as appear before the decimal */
/* point (or last character if there is no decimal */
/* point) but after a leading + or -. */
/* If the picture begins with any of the following */
/* '+0', '-0', or '0' */
/* it is said to have a leading zero. If a picture has */
/* a leading zero and the integer portion is not large */
/* enough to fill up the integer space specified by */
/* PICTUR, STRING will be zero padded from the sign (if */
/* one is required) up to the first character of the */
/* integer part of the number. */
/* If picture does NOT have a leading zero and the */
/* integer portion is not large enough to fill up the */
/* space specified by PICTUR, STRING will be blank */
/* padded on the left between the sign (if one is */
/* required) and the first character of the integer part */
/* of the number. */
/* If a decimal point ( '.' ) is present in PICTUR it */
/* will be present following the integer portion of */
/* STRING. Moreover, the decimal portion of STRING will */
/* contain the same number of digits as there are */
/* non-blank characters following the decimal point in */
/* PICTUR. However, only the first 14 digits starting */
/* with the first non-zero digit are meaningful. */
/* If the format specified by PICTUR does not provide */
/* enough room for the integer portion of X, the routine */
/* determines whether or not the number of characters */
/* present in the picture is sufficient to create a */
/* representation for X using scientific notation. If */
/* so, the output is displayed using scientific notation */
/* (leading signs, if they are present in PICTUR, will */
/* also appear in STRING). If the format specified by */
/* PICTUR is too short to accommodate scientific */
/* notation, the output string is filled with '*' to the */
/* same length as the length of PICTUR. Leading signs */
/* are not preserved in this overflow case. */
/* STRING may overwrite PICTUR. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) A picture that begins with a blank will cause the error */
/* 'SPICE(NOPICTURE)' to be signalled. */
/* 2) A picture that consists only of '+', '-', '.', '+.' or '-.' */
/* are regarded are regarded as errors (there's no significant */
/* component to the picture.) These pictures cause the error */
/* 'SPICE(BADPICTURE)' to be signalled. */
/* 3) If the length of STR is less than the length of the first */
/* non-blank portion of PICTUR, the error 'SPICE(OUTPUTTOOSHORT)' */
/* will be signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine provides a mechanism for producing numeric strings */
/* formatted according to a user supplied picture. We expect that */
/* the string produced by this routine will be used to assist in */
/* the construction of a string that can be read by people. */
/* Note that the process of converting a double precision number */
/* to a string, in not precisely invertible even if the string */
/* contains all of the significant figures allowed by this */
/* routine. You should not anticipate that the string produced */
/* by this routine can be "read" into a double precision number */
/* to reproduce the double precision number X. To the level of */
/* accuracy implied by the string representation, they will be */
/* the same. But, they are unlikely to have the same internal */
/* binary representation. */
/* $ Examples */
/* Suppose that X has the binary representation of PI. Then the */
/* table below illustrates the strings that would be produced */
/* by a variety of different pictures. */
/* PICTUR | STRING */
/* ------------------------------- */
/* '0x.xxx' | '03.142' */
/* 'xx.xxx' | ' 3.142' */
/* '+xxx.yyyy' | '+ 3.1416' */
/* '-.yyyy' | '******' */
/* 'xxxxxxxx' | ' 3' */
/* '00xx' | '0003' */
/* '-00.0000000' | ' 03.1415927' */
/* '00' | '03' */
/* 'x.' | '3.' */
/* '.mynumber' | '3.142E+00' */
/* 'my dog spot' | ' 3' */
/* 'my.dog spot' | ' 3.142' */
/* '+my.dog,spot' | '+ 3.14159265' */
/* Suppose that X has the binary representation of 2/3. Then the */
/* table below illustrates the strings that would be produced */
/* by a variety of different pictures. */
/* PICTUR | STRING */
/* ------------------------------- */
/* '+x.xxx' | '+0.667' */
/* '+xx.xxx' | '+ 0.667' */
/* 'xxx.yyyy' | ' 0.6667' */
/* '.yyyy' | '.6667' */
/* 'xxxxxxxx' | ' 1' */
/* '00xx' | '0001' */
/* '-0.0000000' | ' 0.6666667' */
/* '00' | '01' */
/* 'x.' | '1.' */
/* 'mynumber' | ' 1' */
/* 'my dog spot' | ' 1' */
/* 'my.dog spot' | ' 0.667' */
/* 'my.dog,spot' | ' 0.66666667' */
/* Suppose that X has the binary representation of -8/9. Then the */
/* table below illustrates the strings that would be produced */
/* by a variety of different pictures. */
/* PICTUR | STRING */
/* ------------------------------- */
/* '+x.xxx' | '-0.889' */
/* '-00.xxxx' | '-00.8889' */
/* 'xxx.xxx' | ' -0.889' */
/* '000.000' | '-00.889' */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.2, 31-JAN-2008 (BVS) */
/* Removed non-standard end-of-declarations marker */
/* 'C%&END_DECLARATIONS' from comments. */
/* - Spicelib Version 1.0.1, 22-JUN-1998 (WLT) */
/* A number of typographical and grammatical errors */
/* were corrected in the header. */
/* - Spicelib Version 1.0.0, 17-SEP-1996 (WLT) */
/* -& */
/* $ Index_Entries */
/* format a string representing a d.p. number */
/* string from a d.p. number and format picture */
/* -& */
/* $ Revisions */
/* None. */
/* -& */
/* SPICELIB functions */
/* Initial values */
/* Determine where the picture ends. */
firstb = pos_(pictur, " ", &c__1, pictur_len, (ftnlen)1);
if (firstb == 0) {
lastch = i_len(pictur, pictur_len);
} else {
lastch = firstb - 1;
}
/* Make sure there is a picture to worry about. */
if (lastch == 0) {
chkin_("DPFMT", (ftnlen)5);
setmsg_("The format picture must begin with a non-blank character. "
"The picture supplied was began with a blank.", (ftnlen)103);
sigerr_("SPICE(NOPICTURE)", (ftnlen)16);
chkout_("DPFMT", (ftnlen)5);
return 0;
} else if (lastch == 1) {
if (s_cmp(pictur, "+", pictur_len, (ftnlen)1) == 0 || s_cmp(pictur,
"-", pictur_len, (ftnlen)1) == 0 || s_cmp(pictur, ".",
pictur_len, (ftnlen)1) == 0) {
chkin_("DPFMT", (ftnlen)5);
setmsg_("Format pictures must have at least one significant char"
"acter. The picture provided '#' does not. ", (ftnlen)97);
errch_("#", pictur, (ftnlen)1, (ftnlen)1);
sigerr_("SPICE(BADPICTURE)", (ftnlen)17);
chkout_("DPFMT", (ftnlen)5);
return 0;
}
} else if (lastch == 2) {
if (s_cmp(pictur, "+.", pictur_len, (ftnlen)2) == 0 || s_cmp(pictur,
"-.", pictur_len, (ftnlen)2) == 0) {
chkin_("DPFMT", (ftnlen)5);
setmsg_("Format pictures must have at least one significant char"
"acter. The picture provided '#' does not. ", (ftnlen)97);
errch_("#", pictur, (ftnlen)1, (ftnlen)2);
sigerr_("SPICE(BADPICTURE)", (ftnlen)17);
chkout_("DPFMT", (ftnlen)5);
return 0;
}
} else if (lastch > i_len(str, str_len)) {
chkin_("DPFMT", (ftnlen)5);
setmsg_("The output string is not long enough to accommodate a numbe"
"r formatted according the the supplied format picture. The "
"output string has length #. The output picture '#' requires"
" # characters. ", (ftnlen)194);
i__1 = i_len(str, str_len);
errint_("#", &i__1, (ftnlen)1);
errch_("#", pictur, (ftnlen)1, lastch);
errint_("#", &lastch, (ftnlen)1);
sigerr_("SPICE(OUTPUTTOOSHORT)", (ftnlen)21);
chkout_("DPFMT", (ftnlen)5);
return 0;
}
/* If we get this far, the routine can go ahead and do its business. */
/* Determine the sign of X. Also, determine how many characters */
/* are needed to represent the sign if leading sign is suppressed for */
/* positive numbers. */
if (*x > 0.) {
*(unsigned char *)sign = '+';
sprsiz = 0;
} else if (*x < 0.) {
*(unsigned char *)sign = '-';
sprsiz = 1;
} else {
*(unsigned char *)sign = ' ';
sprsiz = 0;
}
/* Look at the picture and see if a leading sign is required and */
/* if so whether the sign just determined should use a different */
/* character and how many characters are needed for the sign. */
if (*(unsigned char *)pictur == '+') {
needsn = TRUE_;
sgnlen = 1;
} else if (*(unsigned char *)pictur == '-') {
needsn = TRUE_;
sgnlen = 1;
if (*x > 0.) {
*(unsigned char *)sign = ' ';
}
} else {
if (*x > 0.) {
*(unsigned char *)sign = ' ';
}
needsn = FALSE_;
sgnlen = sprsiz;
}
/* If we need a leading sign. The numeric part of the string */
/* will start at character 2. Otherwise it starts at character 1. */
if (needsn) {
start = 2;
} else {
start = 1;
}
/* We can set the sign portion of the string now. */
s_copy(str, sign, str_len, (ftnlen)1);
/* Determine what character should be use for leading characters */
/* before the first significant character of the output string. */
if (*(unsigned char *)&pictur[start - 1] == '0') {
*(unsigned char *)fill = '0';
} else {
*(unsigned char *)fill = ' ';
}
/* See if there is a decimal point. */
dpat = pos_(pictur, ".", &c__1, pictur_len, (ftnlen)1);
/* The integer part is the stuff to the left of the first */
/* decimal point and that follows the sign (if there is one */
/* that is explicitly required. The length of the decimal */
/* portion is the stuff to the right of the decimal point. */
if (dpat > 0) {
intlen = dpat - start;
declen = lastch - dpat;
} else {
intlen = lastch - start + 1;
declen = -1;
}
/* If a sign was not explicitly requested by placing it in */
/* the first digit of the picture START will be 1. If in */
/* addition X is less than zero ( SGNLEN will be 1 in this */
/* case) we have one fewer digits available for the integer */
/* portion of the string than is currently set in INTLEN. */
/* Adjust INTLEN to reflect the actual number of digits */
/* available. */
/* Also set the SHIFT flag to .TRUE. so that we know to swap */
/* the sign and any blanks that might lie between the sign */
/* and the first significant character of the output string. */
if (start == 1 && sgnlen == 1) {
--intlen;
shift = TRUE_;
/* If INTLEN has become negative (i.e. -1) the picture */
/* must be of the form .xxxxx and the input number must */
/* be negative. Add 1 back onto the INTLEN but take one */
/* away from the decimal length DECLEN. */
if (intlen == -1) {
intlen = 0;
--declen;
if (declen == 0 && intlen == 0) {
/* There is no room for anything other than a */
/* decimal point. We simply fill the output */
/* string with the '*' character. */
i__1 = lastch;
for (i__ = 1; i__ <= i__1; ++i__) {
*(unsigned char *)&str[i__ - 1] = '*';
}
return 0;
}
}
} else {
shift = FALSE_;
}
/* Create the "virtual decimal string" associated with the */
/* unsigned part of X. */
y = abs(*x);
zzvststr_(&y, fill, &exp__, (ftnlen)1);
/* The actual number of digits required to print the unsigned integer */
/* portion X is EXP + 1 (provided EXP is at least 0.) We have */
/* INTLEN slots available. So if EXP + 1 is more than INTLEN */
/* ( which is equivalent to EXP being at least INTLEN) we don't */
/* have enough room to print the unsigned integer portion of the */
/* number. */
if (exp__ >= intlen && y != 0.) {
/* See if we have room to print an exponential form. */
/* First we need the number of characters for the */
/* exponent which is always of the form 'E+dd...' */
/* Computing MIN */
i__1 = 1, i__2 = exp__ / 1000;
/* Computing MIN */
i__3 = 1, i__4 = exp__ / 100;
expsiz = min(i__1,i__2) + 4 + min(i__3,i__4);
/* The number of significant digits that can be printed is the */
/* size of the picture minus: the size of the sign */
/* the size of the exponent */
/* the size of the decimal point. */
sigdig = lastch - sgnlen - expsiz - 1;
/* If we don't have room for at least one significant digit, */
/* there's not much we can do. Fill the string with '*'. */
if (sigdig < 1) {
i__1 = lastch;
for (i__ = 1; i__ <= i__1; ++i__) {
*(unsigned char *)&str[i__ - 1] = '*';
}
} else {
dpstr_(x, &sigdig, mystr, (ftnlen)32);
*(unsigned char *)mystr = *(unsigned char *)sign;
ljust_(mystr, str, (ftnlen)32, str_len);
rjust_(str, str, lastch, lastch);
}
return 0;
}
/* One more check. If -INTLEN is greater than DECLEN, or if */
/* both are zero, we don't have room to create an output string. */
if (intlen == 0 && declen == 0 || -intlen > declen) {
i__1 = lastch;
for (i__ = 1; i__ <= i__1; ++i__) {
*(unsigned char *)&str[i__ - 1] = '*';
}
return 0;
}
/* We have a reasonable chance of successfully constructing */
/* the string without overflow. */
start = sgnlen + 1;
i__1 = -intlen;
zzvsbstr_(&i__1, &declen, &c_true, str + (start - 1), &ovflow, str_len - (
start - 1));
/* We might be done at this point. The IF-THEN block below */
/* handles the one snag that could arise. */
/* If the first digit is a zero as a result of rounding it up */
/* OVFLOW will be true. This means we don't have enough room */
/* in the picture for the integer portion of the string. We try */
/* to make an exponential picture. */
if (ovflow) {
/* See if we have room to print an exponential form. */
/* Computing MIN */
i__1 = 1, i__2 = exp__ / 1000;
/* Computing MIN */
i__3 = 1, i__4 = exp__ / 100;
expsiz = min(i__1,i__2) + 4 + min(i__3,i__4);
/* The number of significant digits that can be printed is the */
/* size of the picture minus: the size of the sign */
/* the size of the exponent */
/* the size of the decimal point. */
sigdig = lastch - sgnlen - expsiz - 1;
if (sigdig < 1) {
i__1 = lastch;
for (i__ = 1; i__ <= i__1; ++i__) {
*(unsigned char *)&str[i__ - 1] = '*';
}
} else {
dpstr_(x, &sigdig, mystr, (ftnlen)32);
*(unsigned char *)mystr = *(unsigned char *)sign;
ljust_(mystr, str, (ftnlen)32, str_len);
rjust_(str, str, lastch, lastch);
return 0;
}
} else if (shift) {
/* We need to move the sign right until, there are no */
/* blanks between it and the next character. */
frstch = ncpos_(str, " -", &c__1, str_len, (ftnlen)2);
if (frstch > 2) {
i__1 = frstch - 2;
s_copy(str + i__1, str, frstch - 1 - i__1, (ftnlen)1);
*(unsigned char *)str = ' ';
}
}
return 0;
} /* dpfmt_ */
/* $Procedure ZZHULLAX ( Pyramidal FOV convex hull to FOV axis ) */
/* Subroutine */ int zzhullax_(char *inst, integer *n, doublereal *bounds,
doublereal *axis, ftnlen inst_len)
{
/* System generated locals */
integer bounds_dim2, i__1, i__2;
doublereal d__1;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
extern /* Subroutine */ int vhat_(doublereal *, doublereal *);
doublereal xvec[3], yvec[3], zvec[3];
integer xidx;
extern doublereal vsep_(doublereal *, doublereal *);
integer next;
logical pass1;
integer i__, m;
doublereal r__, v[3], delta;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
logical found;
extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen), vlcom_(
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
integer minix, maxix;
doublereal trans[9] /* was [3][3] */;
extern /* Subroutine */ int ucrss_(doublereal *, doublereal *, doublereal
*), vcrss_(doublereal *, doublereal *, doublereal *);
extern logical vzero_(doublereal *);
extern /* Subroutine */ int vrotv_(doublereal *, doublereal *, doublereal
*, doublereal *);
doublereal cp[3];
extern doublereal pi_(void);
logical ok;
extern doublereal halfpi_(void);
extern /* Subroutine */ int reclat_(doublereal *, doublereal *,
doublereal *, doublereal *), sigerr_(char *, ftnlen);
doublereal minlon;
extern /* Subroutine */ int chkout_(char *, ftnlen);
doublereal maxlon;
extern /* Subroutine */ int vhatip_(doublereal *), vsclip_(doublereal *,
doublereal *), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
extern logical return_(void);
doublereal lat, sep, lon;
extern /* Subroutine */ int mxv_(doublereal *, doublereal *, doublereal *)
;
doublereal ray1[3], ray2[3];
/* $ 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. */
/* Identify a face of the convex hull of an instrument's */
/* polygonal FOV, and use this face to generate an axis of the */
/* FOV. */
/* $ 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 */
/* FRAMES */
/* GF */
/* IK */
/* KERNEL */
/* $ Keywords */
/* FOV */
/* GEOMETRY */
/* INSTRUMENT */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* MARGIN P Minimum complement of FOV cone angle. */
/* INST I Instrument name. */
/* N I Number of FOV boundary vectors. */
/* BOUNDS I FOV boundary vectors. */
/* AXIS O Instrument FOV axis vector. */
/* $ Detailed_Input */
/* INST is the name of an instrument with which the field of */
/* view (FOV) of interest is associated. This name is */
/* used only to generate long error messages. */
/* N is the number of boundary vectors in the array */
/* BOUNDS. */
/* BOUNDS is an array of N vectors emanating from a common */
/* vertex and defining the edges of a pyramidal region in */
/* three-dimensional space: this the region within the */
/* FOV of the instrument designated by INST. The Ith */
/* vector of BOUNDS resides in elements (1:3,I) of this */
/* array. */
/* The vectors contained in BOUNDS are called the */
/* "boundary vectors" of the FOV. */
/* The boundary vectors must satisfy the constraints: */
/* 1) The boundary vectors must be contained within */
/* a right circular cone of angular radius less */
/* than than (pi/2) - MARGIN radians; in other */
/* words, there must be a vector A such that all */
/* boundary vectors have angular separation from */
/* A of less than (pi/2)-MARGIN radians. */
/* 2) There must be a pair of vectors U, V in BOUNDS */
/* such that all other boundary vectors lie in */
/* the same half space bounded by the plane */
/* containing U and V. Furthermore, all other */
/* boundary vectors must have orthogonal */
/* projections onto a plane normal to this plane */
/* such that the projections have angular */
/* separation of at least 2*MARGIN radians from */
/* the plane spanned by U and V. */
/* Given the first constraint above, there is plane PL */
/* such that each of the set of rays extending the */
/* boundary vectors intersects PL. (In fact, there is an */
/* infinite set of such planes.) The boundary vectors */
/* must be ordered so that the set of line segments */
/* connecting the intercept on PL of the ray extending */
/* the Ith vector to that of the (I+1)st, with the Nth */
/* intercept connected to the first, form a polygon (the */
/* "FOV polygon") constituting the intersection of the */
/* FOV pyramid with PL. This polygon may wrap in either */
/* the positive or negative sense about a ray emanating */
/* from the FOV vertex and passing through the plane */
/* region bounded by the FOV polygon. */
/* The FOV polygon need not be convex; it may be */
/* self-intersecting as well. */
/* No pair of consecutive vectors in BOUNDS may be */
/* linearly dependent. */
/* The boundary vectors need not have unit length. */
/* $ Detailed_Output */
/* AXIS is a unit vector normal to a plane containing the */
/* FOV polygon. All boundary vectors have angular */
/* separation from AXIS of not more than */
/* ( pi/2 ) - MARGIN */
/* radians. */
/* This routine signals an error if it cannot find */
/* a satisfactory value of AXIS. */
/* $ Parameters */
/* MARGIN is a small positive number used to constrain the */
/* orientation of the boundary vectors. See the two */
/* constraints described in the Detailed_Input section */
/* above for specifics. */
/* $ Exceptions */
/* 1) In the input vector count N is not at least 3, the error */
/* SPICE(INVALIDCOUNT) is signaled. */
/* 2) If any pair of consecutive boundary vectors has cross */
/* product zero, the error SPICE(DEGENERATECASE) is signaled. */
/* For this test, the first vector is considered the successor */
/* of the Nth. */
/* 3) If this routine can't find a face of the convex hull of */
/* the set of boundary vectors such that this face satisfies */
/* constraint (2) of the Detailed_Input section above, the */
/* error SPICE(FACENOTFOUND) is signaled. */
/* 4) If any boundary vectors have longitude too close to 0 */
/* or too close to pi radians in the face frame (see discussion */
/* of the search algorithm's steps 3 and 4 in Particulars */
/* below), the respective errors SPICE(NOTSUPPORTED) or */
/* SPICE(FOVTOOWIDE) are signaled. */
/* 5) If any boundary vectors have angular separation of more than */
/* (pi/2)-MARGIN radians from the candidate FOV axis, the */
/* error SPICE(FOVTOOWIDE) is signaled. */
/* $ Files */
/* The boundary vectors input to this routine are typically */
/* obtained from an IK file. */
/* $ Particulars */
/* Normally implementation is not discussed in SPICE headers, but we */
/* make an exception here because this routine's implementation and */
/* specification are deeply intertwined. */
/* This routine produces an "axis" for a polygonal FOV using the */
/* following approach: */
/* 1) Test pairs of consecutive FOV boundary vectors to see */
/* whether there's a pair such that the plane region bounded */
/* by these vectors is */
/* a) part of the convex hull of the set of boundary vectors */
/* b) such that all other boundary vectors have angular */
/* separation of at least MARGIN from the plane */
/* containing these vectors */
/* This search has O(N**2) run time dependency on N. */
/* If this test produces a candidate face of the convex hull, */
/* proceed to step 3. */
/* 2) If step (1) fails, repeat the search for a candidate */
/* convex hull face, but this time search over every pair of */
/* distinct boundary vectors. */
/* This search has O(N**3) run time dependency on N. */
/* If this search fails, signal an error. */
/* 3) Produce a set of basis vectors for a reference frame, */
/* which we'll call the "face frame," using as the +X axis */
/* the angle bisector of the vectors bounding the candidate */
/* face, the +Y axis the inward normal vector to this face, */
/* and the +Z axis completing a right-handed basis. */
/* 4) Transform each boundary vector, other than the two vectors */
/* defining the selected convex hull face, to the face frame */
/* and compute the vector's longitude in that frame. Find the */
/* maximum and minimum longitudes of the vectors in the face */
/* frame. */
/* If any vector's longitude is less than 2*MARGIN or greater */
/* than pi - 2*MARGIN radians, signal an error. */
/* 5) Let DELTA be the difference between pi and the maximum */
/* longitude found in step (4). Rotate the +Y axis (which */
/* points in the inward normal direction relative to the */
/* selected face) by -DELTA/2 radians about the +Z axis of */
/* the face frame. This rotation aligns the +Y axis with the */
/* central longitude of the set of boundary vectors. The */
/* resulting vector is our candidate FOV axis. */
/* 6) Check the angular separation of the candidate FOV axis */
/* against each boundary vector. If any vector has angular */
/* separation of more than (pi/2)-MARGIN radians from the */
/* axis, signal an error. */
/* Note that there are reasonable FOVs that cannot be handled by the */
/* algorithm described here. For example, any FOV whose cross */
/* section is a regular convex polygon can be made unusable by */
/* adding boundary vectors aligned with the angle bisectors of each */
/* face of the pyramid defined by the FOV's boundary vectors. The */
/* resulting set of boundary vectors has no face in its convex hull */
/* such that all other boundary vectors have positive angular */
/* separation from that face. */
/* Because of this limitation, this algorithm should be used only */
/* after a simple FOV axis-finding approach, such as using as the */
/* FOV axis the average of the boundary vectors, has been tried */
/* unsuccessfully. */
/* Note that it's easy to construct FOVs where the average of the */
/* boundary vectors doesn't yield a viable axis: a FOV of angular */
/* width nearly equal to pi radians, with a sufficiently large */
/* number of boundary vectors on one side and few boundary vectors */
/* on the other, is one such example. This routine can find an */
/* axis for many such intractable FOVs---that's why this routine */
/* should be called after the simple approach fails. */
/* $ Examples */
/* See SPICELIB private routine ZZFOVAXI. */
/* $ Restrictions */
/* 1) This is a SPICE private routine. User applications should not */
/* call this routine. */
/* 2) There are "reasonable" polygonal FOVs that cannot be handled */
/* by this routine. See the discussion in Particulars above. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB 1.0.0, 05-MAR-2009 (NJB) */
/* -& */
/* $ Index_Entries */
/* Create axis vector for polygonal FOV */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Parameter adjustments */
bounds_dim2 = *n;
/* Function Body */
if (return_()) {
return 0;
}
chkin_("ZZHULLAX", (ftnlen)8);
/* Nothing found yet. */
found = FALSE_;
xidx = 0;
/* We must have at least 3 boundary vectors. */
if (*n < 3) {
setmsg_("Polygonal FOV requires at least 3 boundary vectors but numb"
"er supplied for # was #.", (ftnlen)83);
errch_("#", inst, (ftnlen)1, inst_len);
errint_("#", n, (ftnlen)1);
sigerr_("SPICE(INVALIDCOUNT)", (ftnlen)19);
chkout_("ZZHULLAX", (ftnlen)8);
return 0;
}
/* Find an exterior face of the pyramid defined by the */
/* input boundary vectors. Since most polygonal FOVs will have */
/* an exterior face bounded by two consecutive rays, we'll */
/* try pairs of consecutive rays first. If this fails, we'll */
/* try each pair of rays. */
i__ = 1;
while(i__ <= *n && ! found) {
/* Set the index of the next ray. When we get to the */
/* last boundary vector, the next ray is the first. */
if (i__ == *n) {
next = 1;
} else {
next = i__ + 1;
}
/* Find the cross product of the first ray with the */
/* second. Depending on the ordering of the boundary */
/* vectors, this could be an inward or outward normal, */
/* in the case the current face is exterior. */
vcrss_(&bounds[(i__1 = i__ * 3 - 3) < bounds_dim2 * 3 && 0 <= i__1 ?
i__1 : s_rnge("bounds", i__1, "zzhullax_", (ftnlen)408)], &
bounds[(i__2 = next * 3 - 3) < bounds_dim2 * 3 && 0 <= i__2 ?
i__2 : s_rnge("bounds", i__2, "zzhullax_", (ftnlen)408)], cp);
/* We insist on consecutive boundary vectors being */
/* linearly independent. */
if (vzero_(cp)) {
setmsg_("Polygonal FOV must have linearly independent consecutiv"
"e boundary but vectors at indices # and # have cross pro"
"duct equal to the zero vector. Instrument is #.", (ftnlen)
158);
errint_("#", &i__, (ftnlen)1);
errint_("#", &next, (ftnlen)1);
errch_("#", inst, (ftnlen)1, inst_len);
sigerr_("SPICE(DEGENERATECASE)", (ftnlen)21);
chkout_("ZZHULLAX", (ftnlen)8);
return 0;
}
/* See whether the other boundary vectors have angular */
/* separation of at least MARGIN from the plane containing */
/* the current face. */
pass1 = TRUE_;
ok = TRUE_;
m = 1;
while(m <= *n && ok) {
/* Find the angular separation of CP and the Mth vector if the */
/* latter is not an edge of the current face. */
if (m != i__ && m != next) {
sep = vsep_(cp, &bounds[(i__1 = m * 3 - 3) < bounds_dim2 * 3
&& 0 <= i__1 ? i__1 : s_rnge("bounds", i__1, "zzhull"
"ax_", (ftnlen)446)]);
if (pass1) {
/* Adjust CP if necessary so that it points */
/* toward the interior of the pyramid. */
if (sep > halfpi_()) {
/* Invert the cross product vector and adjust SEP */
/* accordingly. Within this "M" loop, all other */
/* angular separations will be computed using the new */
/* value of CP. */
vsclip_(&c_b20, cp);
sep = pi_() - sep;
}
pass1 = FALSE_;
}
ok = sep < halfpi_() - 1e-12;
}
if (ok) {
/* Consider the next boundary vector. */
++m;
}
}
/* We've tested each boundary vector against the current face, or */
/* else the loop terminated early because a vector with */
/* insufficient angular separation from the plane containing the */
/* face was found. */
if (ok) {
/* The current face is exterior. It's bounded by rays I and */
/* NEXT. */
xidx = i__;
found = TRUE_;
} else {
/* Look at the next face of the pyramid. */
++i__;
}
}
/* If we didn't find an exterior face, we'll have to look at each */
/* face bounded by a pair of rays, even if those rays are not */
/* adjacent. (This can be a very slow process is N is large.) */
if (! found) {
i__ = 1;
while(i__ <= *n && ! found) {
/* Consider all ray pairs (I,NEXT) where NEXT > I. */
next = i__ + 1;
while(next <= *n && ! found) {
/* Find the cross product of the first ray with the second. */
/* If the current face is exterior, CP could be an inward */
/* or outward normal, depending on the ordering of the */
/* boundary vectors. */
vcrss_(&bounds[(i__1 = i__ * 3 - 3) < bounds_dim2 * 3 && 0 <=
i__1 ? i__1 : s_rnge("bounds", i__1, "zzhullax_", (
ftnlen)530)], &bounds[(i__2 = next * 3 - 3) <
bounds_dim2 * 3 && 0 <= i__2 ? i__2 : s_rnge("bounds",
i__2, "zzhullax_", (ftnlen)530)], cp);
/* It's allowable for non-consecutive boundary vectors to */
/* be linearly dependent, but if we have such a pair, */
/* it doesn't define an exterior face. */
if (! vzero_(cp)) {
/* The rays having direction vectors indexed I and NEXT */
/* define a semi-infinite sector of a plane that might */
/* be of interest. */
/* Check whether all of the boundary vectors that are */
/* not edges of the current face have angular separation */
/* of at least MARGIN from the plane containing the */
/* current face. */
pass1 = TRUE_;
ok = TRUE_;
m = 1;
while(m <= *n && ok) {
/* Find the angular separation of CP and the Mth */
/* vector if the latter is not an edge of the current */
/* face. */
if (m != i__ && m != next) {
sep = vsep_(cp, &bounds[(i__1 = m * 3 - 3) <
bounds_dim2 * 3 && 0 <= i__1 ? i__1 :
s_rnge("bounds", i__1, "zzhullax_", (
ftnlen)560)]);
if (pass1) {
/* Adjust CP if necessary so that it points */
/* toward the interior of the pyramid. */
if (sep > halfpi_()) {
/* Invert the cross product vector and */
/* adjust SEP accordingly. Within this "M" */
/* loop, all other angular separations will */
/* be computed using the new value of CP. */
vsclip_(&c_b20, cp);
sep = pi_() - sep;
}
pass1 = FALSE_;
}
ok = sep < halfpi_() - 1e-12;
}
if (ok) {
/* Consider the next boundary vector. */
++m;
}
}
/* We've tested each boundary vector against the current */
/* face, or else the loop terminated early because a */
/* vector with insufficient angular separation from the */
/* plane containing the face was found. */
if (ok) {
/* The current face is exterior. It's bounded by rays */
/* I and NEXT. */
xidx = i__;
found = TRUE_;
}
/* End of angular separation test block. */
}
/* End of non-zero cross product block. */
if (! found) {
/* Look at the face bounded by the rays */
/* at indices I and NEXT+1. */
++next;
}
}
/* End of NEXT loop. */
if (! found) {
/* Look at the face bounded by the pairs of rays */
/* including the ray at index I+1. */
++i__;
}
}
/* End of I loop. */
}
/* End of search for exterior face using each pair of rays. */
/* If we still haven't found an exterior face, we can't continue. */
if (! found) {
setmsg_("Unable to find face of convex hull of FOV of instrument #.",
(ftnlen)58);
errch_("#", inst, (ftnlen)1, inst_len);
sigerr_("SPICE(FACENOTFOUND)", (ftnlen)19);
chkout_("ZZHULLAX", (ftnlen)8);
return 0;
}
/* Arrival at this point means that the rays at indices */
/* XIDX and NEXT define a plane such that all boundary */
/* vectors lie in a half-space bounded by that plane. */
/* We're now going to define a set of orthonormal basis vectors: */
/* +X points along the angle bisector of the bounding vectors */
/* of the exterior face. */
/* +Y points along CP. */
/* +Z is the cross product of +X and +Y. */
/* We'll call the reference frame having these basis vectors */
/* the "face frame." */
vhat_(&bounds[(i__1 = i__ * 3 - 3) < bounds_dim2 * 3 && 0 <= i__1 ? i__1 :
s_rnge("bounds", i__1, "zzhullax_", (ftnlen)683)], ray1);
vhat_(&bounds[(i__1 = next * 3 - 3) < bounds_dim2 * 3 && 0 <= i__1 ? i__1
: s_rnge("bounds", i__1, "zzhullax_", (ftnlen)684)], ray2);
vlcom_(&c_b36, ray1, &c_b36, ray2, xvec);
vhatip_(xvec);
vhat_(cp, yvec);
ucrss_(xvec, yvec, zvec);
/* Create a transformation matrix to map the input boundary */
/* vectors into the face frame. */
for (i__ = 1; i__ <= 3; ++i__) {
trans[(i__1 = i__ * 3 - 3) < 9 && 0 <= i__1 ? i__1 : s_rnge("trans",
i__1, "zzhullax_", (ftnlen)698)] = xvec[(i__2 = i__ - 1) < 3
&& 0 <= i__2 ? i__2 : s_rnge("xvec", i__2, "zzhullax_", (
ftnlen)698)];
trans[(i__1 = i__ * 3 - 2) < 9 && 0 <= i__1 ? i__1 : s_rnge("trans",
i__1, "zzhullax_", (ftnlen)699)] = yvec[(i__2 = i__ - 1) < 3
&& 0 <= i__2 ? i__2 : s_rnge("yvec", i__2, "zzhullax_", (
ftnlen)699)];
trans[(i__1 = i__ * 3 - 1) < 9 && 0 <= i__1 ? i__1 : s_rnge("trans",
i__1, "zzhullax_", (ftnlen)700)] = zvec[(i__2 = i__ - 1) < 3
&& 0 <= i__2 ? i__2 : s_rnge("zvec", i__2, "zzhullax_", (
ftnlen)700)];
}
/* Now we're going to compute the longitude of each boundary in the */
/* face frame. The vectors with indices XIDX and NEXT are excluded. */
/* We expect all longitudes to be between MARGIN and pi - MARGIN. */
minlon = pi_();
maxlon = 0.;
minix = 1;
maxix = 1;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ != xidx && i__ != next) {
/* The current vector is not a boundary of our edge, */
/* so find its longitude. */
mxv_(trans, &bounds[(i__2 = i__ * 3 - 3) < bounds_dim2 * 3 && 0 <=
i__2 ? i__2 : s_rnge("bounds", i__2, "zzhullax_", (
ftnlen)720)], v);
reclat_(v, &r__, &lon, &lat);
/* Update the longitude bounds. */
if (lon < minlon) {
minix = i__;
minlon = lon;
}
if (lon > maxlon) {
maxix = i__;
maxlon = lon;
}
}
}
/* If the longitude bounds are not as expected, don't try */
/* to continue. */
if (minlon < 2e-12) {
setmsg_("Minimum boundary vector longitude in exterior face frame is"
" # radians. Minimum occurs at index #. This FOV does not con"
"form to the requirements of this routine. Instrument is #.", (
ftnlen)177);
errdp_("#", &minlon, (ftnlen)1);
errint_("#", &minix, (ftnlen)1);
errch_("#", inst, (ftnlen)1, inst_len);
sigerr_("SPICE(NOTSUPPORTED)", (ftnlen)19);
chkout_("ZZHULLAX", (ftnlen)8);
return 0;
} else if (maxlon > pi_() - 2e-12) {
setmsg_("Maximum boundary vector longitude in exterior face frame is"
" # radians. Maximum occurs at index #. This FOV does not con"
"form to the requirements of this routine. Instrument is #.", (
ftnlen)177);
errdp_("#", &maxlon, (ftnlen)1);
errint_("#", &maxix, (ftnlen)1);
errch_("#", inst, (ftnlen)1, inst_len);
sigerr_("SPICE(FOVTOOWIDE)", (ftnlen)17);
chkout_("ZZHULLAX", (ftnlen)8);
return 0;
}
/* Let delta represent the amount we can rotate the exterior */
/* face clockwise about +Z without contacting another boundary */
/* vector. */
delta = pi_() - maxlon;
/* Rotate +Y by -DELTA/2 about +Z. The result is our candidate */
/* FOV axis. Make the axis vector unit length. */
d__1 = -delta / 2;
vrotv_(yvec, zvec, &d__1, axis);
vhatip_(axis);
/* If we have a viable result, ALL boundary vectors have */
/* angular separation less than HALFPI-MARGIN from AXIS. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
sep = vsep_(&bounds[(i__2 = i__ * 3 - 3) < bounds_dim2 * 3 && 0 <=
i__2 ? i__2 : s_rnge("bounds", i__2, "zzhullax_", (ftnlen)794)
], axis);
if (sep > halfpi_() - 1e-12) {
setmsg_("Boundary vector at index # has angular separation of # "
"radians from candidate FOV axis. This FOV does not confo"
"rm to the requirements of this routine. Instrument is #.",
(ftnlen)167);
errint_("#", &i__, (ftnlen)1);
errdp_("#", &sep, (ftnlen)1);
errch_("#", inst, (ftnlen)1, inst_len);
sigerr_("SPICE(FOVTOOWIDE)", (ftnlen)17);
chkout_("ZZHULLAX", (ftnlen)8);
return 0;
}
}
chkout_("ZZHULLAX", (ftnlen)8);
return 0;
} /* zzhullax_ */
/* $Procedure RDCMD (Read command file) */
/* Subroutine */ int rdcmd_(char *cmdfil, char *cmdsym, integer *cmdptr, char
*cmdval, ftnlen cmdfil_len, ftnlen cmdsym_len, ftnlen cmdval_len)
{
/* Initialized data */
static char kwds1[32*2] = "LEAPSECONDS_KERNEL 1 1 " "SPK_KERNEL"
" 1 1000 ";
static char kwds2[32*5] = "SOURCE_SPK_KERNEL 1 1000 " "LOG_FILE "
" 0 1 " "BODIES 0 1 " "BEGI"
"N_TIME 0 1000 " "INCLUDE_TEXT_FILE 0 1000 ";
static char kwds3[32*3] = "BODIES 0 1 " "BEGIN_TIME"
" 0 1000 " "INCLUDE_COMMENTS 0 1 ";
static char kwds4[32*1] = "END_TIME 1 1 ";
/* System generated locals */
cilist ci__1;
/* Builtin functions */
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void);
/* Local variables */
static char line[350];
static integer unit;
extern /* Subroutine */ int chkin_(char *, ftnlen), cperr_(char *,
integer *, ftnlen), repmi_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
static char tabval[32*26];
extern /* Subroutine */ int evalcp_(char *, logical *, char *, integer *,
char *, logical *, ftnlen, ftnlen, ftnlen), initcp_(char *,
integer *, char *, char *, ftnlen, ftnlen, ftnlen);
static char reason[160];
extern /* Subroutine */ int sigerr_(char *, ftnlen);
static integer tabptr[26];
extern /* Subroutine */ int prefix_(char *, integer *, char *, ftnlen,
ftnlen);
static char tabsym[32*26];
extern /* Subroutine */ int ssizec_(integer *, char *, ftnlen), chkout_(
char *, ftnlen);
static integer linnum, iostat;
extern /* Subroutine */ int setmsg_(char *, ftnlen), ssizei_(integer *,
integer *);
extern logical return_(void);
extern /* Subroutine */ int syputc_(char *, char *, integer *, char *,
integer *, char *, ftnlen, ftnlen, ftnlen, ftnlen), txtopr_(char *
, integer *, ftnlen);
static logical eof, err;
/* $ Abstract */
/* Parse the command 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 */
/* None. */
/* $ Keywords */
/* None. */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* CMDFIL I Name of command file. */
/* CMDSYM, */
/* CMDPTR, */
/* CMDVAL O Command symbol table. */
/* $ Detailed_Input */
/* CMDFIL is the name of the command file. */
/* $ Detailed_Output */
/* CMDSYM, */
/* CMDPTR, */
/* CMDVAL is the command symbol table. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) An error is signaled if the file cannot be parsed */
/* successfully. */
/* $ Files */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* M.J. Spencer (JPL) */
/* $ Version */
/* - Beta Version 1.1.0, 17-JAN-2014 (BVS) */
/* Increased LINLEN from 120 to 350 (350 = 300 characters for */
/* value consistent with VALLEN in CPARSE_2 and the main program */
/* + 50 more characters for the keyword name, =, and blanks.) */
/* Increased maximum counts of child values in KWDS* from 300 to */
/* 1000 for all values. */
/* Saved all variables. */
/* - Beta Version 1.0.0, 26-JAN-1994 (MJS) */
/* -& */
/* SPICELIB functions */
/* Other functions */
/* Local parameters */
/* Local variables */
/* Save all. */
/* Initial values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("RDCMD", (ftnlen)5);
}
/* Initialize the parser. */
ssizec_(&c__20, tabsym, (ftnlen)32);
ssizei_(&c__20, tabptr);
ssizec_(&c__20, tabval, (ftnlen)32);
syputc_("HEAD", kwds1, &c__2, tabsym, tabptr, tabval, (ftnlen)4, (ftnlen)
32, (ftnlen)32, (ftnlen)32);
syputc_("SPK_KERNEL", kwds2, &c__5, tabsym, tabptr, tabval, (ftnlen)10, (
ftnlen)32, (ftnlen)32, (ftnlen)32);
syputc_("SOURCE_SPK_KERNEL", kwds3, &c__3, tabsym, tabptr, tabval, (
ftnlen)17, (ftnlen)32, (ftnlen)32, (ftnlen)32);
syputc_("BEGIN_TIME", kwds4, &c__1, tabsym, tabptr, tabval, (ftnlen)10, (
ftnlen)32, (ftnlen)32, (ftnlen)32);
initcp_(tabsym, tabptr, tabval, "HEAD", (ftnlen)32, (ftnlen)32, (ftnlen)4)
;
/* Open the command file, and parse its contents */
txtopr_(cmdfil, &unit, cmdfil_len);
eof = FALSE_;
err = FALSE_;
while(! eof && ! err) {
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = unit;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, line, (ftnlen)350);
if (iostat != 0) {
goto L100001;
}
iostat = e_rsfe();
L100001:
eof = iostat != 0;
evalcp_(line, &eof, cmdsym, cmdptr, cmdval, &err, (ftnlen)350,
cmdsym_len, cmdval_len);
}
if (err) {
cperr_(reason, &linnum, (ftnlen)160);
repmi_(reason, "#", &linnum, reason, (ftnlen)160, (ftnlen)1, (ftnlen)
160);
prefix_(":", &c__1, reason, (ftnlen)1, (ftnlen)160);
prefix_(cmdfil, &c__0, reason, cmdfil_len, (ftnlen)160);
setmsg_(reason, (ftnlen)160);
sigerr_("SPICE(CMDPARSEERROR)", (ftnlen)20);
chkout_("RDCMD", (ftnlen)5);
return 0;
}
chkout_("RDCMD", (ftnlen)5);
return 0;
} /* rdcmd_ */
/* $Procedure SPKW21 ( Write SPK segment, type 21 ) */
/* Subroutine */ int spkw21_(integer *handle, integer *body, integer *center,
char *frame, doublereal *first, doublereal *last, char *segid,
integer *n, integer *dlsize, doublereal *dlines, doublereal *epochs,
ftnlen frame_len, ftnlen segid_len)
{
/* System generated locals */
integer dlines_dim1, dlines_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
integer i__, j;
extern /* Subroutine */ int chkin_(char *, ftnlen);
doublereal descr[5];
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen),
errdp_(char *, doublereal *, ftnlen), dafada_(doublereal *,
integer *), dafbna_(integer *, doublereal *, char *, ftnlen),
dafena_(void);
extern logical failed_(void);
integer chrcod, refcod, maxdim;
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int namfrm_(char *, integer *, ftnlen), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen);
doublereal prvepc;
extern /* Subroutine */ int setmsg_(char *, ftnlen);
integer maxdsz;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen), spkpds_(
integer *, integer *, char *, integer *, doublereal *, doublereal
*, doublereal *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Write a type 21 segment to an SPK 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 */
/* NAIF_IDS */
/* SPK */
/* TIME */
/* $ Keywords */
/* EPHEMERIS */
/* FILES */
/* $ 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 an SPK file open for writing. */
/* BODY I NAIF code for an ephemeris object. */
/* CENTER I NAIF code for center of motion of BODY. */
/* FRAME I Reference frame name. */
/* FIRST I Start time of interval covered by segment. */
/* LAST I End time of interval covered by segment. */
/* SEGID I Segment identifier. */
/* N I Number of difference lines in segment. */
/* DLSIZE I Difference line size. */
/* DLINES I Array of difference lines. */
/* EPOCHS I Coverage end times of difference lines. */
/* MAXTRM P Maximum number of terms per difference table */
/* component. */
/* $ Detailed_Input */
/* HANDLE is the file handle of an SPK file that has been */
/* opened for writing. */
/* BODY is the NAIF integer code for an ephemeris object */
/* whose state relative to another body is described */
/* by the segment to be created. */
/* CENTER is the NAIF integer code for the center of motion */
/* of the object identified by BODY. */
/* FRAME is the NAIF name for a reference frame relative to */
/* which the state information for BODY is specified. */
/* FIRST, */
/* LAST are, respectively, the start and stop times of */
/* the time interval over which the segment defines */
/* the state of BODY. */
/* SEGID is the segment identifier. An SPK segment */
/* identifier may contain up to 40 characters. */
/* N is the number of difference lines in the input */
/* difference line array. */
/* DLSIZE is the size of each difference line data structure */
/* in the difference line array input DLINES. 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 */
/* DLINES contains a time-ordered array of difference lines. */
/* The Ith difference line occupies elements (1,I) */
/* through (MAXDIM,I) of DLINES, where MAXDIM is */
/* as described above in the description of DLSIZE. */
/* Each difference line represents the state (x, y, */
/* z, dx/dt, dy/dt, dz/dt, in kilometers and */
/* kilometers per second) of BODY relative to CENTER, */
/* specified relative to FRAME, for an interval of */
/* time. The time interval covered by the Ith */
/* difference line ends at the Ith element of the */
/* array EPOCHS (described below). The interval */
/* covered by the first difference line starts at the */
/* segment start time. */
/* The contents of a difference line are as shown */
/* below: */
/* 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 */
/* The reference position and velocity are those of */
/* BODY relative to CENTER at the reference epoch. */
/* (A difference line is essentially a polynomial */
/* expansion of acceleration about the reference */
/* epoch.) */
/* EPOCHS is an array of epochs corresponding to the members */
/* of the difference line array. The epochs are */
/* specified as seconds past J2000 TDB. */
/* The first difference line covers the time interval */
/* from the segment start time to EPOCHS(1). For */
/* I > 1, the Ith difference line covers the half-open */
/* time interval from, but not including, EPOCHS(I-1) */
/* through EPOCHS(I). */
/* The elements of EPOCHS must be strictly increasing. */
/* $ Detailed_Output */
/* None. See $Particulars for a description of the effect of this */
/* routine. */
/* $ 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 */
/* If any of the following exceptions occur, this routine will return */
/* without creating a new segment. */
/* 1) If FRAME is not a recognized name, the error */
/* SPICE(INVALIDREFFRAME) is signaled. */
/* 2) If the last non-blank character of SEGID occurs past index 40, */
/* the error SPICE(SEGIDTOOLONG) is signaled. */
/* 3) If SEGID contains any nonprintable characters, the error */
/* SPICE(NONPRINTABLECHARS) is signaled. */
/* 4) If the number of difference lines N is not at least one, */
/* the error SPICE(INVALIDCOUNT) will be signaled. */
/* 5) If FIRST is greater than LAST then the error */
/* SPICE(BADDESCRTIMES) will be signaled. */
/* 6) If the elements of the array EPOCHS are not in strictly */
/* increasing order, the error SPICE(TIMESOUTOFORDER) will be */
/* signaled. */
/* 7) If the last epoch EPOCHS(N) is less than LAST, the error */
/* SPICE(COVERAGEGAP) will be signaled. */
/* 8) If DLSIZE is greater than the limit */
/* ( 4 * MAXTRM ) + 11 */
/* the error SPICE(DIFFLINETOOLARGE) will be signaled. If */
/* DLSIZE is less than 71, the error SPICE(DIFFLINETOOSMALL) */
/* will be signaled. */
/* 9) If any value in the step size array of any difference */
/* line is zero, the error SPICE(ZEROSTEP) will be signaled. */
/* $ Files */
/* A new type 21 SPK segment is written to the SPK file attached */
/* to HANDLE. */
/* $ Particulars */
/* This routine writes an SPK type 21 data segment to the open SPK */
/* file according to the format described in the type 21 section of */
/* the SPK Required Reading. The SPK file must have been opened with */
/* write access. */
/* $ Examples */
/* Suppose that you have difference lines and are prepared to */
/* produce a segment of type 21 in an SPK file. */
/* The following code fragment could be used to add the new segment */
/* to a previously opened SPK file attached to HANDLE. The file must */
/* have been opened with write access. */
/* C */
/* C Create a segment identifier. */
/* C */
/* SEGID = 'MY_SAMPLE_SPK_TYPE_21_SEGMENT' */
/* C */
/* C Write the segment. */
/* C */
/* CALL SPKW21 ( HANDLE, BODY, CENTER, FRAME, */
/* . FIRST, LAST, SEGID, N, */
/* . DLSIZE, DLINES, EPOCHS ) */
/* $ Restrictions */
/* 1) The validity of the difference lines is not checked by */
/* this routine. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 03-FEB-2014 (NJB) */
/* -& */
/* $ Index_Entries */
/* write spk type_21 ephemeris data segment */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* MINDSZ is the minimum MDA size; this is the size */
/* of type 1 MDAs. */
/* Local variables */
/* Local variables */
/* Standard SPICE error handling. */
/* Parameter adjustments */
dlines_dim1 = *dlsize;
dlines_offset = dlines_dim1 + 1;
/* Function Body */
if (return_()) {
return 0;
}
chkin_("SPKW21", (ftnlen)6);
/* Make sure the difference line size is within limits. */
maxdsz = 111;
if (*dlsize > maxdsz) {
setmsg_("The input difference line size is #, while the maximum supp"
"orted by this routine is #. It is possible that this problem"
" is due to your SPICE Toolkit being out of date.", (ftnlen)
167);
errint_("#", dlsize, (ftnlen)1);
errint_("#", &maxdsz, (ftnlen)1);
sigerr_("SPICE(DIFFLINETOOLARGE)", (ftnlen)23);
chkout_("SPKW21", (ftnlen)6);
return 0;
}
if (*dlsize < 71) {
setmsg_("The input difference line size is #, while the minimum supp"
"orted by this routine is #. It is possible that this problem"
" is due to your SPICE Toolkit being out of date.", (ftnlen)
167);
errint_("#", dlsize, (ftnlen)1);
errint_("#", &c__71, (ftnlen)1);
sigerr_("SPICE(DIFFLINETOOSMALL)", (ftnlen)23);
chkout_("SPKW21", (ftnlen)6);
return 0;
}
/* Get the NAIF integer code for the reference frame. */
namfrm_(frame, &refcod, frame_len);
if (refcod == 0) {
setmsg_("The reference frame # is not supported.", (ftnlen)39);
errch_("#", frame, (ftnlen)1, frame_len);
sigerr_("SPICE(INVALIDREFFRAME)", (ftnlen)22);
chkout_("SPKW21", (ftnlen)6);
return 0;
}
/* Check to see if the segment identifier is too long. */
if (lastnb_(segid, segid_len) > 40) {
setmsg_("Segment identifier contains more than 40 characters.", (
ftnlen)52);
sigerr_("SPICE(SEGIDTOOLONG)", (ftnlen)19);
chkout_("SPKW21", (ftnlen)6);
return 0;
}
/* Now check that all the characters in the segment identifier */
/* can be printed. */
i__1 = lastnb_(segid, segid_len);
for (i__ = 1; i__ <= i__1; ++i__) {
chrcod = *(unsigned char *)&segid[i__ - 1];
if (chrcod < 32 || chrcod > 126) {
setmsg_("The segment identifier contains nonprintable characters",
(ftnlen)55);
sigerr_("SPICE(NONPRINTABLECHARS)", (ftnlen)24);
chkout_("SPKW21", (ftnlen)6);
return 0;
}
}
/* The difference line count must be at least one. */
if (*n < 1) {
setmsg_("The difference line count was #; the count must be at least"
" one.", (ftnlen)64);
errint_("#", n, (ftnlen)1);
sigerr_("SPICE(INVALIDCOUNT)", (ftnlen)19);
chkout_("SPKW21", (ftnlen)6);
return 0;
}
/* The segment stop time should be greater than or equal to */
/* the begin time. */
if (*first > *last) {
setmsg_("The segment start time: # is greater than the segment end t"
"ime: #", (ftnlen)65);
errdp_("#", first, (ftnlen)1);
errdp_("#", last, (ftnlen)1);
sigerr_("SPICE(BADDESCRTIMES)", (ftnlen)20);
chkout_("SPKW21", (ftnlen)6);
return 0;
}
/* Make sure the epochs form a strictly increasing sequence. */
prvepc = epochs[0];
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
if (epochs[i__ - 1] <= prvepc) {
setmsg_("EPOCH # having index # is not greater than its predeces"
"sor #.", (ftnlen)61);
errdp_("#", &epochs[i__ - 1], (ftnlen)1);
errint_("#", &i__, (ftnlen)1);
errdp_("#", &epochs[i__ - 2], (ftnlen)1);
sigerr_("SPICE(TIMESOUTOFORDER)", (ftnlen)22);
chkout_("SPKW21", (ftnlen)6);
return 0;
}
prvepc = epochs[i__ - 1];
}
/* Make sure there's no gap between the last difference line */
/* epoch and the end of the time interval defined by the segment */
/* descriptor. */
if (epochs[*n - 1] < *last) {
setmsg_("Segment has coverage gap: segment end time # follows last e"
"poch #.", (ftnlen)66);
errdp_("#", last, (ftnlen)1);
errdp_("#", &epochs[*n - 1], (ftnlen)1);
sigerr_("SPICE(COVERAGEGAP)", (ftnlen)18);
chkout_("SPKW21", (ftnlen)6);
return 0;
}
/* Check the step size vectors in the difference lines. */
maxdim = (*dlsize - 11) / 4;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = maxdim + 1;
for (j = 2; j <= i__2; ++j) {
if (dlines[j + i__ * dlines_dim1 - dlines_offset] == 0.) {
setmsg_("Step size was zero at step size vector index # with"
"in difference line #.", (ftnlen)72);
i__3 = j - 1;
errint_("#", &i__3, (ftnlen)1);
errint_("#", &i__, (ftnlen)1);
sigerr_("SPICE(ZEROSTEP)", (ftnlen)15);
chkout_("SPKW21", (ftnlen)6);
return 0;
}
}
}
/* If we made it this far, we're ready to start writing the segment. */
/* Create the segment descriptor. */
spkpds_(body, center, frame, &c__21, first, last, descr, frame_len);
/* Begin a new segment. */
dafbna_(handle, descr, segid, segid_len);
if (failed_()) {
chkout_("SPKW21", (ftnlen)6);
return 0;
}
/* The type 21 segment structure is shown below: */
/* +-----------------------+ */
/* | Difference line 1 | */
/* +-----------------------+ */
/* | Difference line 2 | */
/* +-----------------------+ */
/* ... */
/* +-----------------------+ */
/* | Difference line N | */
/* +-----------------------+ */
/* | Epoch 1 | */
/* +-----------------------+ */
/* | Epoch 2 | */
/* +-----------------------+ */
/* ... */
/* +-----------------------+ */
/* | Epoch N | */
/* +-----------------------+ */
/* | Epoch 100 | (First directory) */
/* +-----------------------+ */
/* ... */
/* +-----------------------+ */
/* | Epoch (N/100)*100 | (Last directory) */
/* +-----------------------+ */
/* | Max diff table size | */
/* +-----------------------+ */
/* | Number of diff lines | */
/* +-----------------------+ */
i__1 = *n * *dlsize;
dafada_(dlines, &i__1);
dafada_(epochs, n);
i__1 = *n / 100;
for (i__ = 1; i__ <= i__1; ++i__) {
dafada_(&epochs[i__ * 100 - 1], &c__1);
}
d__1 = (doublereal) maxdim;
dafada_(&d__1, &c__1);
d__1 = (doublereal) (*n);
dafada_(&d__1, &c__1);
/* As long as nothing went wrong, end the segment. */
if (! failed_()) {
dafena_();
}
chkout_("SPKW21", (ftnlen)6);
return 0;
} /* spkw21_ */
/* $Procedure HRMESP ( Hermite polynomial interpolation, equal spacing ) */
/* Subroutine */ int hrmesp_(integer *n, doublereal *first, doublereal *step,
doublereal *yvals, doublereal *x, doublereal *work, doublereal *f,
doublereal *df)
{
/* System generated locals */
integer yvals_dim1, work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5,
i__6, i__7;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
doublereal temp;
integer this__, prev, next;
doublereal newx;
integer i__, j;
extern /* Subroutine */ int chkin_(char *, ftnlen);
doublereal denom, c1, c2, xi;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
extern logical return_(void);
doublereal xij;
/* $ Abstract */
/* Evaluate, at a specified point, an Hermite interpolating */
/* polynomial for a specified set of coordinate pairs whose */
/* abscissas are equally spaced. */
/* $ 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 */
/* INTERPOLATION */
/* POLYNOMIAL */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* N I Number of points defining the polynomial. */
/* FIRST I First abscissa value. */
/* STEP I Step size. */
/* YVALS I Ordinate and derivative values. */
/* X I Point at which to interpolate the polynomial. */
/* WORK I-O Work space array. */
/* F O Interpolated function value at X. */
/* DF O Interpolated function's derivative at X. */
/* $ Detailed_Input */
/* N is the number of points defining the polynomial. */
/* The array YVALS contains 2*N elements. */
/* FIRST, */
/* STEP are, respectively, a starting abscissa value and a */
/* step size that define the set of abscissa values */
/* FIRST + (I-1) * STEP, I = 1, ..., N */
/* STEP must be non-zero. */
/* YVALS is an array of length 2*N containing ordinate and */
/* derivative values for each point in the domain */
/* defined by FIRST, STEP, and N. The elements */
/* YVALS( 2*I - 1 ) */
/* YVALS( 2*I ) */
/* give the value and first derivative of the output */
/* polynomial at the abscissa value */
/* FIRST + I * STEP */
/* where I ranges from 1 to N. */
/* WORK is a work space array. It is used by this routine */
/* as a scratch area to hold intermediate results. */
/* X is the abscissa value at which the interpolating */
/* polynomial and its derivative are to be evaluated. */
/* $ Detailed_Output */
/* F, */
/* DF are the value and derivative at X of the unique */
/* polynomial of degree 2N-1 that fits the points and */
/* derivatives defined by FIRST, STEP, and YVALS. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If STEP is zero, the error SPICE(INVALIDSTEPSIZE) will be */
/* signaled. */
/* 2) If N is less than 1, the error SPICE(INVALIDSIZE) is */
/* signaled. */
/* 3) This routine does not attempt to ward off or diagnose */
/* arithmetic overflows. */
/* $ Files */
/* None. */
/* $ Particulars */
/* Users of this routine must choose the number of points to use */
/* in their interpolation method. The authors of Reference [1] have */
/* this to say on the topic: */
/* Unless there is solid evidence that the interpolating function */
/* is close in form to the true function f, it is a good idea to */
/* be cautious about high-order interpolation. We */
/* enthusiastically endorse interpolations with 3 or 4 points, we */
/* are perhaps tolerant of 5 or 6; but we rarely go higher than */
/* that unless there is quite rigorous monitoring of estimated */
/* errors. */
/* The same authors offer this warning on the use of the */
/* interpolating function for extrapolation: */
/* ...the dangers of extrapolation cannot be overemphasized: */
/* An interpolating function, which is perforce an extrapolating */
/* function, will typically go berserk when the argument x is */
/* outside the range of tabulated values by more than the typical */
/* spacing of tabulated points. */
/* $ Examples */
/* 1) Fit a 7th degree polynomial through the points ( x, y, y' ) */
/* ( -1, 6, 3 ) */
/* ( 1, 8, 11 ) */
/* ( 3, 2210, 5115 ) */
/* ( 5, 78180, 109395 ) */
/* and evaluate this polynomial at x = 2. */
/* PROGRAM TEST_HRMINT */
/* DOUBLE PRECISION ANSWER */
/* DOUBLE PRECISION DERIV */
/* DOUBLE PRECISION FIRST */
/* DOUBLE PRECISION STEP */
/* DOUBLE PRECISION YVALS (8) */
/* DOUBLE PRECISION WORK (8,2) */
/* INTEGER N */
/* N = 4 */
/* YVALS(1) = 6.D0 */
/* YVALS(2) = 3.D0 */
/* YVALS(3) = 8.D0 */
/* YVALS(4) = 11.D0 */
/* YVALS(5) = 2210.D0 */
/* YVALS(6) = 5115.D0 */
/* YVALS(7) = 78180.D0 */
/* YVALS(8) = 109395.D0 */
/* FIRST = -1.D0 */
/* STEP = 2.D0 */
/* CALL HRMESP ( N, FIRST, STEP, YVALS, */
/* . 2.D0, WORK, ANSWER, DERIV ) */
/* WRITE (*,*) 'ANSWER = ', ANSWER */
/* WRITE (*,*) 'DERIV = ', DERIV */
/* END */
/* The returned value of ANSWER should be 141.D0, and the returned */
/* derivative value should be 456.D0, since the unique 7th degree */
/* polynomial that fits these constraints is */
/* 7 2 */
/* f(x) = x + 2x + 5 */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* [1] "Numerical Recipes---The Art of Scientific Computing" by */
/* William H. Press, Brian P. Flannery, Saul A. Teukolsky, */
/* William T. Vetterling (see sections 3.0 and 3.1). */
/* [2] "Elementary Numerical Analysis---An Algorithmic Approach" */
/* by S. D. Conte and Carl de Boor. See p. 64. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.2.1, 28-JAN-2014 (NJB) */
/* Fixed a few comment typos. */
/* - SPICELIB Version 1.2.0, 31-JAN-2002 (EDW) */
/* Added the use of DBLE to convert integer values */
/* used in DOUBLE PRECISION calculations. */
/* - SPICELIB Version 1.1.0, 28-DEC-2001 (NJB) */
/* Blanks following final newline were truncated to */
/* suppress compilation warnings on the SGI-N32 platform. */
/* - SPICELIB Version 1.0.0, 01-MAR-2000 (NJB) */
/* -& */
/* $ Index_Entries */
/* interpolate function using Hermite polynomial */
/* Hermite interpolation */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Check in only if an error is detected. */
/* Parameter adjustments */
work_dim1 = *n << 1;
work_offset = work_dim1 + 1;
yvals_dim1 = *n << 1;
/* Function Body */
if (return_()) {
return 0;
}
/* No data, no interpolation. */
if (*n < 1) {
chkin_("HRMESP", (ftnlen)6);
setmsg_("Array size must be positive; was #.", (ftnlen)35);
errint_("#", n, (ftnlen)1);
sigerr_("SPICE(INVALIDSIZE)", (ftnlen)18);
chkout_("HRMESP", (ftnlen)6);
return 0;
}
/* The step size must be non-zero. */
if (*step == 0.) {
chkin_("HRMESP", (ftnlen)6);
setmsg_("Step size was zero.", (ftnlen)19);
sigerr_("SPICE(INVALIDSTEPSIZE)", (ftnlen)22);
chkout_("HRMESP", (ftnlen)6);
return 0;
}
/* We can simplify the interpolation problem by shifting */
/* and scaling the abscissa values so that they start at 1 */
/* and are separated by a unit step. All we need to do here is */
/* shift and scale X. */
newx = (*x - *first) / *step + 1.;
/* For consistency with our scaled horizontal axis, we'll have */
/* scale our local derivative values by STEP, and scale our final */
/* computed derivative by 1/STEP. */
/* Copy the input array into WORK. Scale the derivatives at this */
/* step. After this, the first column of WORK represents the first */
/* column of our triangular interpolation table. */
i__1 = (*n << 1) - 1;
for (i__ = 1; i__ <= i__1; i__ += 2) {
work[(i__2 = i__ + work_dim1 - work_offset) < work_dim1 << 1 && 0 <=
i__2 ? i__2 : s_rnge("work", i__2, "hrmesp_", (ftnlen)331)] =
yvals[(i__3 = i__ - 1) < yvals_dim1 && 0 <= i__3 ? i__3 :
s_rnge("yvals", i__3, "hrmesp_", (ftnlen)331)];
}
i__1 = *n << 1;
for (i__ = 2; i__ <= i__1; i__ += 2) {
work[(i__2 = i__ + work_dim1 - work_offset) < work_dim1 << 1 && 0 <=
i__2 ? i__2 : s_rnge("work", i__2, "hrmesp_", (ftnlen)335)] =
yvals[(i__3 = i__ - 1) < yvals_dim1 && 0 <= i__3 ? i__3 :
s_rnge("yvals", i__3, "hrmesp_", (ftnlen)335)] * *step;
}
/* Compute the second column of the interpolation table: this */
/* consists of the N-1 values obtained by evaluating the */
/* first-degree interpolants at NEWX. We'll also evaluate the */
/* derivatives of these interpolants at NEWX and save the results in */
/* the second column of WORK. Because the derivative computations */
/* depend on the function computations from the previous column in */
/* the interpolation table, and because the function interpolation */
/* overwrites the previous column of interpolated function values, */
/* we must evaluate the derivatives first. */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
c1 = (doublereal) (i__ + 1) - newx;
c2 = newx - (doublereal) i__;
/* The second column of WORK contains interpolated derivative */
/* values. */
/* The odd-indexed interpolated derivatives are simply the input */
/* derivatives, after scaling. */
prev = (i__ << 1) - 1;
this__ = prev + 1;
next = this__ + 1;
work[(i__2 = prev + (work_dim1 << 1) - work_offset) < work_dim1 << 1
&& 0 <= i__2 ? i__2 : s_rnge("work", i__2, "hrmesp_", (ftnlen)
366)] = work[(i__3 = this__ + work_dim1 - work_offset) <
work_dim1 << 1 && 0 <= i__3 ? i__3 : s_rnge("work", i__3,
"hrmesp_", (ftnlen)366)];
/* The even-indexed interpolated derivatives are the slopes of */
/* the linear interpolating polynomials for adjacent input */
/* abscissa/ordinate pairs. No scaling is needed here. */
work[(i__2 = this__ + (work_dim1 << 1) - work_offset) < work_dim1 <<
1 && 0 <= i__2 ? i__2 : s_rnge("work", i__2, "hrmesp_", (
ftnlen)373)] = work[(i__3 = next + work_dim1 - work_offset) <
work_dim1 << 1 && 0 <= i__3 ? i__3 : s_rnge("work", i__3,
"hrmesp_", (ftnlen)373)] - work[(i__4 = prev + work_dim1 -
work_offset) < work_dim1 << 1 && 0 <= i__4 ? i__4 : s_rnge(
"work", i__4, "hrmesp_", (ftnlen)373)];
/* The first column of WORK contains interpolated function values. */
/* The odd-indexed entries are the linear Taylor polynomials, */
/* each input abscissa value, evaluated at NEWX. */
temp = work[(i__2 = this__ + work_dim1 - work_offset) < work_dim1 <<
1 && 0 <= i__2 ? i__2 : s_rnge("work", i__2, "hrmesp_", (
ftnlen)380)] * (newx - (doublereal) i__) + work[(i__3 = prev
+ work_dim1 - work_offset) < work_dim1 << 1 && 0 <= i__3 ?
i__3 : s_rnge("work", i__3, "hrmesp_", (ftnlen)380)];
work[(i__2 = this__ + work_dim1 - work_offset) < work_dim1 << 1 && 0
<= i__2 ? i__2 : s_rnge("work", i__2, "hrmesp_", (ftnlen)383)]
= c1 * work[(i__3 = prev + work_dim1 - work_offset) <
work_dim1 << 1 && 0 <= i__3 ? i__3 : s_rnge("work", i__3,
"hrmesp_", (ftnlen)383)] + c2 * work[(i__4 = next + work_dim1
- work_offset) < work_dim1 << 1 && 0 <= i__4 ? i__4 : s_rnge(
"work", i__4, "hrmesp_", (ftnlen)383)];
work[(i__2 = prev + work_dim1 - work_offset) < work_dim1 << 1 && 0 <=
i__2 ? i__2 : s_rnge("work", i__2, "hrmesp_", (ftnlen)386)] =
temp;
}
/* The last column entries were not computed by the preceding loop; */
/* compute them now. */
work[(i__1 = (*n << 1) - 1 + (work_dim1 << 1) - work_offset) < work_dim1
<< 1 && 0 <= i__1 ? i__1 : s_rnge("work", i__1, "hrmesp_", (
ftnlen)394)] = work[(i__2 = (*n << 1) + work_dim1 - work_offset) <
work_dim1 << 1 && 0 <= i__2 ? i__2 : s_rnge("work", i__2, "hrme"
"sp_", (ftnlen)394)];
work[(i__1 = (*n << 1) - 1 + work_dim1 - work_offset) < work_dim1 << 1 &&
0 <= i__1 ? i__1 : s_rnge("work", i__1, "hrmesp_", (ftnlen)395)] =
work[(i__2 = (*n << 1) + work_dim1 - work_offset) < work_dim1 <<
1 && 0 <= i__2 ? i__2 : s_rnge("work", i__2, "hrmesp_", (ftnlen)
395)] * (newx - *n) + work[(i__3 = (*n << 1) - 1 + work_dim1 -
work_offset) < work_dim1 << 1 && 0 <= i__3 ? i__3 : s_rnge("work",
i__3, "hrmesp_", (ftnlen)395)];
/* Compute columns 3 through 2*N of the table. */
i__1 = (*n << 1) - 1;
for (j = 2; j <= i__1; ++j) {
i__2 = (*n << 1) - j;
for (i__ = 1; i__ <= i__2; ++i__) {
/* In the theoretical construction of the interpolation table, */
/* there are 2*N abscissa values, since each input abcissa */
/* value occurs with multiplicity two. In this theoretical */
/* construction, the Jth column of the interpolation table */
/* contains results of evaluating interpolants that span J+1 */
/* consecutive abscissa values. The indices XI and XIJ below */
/* are used to pick the correct abscissa values out of this */
/* sequence of 2*N values. */
xi = (doublereal) ((i__ + 1) / 2);
xij = (doublereal) ((i__ + j + 1) / 2);
c1 = xij - newx;
c2 = newx - xi;
denom = xij - xi;
/* Compute the interpolated derivative at NEWX for the Ith */
/* interpolant. This is the derivative with respect to NEWX of */
/* the expression for the interpolated function value, which is */
/* the second expression below. This derivative computation */
/* is done first because it relies on the interpolated function */
/* values from the previous column of the interpolation table. */
/* The derivative expression here corresponds to equation */
/* 2.35 on page 64 in reference [2]. */
work[(i__3 = i__ + (work_dim1 << 1) - work_offset) < work_dim1 <<
1 && 0 <= i__3 ? i__3 : s_rnge("work", i__3, "hrmesp_", (
ftnlen)433)] = (c1 * work[(i__4 = i__ + (work_dim1 << 1)
- work_offset) < work_dim1 << 1 && 0 <= i__4 ? i__4 :
s_rnge("work", i__4, "hrmesp_", (ftnlen)433)] + c2 * work[
(i__5 = i__ + 1 + (work_dim1 << 1) - work_offset) <
work_dim1 << 1 && 0 <= i__5 ? i__5 : s_rnge("work", i__5,
"hrmesp_", (ftnlen)433)] + (work[(i__6 = i__ + 1 +
work_dim1 - work_offset) < work_dim1 << 1 && 0 <= i__6 ?
i__6 : s_rnge("work", i__6, "hrmesp_", (ftnlen)433)] -
work[(i__7 = i__ + work_dim1 - work_offset) < work_dim1 <<
1 && 0 <= i__7 ? i__7 : s_rnge("work", i__7, "hrmesp_", (
ftnlen)433)])) / denom;
/* Compute the interpolated function value at NEWX for the Ith */
/* interpolant. */
work[(i__3 = i__ + work_dim1 - work_offset) < work_dim1 << 1 && 0
<= i__3 ? i__3 : s_rnge("work", i__3, "hrmesp_", (ftnlen)
440)] = (c1 * work[(i__4 = i__ + work_dim1 - work_offset)
< work_dim1 << 1 && 0 <= i__4 ? i__4 : s_rnge("work",
i__4, "hrmesp_", (ftnlen)440)] + c2 * work[(i__5 = i__ +
1 + work_dim1 - work_offset) < work_dim1 << 1 && 0 <=
i__5 ? i__5 : s_rnge("work", i__5, "hrmesp_", (ftnlen)440)
]) / denom;
}
}
/* Our interpolated function value is sitting in WORK(1,1) at this */
/* point. The interpolated derivative is located in WORK(1,2). */
/* We must undo the scaling of the derivative. We've already */
/* checked that STEP is non-zero. */
*f = work[(i__1 = work_dim1 + 1 - work_offset) < work_dim1 << 1 && 0 <=
i__1 ? i__1 : s_rnge("work", i__1, "hrmesp_", (ftnlen)452)];
*df = work[(i__1 = (work_dim1 << 1) + 1 - work_offset) < work_dim1 << 1 &&
0 <= i__1 ? i__1 : s_rnge("work", i__1, "hrmesp_", (ftnlen)453)]
/ *step;
return 0;
} /* hrmesp_ */
/* $Procedure ZZXLATED ( Private --- Translate Double Precision Numbers ) */
/* Subroutine */ int zzxlated_(integer *inbff, char *input, integer *space,
doublereal *output, ftnlen input_len)
{
/* Initialized data */
static logical first = TRUE_;
static integer natbff = 0;
/* System generated locals */
integer i__1, i__2, i__3;
char ch__1[1];
static doublereal equiv_0[128];
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int zzddhgsd_(char *, integer *, char *, ftnlen,
ftnlen), zzplatfm_(char *, char *, ftnlen, ftnlen);
integer i__, j, k;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), errch_(char *, char *, ftnlen, ftnlen);
integer value;
extern /* Subroutine */ int moved_(doublereal *, integer *, doublereal *);
integer numdp;
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
static integer bigint;
#define dpbufr (equiv_0)
static char strbff[8*4];
#define inbufr ((integer *)equiv_0)
integer lenipt;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen);
extern integer intmin_(void);
extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen);
static integer smlint;
extern logical return_(void);
char tmpstr[8];
integer outpos;
/* $ 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. */
/* Convert double precision values from one binary file format */
/* to another. */
/* $ 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 */
/* PRIVATE */
/* $ Declarations */
/* $ Abstract */
/* Parameter declarations for the DAF/DAS handle manager. */
/* $ 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, DAS */
/* $ Keywords */
/* PRIVATE */
/* $ Particulars */
/* This include file contains parameters defining limits and */
/* integer codes that are utilized in the DAF/DAS handle manager */
/* routines. */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 1.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 1.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 1.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 1.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 1.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 1.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 1.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 1.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 1.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 1.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 1.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 1.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 1.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 1.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 1.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 1.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 1.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 1.0.1, 17-JUL-2002 */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 1.0.0, 07-NOV-2001 */
/* -& */
/* Unit and file table size parameters. */
/* FTSIZE is the maximum number of files (DAS and DAF) that a */
/* user may have open simultaneously. */
/* RSVUNT is the number of units protected from being locked */
/* to a particular handle by ZZDDHHLU. */
/* SCRUNT is the number of units protected for use by scratch */
/* files. */
/* UTSIZE is the maximum number of logical units this manager */
/* will utilize at one time. */
/* Access method enumeration. These parameters are used to */
/* identify which access method is associated with a particular */
/* handle. They need to be synchronized with the STRAMH array */
/* defined in ZZDDHGSD in the following fashion: */
/* STRAMH ( READ ) = 'READ' */
/* STRAMH ( WRITE ) = 'WRITE' */
/* STRAMH ( SCRTCH ) = 'SCRATCH' */
/* STRAMH ( NEW ) = 'NEW' */
/* These values are used in the file table variable FTAMH. */
/* Binary file format enumeration. These parameters are used to */
/* identify which binary file format is associated with a */
/* particular handle. They need to be synchronized with the STRBFF */
/* array defined in ZZDDHGSD in the following fashion: */
/* STRBFF ( BIGI3E ) = 'BIG-IEEE' */
/* STRBFF ( LTLI3E ) = 'LTL-IEEE' */
/* STRBFF ( VAXGFL ) = 'VAX-GFLT' */
/* STRBFF ( VAXDFL ) = 'VAX-DFLT' */
/* These values are used in the file table variable FTBFF. */
/* Some random string lengths... more documentation required. */
/* For now this will have to suffice. */
/* Architecture enumeration. These parameters are used to identify */
/* which file architecture is associated with a particular handle. */
/* They need to be synchronized with the STRARC array defined in */
/* ZZDDHGSD in the following fashion: */
/* STRARC ( DAF ) = 'DAF' */
/* STRARC ( DAS ) = 'DAS' */
/* These values will be used in the file table variable FTARC. */
/* For the following environments, record length is measured in */
/* characters (bytes) with eight characters per double precision */
/* number. */
/* Environment: Sun, Sun FORTRAN */
/* Source: Sun Fortran Programmer's Guide */
/* Environment: PC, MS FORTRAN */
/* Source: Microsoft Fortran Optimizing Compiler User's Guide */
/* Environment: Macintosh, Language Systems FORTRAN */
/* Source: Language Systems FORTRAN Reference Manual, */
/* Version 1.2, page 12-7 */
/* Environment: PC/Linux, g77 */
/* Source: Determined by experiment. */
/* Environment: PC, Lahey F77 EM/32 Version 4.0 */
/* Source: Lahey F77 EM/32 Language Reference Manual, */
/* page 144 */
/* Environment: HP-UX 9000/750, FORTRAN/9000 Series 700 computers */
/* Source: FORTRAN/9000 Reference-Series 700 Computers, */
/* page 5-110 */
/* Environment: NeXT Mach OS (Black Hardware), */
/* Absoft Fortran Version 3.2 */
/* Source: NAIF Program */
/* The following parameter defines the size of a string used */
/* to store a filenames on this target platform. */
/* The following parameter controls the size of the character record */
/* buffer used to read data from non-native files. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* INBFF I Binary file format of d.p. values in INPUT. */
/* INPUT I String containing d.p. values read as characters. */
/* SPACE I Number of d.p. values that can be placed in OUTPUT. */
/* OUTPUT O Translated d.p. values. */
/* $ Detailed_Input */
/* INBFF is an integer code that indicates the binary file */
/* format of INPUT. Acceptable values are the */
/* parameters: */
/* BIGI3E */
/* LTLI3E */
/* VAXGFL */
/* VAXDFL */
/* as defined in the include file 'zzddhman.inc'. */
/* INPUT is a string containing a group of d.p. values read */
/* from a file as a character string. The length of */
/* this string must be a multiple of the number of */
/* bytes used to store a d.p. value in a file utilizing */
/* INBFF. */
/* SPACE is the number of d.p. values that OUTPUT has room to */
/* store. */
/* $ Detailed_Output */
/* OUTPUT is an array of double precision values containing */
/* the translated values from INPUT into the native */
/* binary format. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* This routine signals several SPICE(BUG) exceptions. They are */
/* signaled when improperly specified inputs are passed into the */
/* routine or if the module or modules in its calling tree are */
/* improperly configured to run on this platform. Callers that */
/* prevent invalid inputs from being passed into this routine */
/* need not check in. See the $Restrictions section for a */
/* discussion of input argument restrictions. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine translates double precision values from a non-native */
/* binary format read from a file as a sequence of characters to the */
/* native format. */
/* $ Examples */
/* See ZZDAFGSR or ZZDAFGDR. */
/* $ Restrictions */
/* 1) Numeric data when read as characters from a file preserves */
/* the bit patterns present in the file in memory. */
/* 2) The intrinsic ICHAR preserves the bit pattern of the character */
/* byte read from a file. Namely if one examines the integer */
/* created the 8 least significant bits will be precisely those */
/* found in the character. */
/* 3) The size of double precision values on the target environment */
/* are a multiple of some number of bytes. */
/* 4) The length of the INPUT string is a multiple of the number */
/* of bytes for a double precision value in the INBFF format. */
/* 5) INBFF is supported for reading on this platform, and not */
/* equivalent to NATBFF on this platform. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* $ Version */
/* - SPICELIB Version 1.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 1.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 1.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 1.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 1.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 1.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 1.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 1.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 1.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 1.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 1.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 1.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 1.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 1.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 1.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 1.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 1.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 1.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 1.0.1, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 1.0.0, 12-NOV-2001 (FST) */
/* -& */
/* SPICELIB Functions */
/* Local Parameters */
/* Length of the double precision and integer buffers that */
/* are equivalenced. */
/* These parameters are used for arithmetic shifting. */
/* Local Variables */
/* Equivalence DPBUFR to INBUFR. */
/* Statement Functions */
/* Saved Variables */
/* Data Statements */
/* Statement Function Definitions */
/* This function controls the conversion of characters to integers. */
/* On some supported environments, ICHAR is not sufficient to */
/* produce the desired results. This, however, is not the case */
/* with this particular environment. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZXLATED", (ftnlen)8);
}
/* Perform some initialization tasks. */
if (first) {
/* Populate STRBFF. */
for (i__ = 1; i__ <= 4; ++i__) {
zzddhgsd_("BFF", &i__, strbff + (((i__1 = i__ - 1) < 4 && 0 <=
i__1 ? i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)
354)) << 3), (ftnlen)3, (ftnlen)8);
}
/* Fetch the native binary file format. */
zzplatfm_("FILE_FORMAT", tmpstr, (ftnlen)11, (ftnlen)8);
ucase_(tmpstr, tmpstr, (ftnlen)8, (ftnlen)8);
natbff = isrchc_(tmpstr, &c__4, strbff, (ftnlen)8, (ftnlen)8);
if (natbff == 0) {
setmsg_("The binary file format, '#', is not supported by this v"
"ersion of the toolkit. This is a serious problem, contac"
"t NAIF.", (ftnlen)118);
errch_("#", tmpstr, (ftnlen)1, (ftnlen)8);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZXLATED", (ftnlen)8);
return 0;
}
/* Store the largest value a 32-bit integer can actually */
/* hold. */
bigint = 2147483647;
/* Prepare the smallest value a 32-bit integer can actually */
/* store, regardless of what INTMIN returns. */
smlint = intmin_();
/* Set SMLINT to the appropriate value if INTMIN is too large. */
if (smlint == -2147483647) {
--smlint;
}
/* Do not perform initialization tasks again. */
first = FALSE_;
}
/* Check to see if INBFF makes sense. */
if (*inbff < 1 || *inbff > 4) {
setmsg_("The integer code used to indicate the binary file format of"
" the input integers, #, is out of range. This error should "
"never occur.", (ftnlen)131);
errint_("#", inbff, (ftnlen)1);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZXLATED", (ftnlen)8);
return 0;
}
/* Retrieve the length of the input string, and set the position */
/* into the output buffer to the beginning. */
lenipt = i_len(input, input_len);
outpos = 1;
/* Now branch based on NATBFF. */
if (natbff == 1) {
if (*inbff == 2) {
/* Check to see that the length of the input string is */
/* appropriate. Since this is a string containing LTL-IEEE */
/* d.p. values, and this is a BIG-IEEE machine characters */
/* are 1-byte and d.p. values are 8-bytes. So the length */
/* of INPUT must be a multiple of 8. */
numdp = lenipt / 8;
if (lenipt - (numdp << 3) != 0) {
setmsg_("The input string that is to be translated from the "
"binary format # to format # has a length that is not"
" a multiple of 4 bytes. This error should never occ"
"ur.", (ftnlen)158);
errch_("#", strbff + (((i__1 = *inbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)
450)) << 3), (ftnlen)1, (ftnlen)8);
errch_("#", strbff + (((i__1 = natbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)
451)) << 3), (ftnlen)1, (ftnlen)8);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZXLATED", (ftnlen)8);
return 0;
}
/* Verify there is enough room to store the results of */
/* the translation. */
if (numdp > *space) {
setmsg_("The caller specified that # double precision number"
"s are to be translated from binary format # to #. H"
"owever there is only room to hold # integers in the "
"output array. This error should never occur.", (
ftnlen)200);
errint_("#", &numdp, (ftnlen)1);
errch_("#", strbff + (((i__1 = *inbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)
471)) << 3), (ftnlen)1, (ftnlen)8);
errch_("#", strbff + (((i__1 = natbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)
472)) << 3), (ftnlen)1, (ftnlen)8);
errint_("#", space, (ftnlen)1);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZXLATED", (ftnlen)8);
return 0;
}
/* The remainder of this branch is devoted to translating */
/* and copying blocks of DPBLEN double precision numbers */
/* into OUTPUT. Initialize K, the integer index into the */
/* buffer equivalenced to DPBUFR. */
k = 1;
/* Start looping over each 8 character package in INPUT and */
/* converting it to double precision numbers. */
i__1 = numdp;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Compute the substring index of the first character */
/* in INPUT for this integer. */
j = (i__ - 1 << 3) + 1;
/* Now arrange the bytes properly. Since these characters */
/* were read from a file utilizing LTL-IEEE: */
/* . */
/* . */
/* . */
/* ------- */
/* | J | - Least Significant Byte of Mantissa */
/* ------- */
/* | J+1 | - Sixth Most Significant Mantissa Byte */
/* ------- */
/* | J+2 | - Fifth Most Significant Mantissa Byte */
/* ------- */
/* | J+3 | - Fourth Most Significant Mantissa Byte */
/* ------- */
/* | J+4 | - Third Most Significant Mantissa Byte */
/* ------- */
/* | J+5 | - Second Most Significant Mantissa Byte */
/* ------- */
/* | J+6 | - Tail of Exponent, Most Significant */
/* ------- Bits of the Mantissa */
/* | J+7 | - Sign Bit, Head of Exponent */
/* ------- */
/* . */
/* . */
/* . */
/* Now rearrange the bytes to place them in the */
/* proper order for d.p. values on BIG-IEEE machines. */
/* This is accomplished in the following manner: */
/* INPUT(J+4:J+4) */
/* INPUT(J+5:J+5)*SHFT8 */
/* INPUT(J+6:J+6)*SHFT16 */
/* + INPUT(J+7:J+7)*SHFT24 */
/* ------------------------- */
/* INBUFR(K) */
/* INPUT(J:J) */
/* INPUT(J+1:J+1)*SHFT8 */
/* INPUT(J+2:J+2)*SHFT16 */
/* + INPUT(J+3:J+3)*SHFT24 */
/* ------------------------- */
/* INBUFR(K+1) */
/* Utilize the military extension bit manipulation */
/* intrinsics to perform the necessary computations. */
/* It has been determined empirically that on these */
/* environments this is faster than arithmetic. */
i__2 = j + 3;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 4 - i__2);
value = *(unsigned char *)&ch__1[0];
inbufr[(i__2 = k - 1) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"inbufr", i__2, "zzxlated_", (ftnlen)553)] = value;
i__2 = j + 4;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 5 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 8;
inbufr[(i__2 = k - 1) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"inbufr", i__2, "zzxlated_", (ftnlen)557)] = inbufr[(
i__3 = k - 1) < 256 && 0 <= i__3 ? i__3 : s_rnge(
"inbufr", i__3, "zzxlated_", (ftnlen)557)] | value;
i__2 = j + 5;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 6 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 16;
inbufr[(i__2 = k - 1) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"inbufr", i__2, "zzxlated_", (ftnlen)561)] = inbufr[(
i__3 = k - 1) < 256 && 0 <= i__3 ? i__3 : s_rnge(
"inbufr", i__3, "zzxlated_", (ftnlen)561)] | value;
i__2 = j + 6;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 7 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 24;
inbufr[(i__2 = k - 1) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"inbufr", i__2, "zzxlated_", (ftnlen)565)] = inbufr[(
i__3 = k - 1) < 256 && 0 <= i__3 ? i__3 : s_rnge(
"inbufr", i__3, "zzxlated_", (ftnlen)565)] | value;
*(unsigned char *)&ch__1[0] = *(unsigned char *)&input[j - 1];
value = *(unsigned char *)&ch__1[0];
inbufr[(i__2 = k) < 256 && 0 <= i__2 ? i__2 : s_rnge("inbufr",
i__2, "zzxlated_", (ftnlen)569)] = value;
i__2 = j;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 1 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 8;
inbufr[(i__2 = k) < 256 && 0 <= i__2 ? i__2 : s_rnge("inbufr",
i__2, "zzxlated_", (ftnlen)573)] = inbufr[(i__3 = k)
< 256 && 0 <= i__3 ? i__3 : s_rnge("inbufr", i__3,
"zzxlated_", (ftnlen)573)] | value;
i__2 = j + 1;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 2 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 16;
inbufr[(i__2 = k) < 256 && 0 <= i__2 ? i__2 : s_rnge("inbufr",
i__2, "zzxlated_", (ftnlen)577)] = inbufr[(i__3 = k)
< 256 && 0 <= i__3 ? i__3 : s_rnge("inbufr", i__3,
"zzxlated_", (ftnlen)577)] | value;
i__2 = j + 2;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 3 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 24;
inbufr[(i__2 = k) < 256 && 0 <= i__2 ? i__2 : s_rnge("inbufr",
i__2, "zzxlated_", (ftnlen)581)] = inbufr[(i__3 = k)
< 256 && 0 <= i__3 ? i__3 : s_rnge("inbufr", i__3,
"zzxlated_", (ftnlen)581)] | value;
/* Check to see if the local buffer is full and the */
/* double precision numbers need to be moved into the */
/* next block of OUTPUT. */
if (k == 255) {
moved_(dpbufr, &c__128, &output[outpos - 1]);
outpos += 128;
k = 1;
/* Otherwise, increment K. */
} else {
k += 2;
}
}
/* Copy any remaining double precision numbers from DPBUFR */
/* into OUTPUT. */
if (k != 1) {
i__1 = k / 2;
moved_(dpbufr, &i__1, &output[outpos - 1]);
}
} else {
setmsg_("Unable to translate double precision values from binary"
" file format # to #. This error should never occur and i"
"s indicative of a bug. Contact NAIF.", (ftnlen)148);
errch_("#", strbff + (((i__1 = *inbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)618))
<< 3), (ftnlen)1, (ftnlen)8);
errch_("#", strbff + (((i__1 = natbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)619))
<< 3), (ftnlen)1, (ftnlen)8);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZXLATED", (ftnlen)8);
return 0;
}
} else if (natbff == 2) {
if (*inbff == 1) {
/* Check to see that the length of the input string is */
/* appropriate. Since this is a string containing BIG-IEEE */
/* d.p. values, and this is a LTL-IEEE machine characters */
/* are 1-byte and d.p. values are 8-bytes. So the length */
/* of INPUT must be a multiple of 8. */
numdp = lenipt / 8;
if (lenipt - (numdp << 3) != 0) {
setmsg_("The input string that is to be translated from the "
"binary format # to format # has a length that is not"
" a multiple of 4 bytes. This error should never occ"
"ur.", (ftnlen)158);
errch_("#", strbff + (((i__1 = *inbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)
646)) << 3), (ftnlen)1, (ftnlen)8);
errch_("#", strbff + (((i__1 = natbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)
647)) << 3), (ftnlen)1, (ftnlen)8);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZXLATED", (ftnlen)8);
return 0;
}
/* Verify there is enough room to store the results of */
/* the translation. */
if (numdp > *space) {
setmsg_("The caller specified that # double precision number"
"s are to be translated from binary format # to #. H"
"owever there is only room to hold # integers in the "
"output array. This error should never occur.", (
ftnlen)200);
errint_("#", &numdp, (ftnlen)1);
errch_("#", strbff + (((i__1 = *inbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)
667)) << 3), (ftnlen)1, (ftnlen)8);
errch_("#", strbff + (((i__1 = natbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)
668)) << 3), (ftnlen)1, (ftnlen)8);
errint_("#", space, (ftnlen)1);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZXLATED", (ftnlen)8);
return 0;
}
/* The remainder of this branch is devoted to translating */
/* and copying blocks of DPBLEN double precision numbers */
/* into OUTPUT. Initialize K, the integer index into the */
/* buffer equivalenced to DPBUFR. */
k = 1;
/* Start looping over each 8 character package in INPUT and */
/* converting them to double precision numbers. */
i__1 = numdp;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Compute the substring index of the first character */
/* in INPUT for this integer. */
j = (i__ - 1 << 3) + 1;
/* Now arrange the bytes properly. Since these characters */
/* were read from a file utilizing BIG-IEEE: */
/* . */
/* . */
/* . */
/* ------- */
/* | J | - Sign Bit, Head of Exponent */
/* ------- */
/* | J+1 | - Tail of Exponent, Most Significant */
/* ------- Bits of the Mantissa */
/* | J+2 | - Second Most Significant Mantissa Byte */
/* ------- */
/* | J+3 | - Third Most Significant Mantissa Byte */
/* ------- */
/* | J+4 | - Fourth Most Significant Mantissa Byte */
/* ------- */
/* | J+5 | - Fifth Most Significant Mantissa Byte */
/* ------- */
/* | J+6 | - Sixth Most Significant Mantissa Byte */
/* ------- */
/* | J+7 | - Least Significant Byte of Mantissa */
/* ------- */
/* . */
/* . */
/* . */
/* Now rearrange the bytes to place them in the */
/* proper order for d.p. values on LTL-IEEE machines. */
/* This is accomplished in the following manner: */
/* INPUT(J+7:J+7) */
/* INPUT(J+6:J+6)*SHFT8 */
/* INPUT(J+5:J+5)*SHFT16 */
/* + INPUT(J+4:J+4)*SHFT24 */
/* ------------------------- */
/* INBUFR(K) */
/* INPUT(J+3:J+3) */
/* INPUT(J+2:J+2)*SHFT8 */
/* INPUT(J+1:J+1)*SHFT16 */
/* + INPUT(J:J)*SHFT24 */
/* ------------------------- */
/* INBUFR(K+1) */
/* Utilize the military extension bit manipulation */
/* intrinsics to perform the necessary computations. */
/* It has been determined empirically that on these */
/* environments this is faster than arithmetic. */
i__2 = j + 6;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 7 - i__2);
value = *(unsigned char *)&ch__1[0];
inbufr[(i__2 = k - 1) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"inbufr", i__2, "zzxlated_", (ftnlen)749)] = value;
i__2 = j + 5;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 6 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 8;
inbufr[(i__2 = k - 1) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"inbufr", i__2, "zzxlated_", (ftnlen)753)] = inbufr[(
i__3 = k - 1) < 256 && 0 <= i__3 ? i__3 : s_rnge(
"inbufr", i__3, "zzxlated_", (ftnlen)753)] | value;
i__2 = j + 4;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 5 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 16;
inbufr[(i__2 = k - 1) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"inbufr", i__2, "zzxlated_", (ftnlen)757)] = inbufr[(
i__3 = k - 1) < 256 && 0 <= i__3 ? i__3 : s_rnge(
"inbufr", i__3, "zzxlated_", (ftnlen)757)] | value;
i__2 = j + 3;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 4 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 24;
inbufr[(i__2 = k - 1) < 256 && 0 <= i__2 ? i__2 : s_rnge(
"inbufr", i__2, "zzxlated_", (ftnlen)761)] = inbufr[(
i__3 = k - 1) < 256 && 0 <= i__3 ? i__3 : s_rnge(
"inbufr", i__3, "zzxlated_", (ftnlen)761)] | value;
i__2 = j + 2;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 3 - i__2);
value = *(unsigned char *)&ch__1[0];
inbufr[(i__2 = k) < 256 && 0 <= i__2 ? i__2 : s_rnge("inbufr",
i__2, "zzxlated_", (ftnlen)765)] = value;
i__2 = j + 1;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 2 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 8;
inbufr[(i__2 = k) < 256 && 0 <= i__2 ? i__2 : s_rnge("inbufr",
i__2, "zzxlated_", (ftnlen)769)] = inbufr[(i__3 = k)
< 256 && 0 <= i__3 ? i__3 : s_rnge("inbufr", i__3,
"zzxlated_", (ftnlen)769)] | value;
i__2 = j;
s_copy(ch__1, input + i__2, (ftnlen)1, j + 1 - i__2);
value = *(unsigned char *)&ch__1[0];
value <<= 16;
inbufr[(i__2 = k) < 256 && 0 <= i__2 ? i__2 : s_rnge("inbufr",
i__2, "zzxlated_", (ftnlen)773)] = inbufr[(i__3 = k)
< 256 && 0 <= i__3 ? i__3 : s_rnge("inbufr", i__3,
"zzxlated_", (ftnlen)773)] | value;
*(unsigned char *)&ch__1[0] = *(unsigned char *)&input[j - 1];
value = *(unsigned char *)&ch__1[0];
value <<= 24;
inbufr[(i__2 = k) < 256 && 0 <= i__2 ? i__2 : s_rnge("inbufr",
i__2, "zzxlated_", (ftnlen)777)] = inbufr[(i__3 = k)
< 256 && 0 <= i__3 ? i__3 : s_rnge("inbufr", i__3,
"zzxlated_", (ftnlen)777)] | value;
/* Check to see if the local buffer is full and the */
/* double precision numbers need to be moved into the */
/* next block of OUTPUT. */
if (k == 255) {
moved_(dpbufr, &c__128, &output[outpos - 1]);
outpos += 128;
k = 1;
/* Otherwise, increment K. */
} else {
k += 2;
}
}
/* Copy any remaining double precision numbers from DPBUFR */
/* into OUTPUT. */
if (k != 1) {
i__1 = k / 2;
moved_(dpbufr, &i__1, &output[outpos - 1]);
}
} else {
setmsg_("Unable to translate double precision values from binary"
" file format # to #. This error should never occur and i"
"s indicative of a bug. Contact NAIF.", (ftnlen)148);
errch_("#", strbff + (((i__1 = *inbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)814))
<< 3), (ftnlen)1, (ftnlen)8);
errch_("#", strbff + (((i__1 = natbff - 1) < 4 && 0 <= i__1 ?
i__1 : s_rnge("strbff", i__1, "zzxlated_", (ftnlen)815))
<< 3), (ftnlen)1, (ftnlen)8);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZXLATED", (ftnlen)8);
return 0;
}
/* The native binary file format on this platform is not supported */
/* for the conversion of integers. This is a bug, as this branch */
/* of code should never be reached in normal operation. */
} else {
setmsg_("The native binary file format of this toolkit build, #, is "
"not currently supported for translation of double precision "
"numbers from non-native formats.", (ftnlen)151);
errch_("#", strbff + (((i__1 = natbff - 1) < 4 && 0 <= i__1 ? i__1 :
s_rnge("strbff", i__1, "zzxlated_", (ftnlen)833)) << 3), (
ftnlen)1, (ftnlen)8);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZXLATED", (ftnlen)8);
return 0;
}
chkout_("ZZXLATED", (ftnlen)8);
return 0;
} /* zzxlated_ */
/* $Procedure ZZEKDE01 ( EK, delete column entry, class 1 ) */
/* Subroutine */ int zzekde01_(integer *handle, integer *segdsc, integer *
coldsc, integer *recptr)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer base;
extern integer zzekrp2n_(integer *, integer *, integer *);
integer unit;
extern /* Subroutine */ int zzekpgch_(integer *, char *, ftnlen),
zzekglnk_(integer *, integer *, integer *, integer *), zzekpgpg_(
integer *, integer *, integer *, integer *), zzekixdl_(integer *,
integer *, integer *, integer *), zzekslnk_(integer *, integer *,
integer *, integer *);
integer p;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer recno, ncols;
extern logical failed_(void);
extern /* Subroutine */ int dasrdi_(integer *, integer *, integer *,
integer *), dasudi_(integer *, integer *, integer *, integer *);
extern logical return_(void);
integer datptr, idxtyp, nlinks, ptrloc;
extern /* Subroutine */ int chkout_(char *, ftnlen), dashlu_(integer *,
integer *), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen), errfnm_(char *, integer *, ftnlen), sigerr_(char *,
ftnlen), zzekdps_(integer *, integer *, integer *, integer *);
/* $ Abstract */
/* Delete a specified class 1 column entry from an EK record. */
/* $ 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 */
/* PRIVATE */
/* 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 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. */
/* $ Detailed_Input */
/* HANDLE is a file handle of an EK open for write access. */
/* SEGDSC is the descriptor of the segment from which to */
/* delete the specified column entry. */
/* COLDSC is the descriptor of the column from which to */
/* delete the specified column entry. */
/* RECPTR is a pointer to the record containing the column */
/* entry to delete. */
/* $ Detailed_Output */
/* None. See the $Particulars section for a description of the */
/* effect of this routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If HANDLE is invalid, the error will be diagnosed by routines */
/* called by this routine. The file will not be modified. */
/* 2) If an I/O error occurs while reading or writing the indicated */
/* file, the error will be diagnosed by routines called by this */
/* routine. The file may be corrupted. */
/* $ Files */
/* See the EK Required Reading for a discussion of the EK file */
/* format. */
/* $ Particulars */
/* This routine operates by side effects: it deletes a column entry */
/* from an EK segment. The deleted entry is marked as */
/* `uninitialized'. If the column containing the entry is indexed, */
/* the corresponding entry in the index is removed. The entry must */
/* be replaced with a new entry in order to be readable. */
/* The link count for the page containing the deleted column entry */
/* is decremented. If the count becomes zero, the page is freed. */
/* If the entry to be deleted is already uninitialized upon entry */
/* to this routine, no link counts are modified. The record */
/* containing the entry is still marked `updated' in this */
/* case. */
/* The changes made by this routine to the target EK file become */
/* permanent when the file is closed. Failure to close the file */
/* properly will leave it in an indeterminate state. */
/* $ Examples */
/* See EKDELR. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - Beta Version 1.0.0, 28-SEP-1995 (NJB) */
/* -& */
/* SPICELIB functions */
/* Non-SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZEKDE01", (ftnlen)8);
}
/* Before trying to actually modify the file, do every error */
/* check we can. */
/* Is this file handle valid--is the file open for paged write */
/* access? Signal an error if not. */
zzekpgch_(handle, "WRITE", (ftnlen)5);
if (failed_()) {
chkout_("ZZEKDE01", (ftnlen)8);
return 0;
}
/* We'll need to know how many columns the segment has in order to */
/* compute the size of the record pointer. The record pointer */
/* contains DPTBAS items plus two elements for each column. */
ncols = segdsc[4];
/* Compute the data pointer location. If the data pointer is */
/* already set to `uninitialized', there's nothing to do. If */
/* the element is null, just set it to `uninitialized'. The */
/* presence of actual data obligates us to clean up, however. */
ptrloc = *recptr + 2 + coldsc[8];
dasrdi_(handle, &ptrloc, &ptrloc, &datptr);
if (datptr > 0) {
/* Determine whether the column is indexed. */
idxtyp = coldsc[5];
if (idxtyp != -1) {
/* This column is indexed. Delete the index entry */
/* for this column. */
zzekixdl_(handle, segdsc, coldsc, recptr);
}
/* Find the number of the page containing the column entry. */
zzekpgpg_(&c__3, &datptr, &p, &base);
/* Get the link count for the page. If we have more */
/* than one link to the page, decrement the link count. If */
/* we're down to one link, this deletion will finish off the */
/* page: we'll deallocate it. */
zzekglnk_(handle, &c__3, &p, &nlinks);
if (nlinks > 1) {
i__1 = nlinks - 1;
zzekslnk_(handle, &c__3, &p, &i__1);
} else {
/* If we removed the last item from the page, we can delete */
/* the page. ZZEKDPS adjusts the segment's metadata */
/* to reflect the deallocation. */
zzekdps_(handle, segdsc, &c__3, &p);
}
/* Set the data pointer to indicate the item is uninitialized. */
dasudi_(handle, &ptrloc, &ptrloc, &c_n1);
} else if (datptr == -2) {
/* Determine whether the column is indexed. */
idxtyp = coldsc[5];
if (idxtyp != -1) {
/* This column is indexed. Delete the index entry */
/* for this column. */
zzekixdl_(handle, segdsc, coldsc, recptr);
}
/* Mark the entry as `uninitialized'. */
dasudi_(handle, &ptrloc, &ptrloc, &c_n1);
} else if (datptr != -1) {
/* UNINIT was the last valid possibility. The data pointer is */
/* corrupted. */
recno = zzekrp2n_(handle, &segdsc[1], recptr);
dashlu_(handle, &unit);
setmsg_("Data pointer is corrupted. SEGNO = #; COLIDX = #; RECNO = "
"#; EK = #", (ftnlen)68);
errint_("#", &segdsc[1], (ftnlen)1);
errint_("#", &coldsc[8], (ftnlen)1);
errint_("#", &recno, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(BUG)", (ftnlen)10);
chkout_("ZZEKDE01", (ftnlen)8);
return 0;
}
chkout_("ZZEKDE01", (ftnlen)8);
return 0;
} /* zzekde01_ */
