/* $Procedure KPLFRM ( Kernel pool frame IDs ) */
/* Subroutine */ int kplfrm_(integer *frmcls, integer *idset)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
integer i__, l, m, n, w;
extern /* Subroutine */ int chkin_(char *, ftnlen), repmc_(char *, char *,
char *, char *, ftnlen, ftnlen, ftnlen, ftnlen);
logical found;
extern /* Subroutine */ int repmi_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
extern integer sizei_(integer *);
integer idcode, to;
extern /* Subroutine */ int scardi_(integer *, integer *);
char frname[32];
extern /* Subroutine */ int validi_(integer *, integer *, integer *);
char kvcode[32];
integer fclass;
char kvname[32], kvbuff[32*100], kvclas[32];
extern /* Subroutine */ int gcpool_(char *, integer *, integer *, integer
*, char *, logical *, ftnlen, ftnlen), gipool_(char *, integer *,
integer *, integer *, integer *, logical *, ftnlen);
char tmpnam[32];
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
char kvtemp[32];
extern /* Subroutine */ int gnpool_(char *, integer *, integer *, integer
*, char *, logical *, ftnlen, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Return a SPICE set containing the frame IDs of all reference */
/* frames of a given class having specifications in the kernel pool. */
/* $ 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 */
/* FRAMES */
/* KERNEL */
/* NAIF_IDS */
/* SETS */
/* $ Keywords */
/* FRAME */
/* SET */
/* UTILITY */
/* $ Declarations */
/* $ Abstract */
/* The parameters below form an enumerated list of the recognized */
/* frame types. They are: INERTL, PCK, CK, TK, DYN. The meanings */
/* are outlined below. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Parameters */
/* INERTL an inertial frame that is listed in the routine */
/* CHGIRF and that requires no external file to */
/* compute the transformation from or to any other */
/* inertial frame. */
/* PCK is a frame that is specified relative to some */
/* INERTL frame and that has an IAU model that */
/* may be retrieved from the PCK system via a call */
/* to the routine TISBOD. */
/* CK is a frame defined by a C-kernel. */
/* TK is a "text kernel" frame. These frames are offset */
/* from their associated "relative" frames by a */
/* constant rotation. */
/* DYN is a "dynamic" frame. These currently are */
/* parameterized, built-in frames where the full frame */
/* definition depends on parameters supplied via a */
/* frame kernel. */
/* ALL indicates any of the above classes. This parameter */
/* is used in APIs that fetch information about frames */
/* of a specified class. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 4.0.0, 08-MAY-2012 (NJB) */
/* The parameter ALL was added to support frame fetch APIs. */
/* - SPICELIB Version 3.0.0, 28-MAY-2004 (NJB) */
/* The parameter DYN was added to support the dynamic frame class. */
/* - SPICELIB Version 2.0.0, 12-DEC-1996 (WLT) */
/* Various unused frames types were removed and the */
/* frame time TK was added. */
/* - SPICELIB Version 1.0.0, 10-DEC-1995 (WLT) */
/* -& */
/* End of INCLUDE file frmtyp.inc */
/* $ Abstract */
/* This file contains the number of inertial reference */
/* frames that are currently known by the SPICE toolkit */
/* software. */
/* $ 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 */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* NINERT P Number of known inertial reference frames. */
/* $ Parameters */
/* NINERT is the number of recognized inertial reference */
/* frames. This value is needed by both CHGIRF */
/* ZZFDAT, and FRAMEX. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 10-OCT-1996 (WLT) */
/* -& */
/* $ Abstract */
/* This file contains the number of non-inertial reference */
/* frames that are currently built into the SPICE toolkit */
/* software. */
/* $ 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 */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* NINERT P Number of built-in non-inertial reference frames. */
/* $ Parameters */
/* NINERT is the number of built-in non-inertial reference */
/* frames. This value is needed by both ZZFDAT, and */
/* FRAMEX. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* W.L. Taber (JPL) */
/* F.S. Turner (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.5.0, 11-OCT-2011 (BVS) */
/* Increased the number of non-inertial frames from 100 to 105 */
/* in order to accomodate the following PCK based frames: */
/* IAU_CERES */
/* IAU_PALLAS */
/* IAU_LUTETIA */
/* IAU_DAVIDA */
/* IAU_STEINS */
/* - SPICELIB Version 1.4.0, 11-MAY-2010 (BVS) */
/* Increased the number of non-inertial frames from 96 to 100 */
/* in order to accomodate the following PCK based frames: */
/* IAU_BORRELLY */
/* IAU_TEMPEL_1 */
/* IAU_VESTA */
/* IAU_ITOKAWA */
/* - SPICELIB Version 1.3.0, 12-DEC-2002 (BVS) */
/* Increased the number of non-inertial frames from 85 to 96 */
/* in order to accomodate the following PCK based frames: */
/* IAU_CALLIRRHOE */
/* IAU_THEMISTO */
/* IAU_MAGACLITE */
/* IAU_TAYGETE */
/* IAU_CHALDENE */
/* IAU_HARPALYKE */
/* IAU_KALYKE */
/* IAU_IOCASTE */
/* IAU_ERINOME */
/* IAU_ISONOE */
/* IAU_PRAXIDIKE */
/* - SPICELIB Version 1.2.0, 02-AUG-2002 (FST) */
/* Increased the number of non-inertial frames from 81 to 85 */
/* in order to accomodate the following PCK based frames: */
/* IAU_PAN */
/* IAU_GASPRA */
/* IAU_IDA */
/* IAU_EROS */
/* - SPICELIB Version 1.1.0, 20-FEB-1997 (WLT) */
/* Increased the number of non-inertial frames from 79 to 81 */
/* in order to accomodate the following earth rotation */
/* models: */
/* ITRF93 */
/* EARTH_FIXED */
/* - SPICELIB Version 1.0.0, 10-OCT-1996 (WLT) */
/* -& */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* FRMCLS I Frame class. */
/* IDSET O Set of ID codes of frames of the specified class. */
/* $ Detailed_Input */
/* FRMCLS is an integer code specifying the frame class or */
/* classes for which frame ID codes are requested. */
/* The applicable reference frames are those having */
/* specifications present in the kernel pool. */
/* FRMCLS may designate a single class or "all */
/* classes." */
/* The include file frmtyp.inc declares parameters */
/* identifying frame classes. The supported values */
/* and corresponding meanings of FRMCLS are */
/* Parameter Value Meaning */
/* ========= ===== ================= */
/* ALL -1 All frame classes */
/* specified in the */
/* kernel pool. Class 1 */
/* is not included. */
/* INERTL 1 Built-in inertial. */
/* No frames will be */
/* returned in the */
/* output set. */
/* PCK 2 PCK-based frame */
/* CK 3 CK-based frame */
/* TK 4 Fixed rotational */
/* offset ("text */
/* kernel") frame */
/* DYN 5 Dynamic frame */
/* $ Detailed_Output */
/* IDSET is a SPICE set containing the ID codes of all */
/* reference frames having specifications present in */
/* the kernel pool and belonging to the specified */
/* class or classes. */
/* Note that if FRMCLS is set to INERTL, IDSET */
/* will be empty on output. */
/* $ Parameters */
/* See the INCLUDE file frmtyp.inc. */
/* $ Exceptions */
/* 1) If the input frame class argument is not defined in */
/* frmtyp.inc, the error SPICE(BADFRAMECLASS) is signaled. */
/* 2) If the size of IDSET is too small to hold the requested frame */
/* ID set, the error SPICE(SETTOOSMALL) is signaled. */
/* 3) Frames of class 1 may not be specified in the kernel pool. */
/* However, for the convenience of users, this routine does not */
/* signal an error if the input class is set to INERTL. In this */
/* case the output set will be empty. */
/* 4) This routine relies on the presence of just three kernel */
/* variable assignments for a reference frame in order to */
/* determine that that reference frame has been specified: */
/* FRAME_<frame name> = <ID code> */
/* FRAME_<ID code>_NAME = <frame name> */
/* and either */
/* FRAME_<ID code>_CLASS = <class> */
/* or */
/* FRAME_<frame name>_CLASS = <class> */
/* It is possible for the presence of an incomplete frame */
/* specification to trick this routine into incorrectly */
/* deciding that a frame has been specified. This routine */
/* does not attempt to diagnose this problem. */
/* $ Files */
/* 1) Reference frame specifications for frames that are not */
/* built in are typically established by loading frame kernels. */
/* $ Particulars */
/* This routine enables SPICE-based applications to conveniently */
/* find the frame ID codes of reference frames having specifications */
/* present in the kernel pool. Such frame specifications are */
/* introduced into the kernel pool either by loading frame kernels */
/* or by means of calls to the kernel pool "put" API routines */
/* PCPOOL */
/* PDPOOL */
/* PIPOOL */
/* Given a reference frame's ID code, other attributes of the */
/* frame can be obtained via calls to entry points of the */
/* umbrella routine FRAMEX: */
/* FRMNAM {Return a frame's name} */
/* FRINFO {Return a frame's center, class, and class ID} */
/* This routine has a counterpart */
/* BLTFRM */
/* which fetches the frame IDs of all built-in reference frames. */
/* $ Examples */
/* 1) Display the IDs and names of all reference frames having */
/* specifications present in the kernel pool. Group the outputs */
/* by frame class. Also fetch and display the entire set of IDs */
/* and names using the parameter ALL. */
/* The meta-kernel used for this example is shown below. The */
/* Rosetta kernels referenced by the meta-kernel are available */
/* in the path */
/* pub/naif/ROSETTA/kernels/fk */
/* on the NAIF server. Older, but officially archived versions */
/* of these kernels are available in the path */
/* pub/naif/pds/data/ros-e_m_a_c-spice-6-v1.0/ */
/* rossp_1000/DATA/FK */
/* The referenced PCK is available from the pck path under the */
/* generic_kernels path on the same server. */
/* KPL/MK */
/* \begindata */
/* KERNELS_TO_LOAD = ( 'pck00010.tpc' */
/* 'EARTHFIXEDITRF93.TF' */
/* 'ROS_LUTETIA_RSOC_V03.TF' */
/* 'ROS_V18.TF' */
/* 'RSSD0002.TF' ) */
/* \begintext */
/* Program source code: */
/* PROGRAM EX1 */
/* IMPLICIT NONE */
/* INCLUDE 'frmtyp.inc' */
/* C */
/* C SPICELIB functions */
/* C */
/* INTEGER CARDI */
/* C */
/* C Local parameters */
/* C */
/* CHARACTER*(*) META */
/* PARAMETER ( META = 'kplfrm.tm' ) */
/* INTEGER NFRAME */
/* PARAMETER ( NFRAME = 1000 ) */
/* INTEGER LBCELL */
/* PARAMETER ( LBCELL = -5 ) */
/* INTEGER LNSIZE */
/* PARAMETER ( LNSIZE = 80 ) */
/* INTEGER FRNMLN */
/* PARAMETER ( FRNMLN = 32 ) */
/* C */
/* C Local variables */
/* C */
/* CHARACTER*(FRNMLN) FRNAME */
/* CHARACTER*(LNSIZE) OUTLIN */
/* INTEGER I */
/* INTEGER IDSET ( LBCELL : NFRAME ) */
/* INTEGER J */
/* C */
/* C Initialize the frame set. */
/* C */
/* CALL SSIZEI ( NFRAME, IDSET ) */
/* C */
/* C Load kernels that contain frame specifications. */
/* C */
/* CALL FURNSH ( META ) */
/* C */
/* C Fetch and display the frames of each class. */
/* C */
/* DO I = 1, 6 */
/* IF ( I .LT. 6 ) THEN */
/* C */
/* C Fetch the frames of class I. */
/* C */
/* CALL KPLFRM ( I, IDSET ) */
/* OUTLIN = 'Number of frames of class #: #' */
/* CALL REPMI ( OUTLIN, '#', I, OUTLIN ) */
/* CALL REPMI ( OUTLIN, '#', CARDI(IDSET), OUTLIN ) */
/* ELSE */
/* C */
/* C Fetch IDs of all frames specified in the kernel */
/* C pool. */
/* C */
/* CALL KPLFRM ( ALL, IDSET ) */
/* OUTLIN = 'Number of frames in the kernel pool: #' */
/* CALL REPMI ( OUTLIN, '#', CARDI(IDSET), OUTLIN ) */
/* END IF */
/* CALL TOSTDO ( ' ' ) */
/* CALL TOSTDO ( OUTLIN ) */
/* CALL TOSTDO ( ' Frame IDs and names' ) */
/* DO J = 1, CARDI(IDSET) */
/* CALL FRMNAM ( IDSET(J), FRNAME ) */
/* WRITE (*,*) IDSET(J), ' ', FRNAME */
/* END DO */
/* END DO */
/* END */
/* The output from the program, when the program was linked */
/* against the N0064 SPICE Toolkit, is shown below. The output */
/* shown here has been abbreviated. */
/* Number of frames of class 1: 0 */
/* Frame IDs and names */
/* Number of frames of class 2: 3 */
/* Frame IDs and names */
/* 1000012 67P/C-G_FIXED */
/* 2000021 LUTETIA_FIXED */
/* 2002867 STEINS_FIXED */
/* Number of frames of class 3: 7 */
/* Frame IDs and names */
/* -226570 ROS_RPC_BOOM2 */
/* -226215 ROS_VIRTIS-M_SCAN */
/* -226072 ROS_HGA_AZ */
/* -226071 ROS_HGA_EL */
/* -226025 ROS_SA-Y */
/* -226015 ROS_SA+Y */
/* -226000 ROS_SPACECRAFT */
/* Number of frames of class 4: 64 */
/* Frame IDs and names */
/* -2260021 ROS_LUTETIA */
/* -226999 ROSLND_LOCAL_LEVEL */
/* -226900 ROSLND_LANDER */
/* -226560 ROS_RPC_BOOM1 */
/* ... */
/* -226030 ROS_MGA-S */
/* -226020 ROS_SA-Y_ZERO */
/* -226010 ROS_SA+Y_ZERO */
/* 1502010 HCI */
/* 1502301 LME2000 */
/* 1503299 VME2000 */
/* 1503499 MME2000 */
/* Number of frames of class 5: 19 */
/* Frame IDs and names */
/* -226967 2867/STEINS_CSO */
/* -226945 45P/H-M-P_CSO */
/* -226921 21/LUTETIA_CSO */
/* -226920 21/LUTETIA_CSEQ */
/* -226912 67P/C-G_CSO */
/* -226910 67P/C-G_CSEQ */
/* 1500010 HEE */
/* 1500299 VSO */
/* 1500301 LSE */
/* 1500399 GSE */
/* 1500499 MME */
/* 1501010 HEEQ */
/* 1501299 VME */
/* 1501301 LME */
/* 1501399 EME */
/* 1501499 MME_IAU2000 */
/* 1502399 GSEQ */
/* 1502499 MSO */
/* 1503399 ECLIPDATE */
/* Number of frames in the kernel pool: 93 */
/* Frame IDs and names */
/* -2260021 ROS_LUTETIA */
/* -226999 ROSLND_LOCAL_LEVEL */
/* -226967 2867/STEINS_CSO */
/* -226945 45P/H-M-P_CSO */
/* -226921 21/LUTETIA_CSO */
/* ... */
/* 1503299 VME2000 */
/* 1503399 ECLIPDATE */
/* 1503499 MME2000 */
/* 2000021 LUTETIA_FIXED */
/* 2002867 STEINS_FIXED */
/* $ Restrictions */
/* 1) This routine will work correctly if the kernel pool */
/* contains no invalid frame specifications. See the */
/* description of exception 4 above. Users must ensure */
/* that no invalid frame specifications are introduced */
/* into the kernel pool, either by loaded kernels or */
/* by means of the kernel pool "put" APIs. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 22-MAY-2012 (NJB) */
/* -& */
/* $ Index_Entries */
/* fetch IDs of reference_frames from the kernel_pool */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
if (return_()) {
return 0;
}
chkin_("KPLFRM", (ftnlen)6);
/* The output set starts out empty. */
scardi_(&c__0, idset);
/* Check the input frame class. */
/* This block of code must be kept in sync with frmtyp.inc. */
if (*frmcls > 5 || *frmcls == 0 || *frmcls < -1) {
setmsg_("Frame class specifier FRMCLS was #; this value is not suppo"
"rted.", (ftnlen)64);
errint_("#", frmcls, (ftnlen)1);
sigerr_("SPICE(BADFRAMECLASS)", (ftnlen)20);
chkout_("KPLFRM", (ftnlen)6);
return 0;
}
/* Initialize the output buffer index. The */
/* index is to be incremented prior to each */
/* write to the buffer. */
to = 0;
/* Find all of the kernel variables having names */
/* that could correspond to frame name assignments. */
/* We expect that all frame specifications will */
/* include assignments of the form */
/* FRAME_<ID code>_NAME = <frame name> */
/* We may pick up some additional assignments that are not part of */
/* frame specifications; we plan to filter out as many as possible */
/* by looking the corresponding frame ID and frame class */
/* assignments. */
s_copy(kvtemp, "FRAME_*_NAME", (ftnlen)32, (ftnlen)12);
gnpool_(kvtemp, &c__1, &c__100, &n, kvbuff, &found, (ftnlen)32, (ftnlen)
32);
while(n > 0) {
/* At least one kernel variable was found by the last */
/* GNPOOL call. Each of these variables is a possible */
/* frame name. Look up each of these candidate names. */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Attempt to fetch the right hand side value for */
/* the Ith kernel variable found on the previous */
/* GNPOOL call. */
gcpool_(kvbuff + (((i__2 = i__ - 1) < 100 && 0 <= i__2 ? i__2 :
s_rnge("kvbuff", i__2, "kplfrm_", (ftnlen)523)) << 5), &
c__1, &c__1, &m, frname, &found, (ftnlen)32, (ftnlen)32);
if (found) {
/* We found a possible frame name. Attempt to look */
/* up an ID code variable for the name. The assignment */
/* for the ID code, if present, will have the form */
/* FRAME_<name> = <ID code> */
/* Create the kernel variable name on the left hand */
/* side of the assignment. */
s_copy(kvcode, "FRAME_<name>", (ftnlen)32, (ftnlen)12);
repmc_(kvcode, "<name>", frname, kvcode, (ftnlen)32, (ftnlen)
6, (ftnlen)32, (ftnlen)32);
/* Try to fetch the ID code. */
gipool_(kvcode, &c__1, &c__1, &l, &idcode, &found, (ftnlen)32)
;
if (found) {
/* We found an integer on the right hand side */
/* of the assignment. We probably have a */
/* frame specification at this point. Check that */
/* the variable */
/* FRAME_<ID code>_NAME */
/* is present in the kernel pool and maps to */
/* the name FRNAME. */
s_copy(kvname, "FRAME_<code>_NAME", (ftnlen)32, (ftnlen)
17);
repmi_(kvname, "<code>", &idcode, kvname, (ftnlen)32, (
ftnlen)6, (ftnlen)32);
gcpool_(kvname, &c__1, &c__1, &w, tmpnam, &found, (ftnlen)
32, (ftnlen)32);
if (found) {
/* Try to look up the frame class using a */
/* kernel variable name of the form */
/* FRAME_<integer ID code>_CLASS */
/* Create the kernel variable name on the left */
/* hand side of the frame class assignment. */
s_copy(kvclas, "FRAME_<integer>_CLASS", (ftnlen)32, (
ftnlen)21);
repmi_(kvclas, "<integer>", &idcode, kvclas, (ftnlen)
32, (ftnlen)9, (ftnlen)32);
/* Look for the frame class. */
gipool_(kvclas, &c__1, &c__1, &w, &fclass, &found, (
ftnlen)32);
if (! found) {
/* Try to look up the frame class using a kernel */
/* variable name of the form */
/* FRAME_<frame name>_CLASS */
s_copy(kvclas, "FRAME_<name>_CLASS", (ftnlen)32, (
ftnlen)18);
repmc_(kvclas, "<name>", frname, kvclas, (ftnlen)
32, (ftnlen)6, (ftnlen)32, (ftnlen)32);
gipool_(kvclas, &c__1, &c__1, &w, &fclass, &found,
(ftnlen)32);
}
/* At this point FOUND indicates whether we found */
/* the frame class. */
if (found) {
/* Check whether the frame class is one */
/* we want. */
if (*frmcls == -1 || *frmcls == fclass) {
/* We have a winner. Add it to the output set. */
/* First make sure the set is large enough to */
/* hold another element. */
if (to == sizei_(idset)) {
setmsg_("Frame ID set argument IDSET has"
" size #; required size is at lea"
"st #. Make sure that the caller "
"of this routine has initialized "
"IDSET via SSIZEI.", (ftnlen)144);
i__2 = sizei_(idset);
errint_("#", &i__2, (ftnlen)1);
i__2 = to + 1;
errint_("#", &i__2, (ftnlen)1);
sigerr_("SPICE(SETTOOSMALL)", (ftnlen)18);
chkout_("KPLFRM", (ftnlen)6);
return 0;
}
++to;
idset[to + 5] = idcode;
}
/* End of IF block for processing a frame having */
/* a frame class matching the request. */
}
/* End of IF block for finding the frame class. */
}
/* End of IF block for finding the frame name. */
}
/* End of IF block for finding the frame ID. */
}
/* End of IF block for finding string value corresponding to */
/* the Ith kernel variable matching the name template. */
}
/* End of loop for processing last batch of potential */
/* frame names. */
/* Fetch next batch of potential frame names. */
i__1 = n + 1;
gnpool_(kvtemp, &i__1, &c__100, &n, kvbuff, &found, (ftnlen)32, (
ftnlen)32);
}
/* At this point all kernel variables that matched the frame name */
/* keyword template have been processed. All frames of the specified */
/* class or classes have had their ID codes appended to IDSET. In */
/* general IDSET is not yet a SPICELIB set, since it's not sorted */
/* and it may contain duplicate values. */
/* Turn IDSET into a set. VALIDI sorts and removes duplicates. */
i__1 = sizei_(idset);
validi_(&i__1, &to, idset);
chkout_("KPLFRM", (ftnlen)6);
return 0;
} /* kplfrm_ */
/* $Procedure SYPOPD ( Pop a value from a particular symbol ) */
/* Subroutine */ int sypopd_(char *name__, char *tabsym, integer *tabptr,
doublereal *tabval, doublereal *value, logical *found, ftnlen
name_len, ftnlen tabsym_len)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer nval, nptr, nsym;
extern integer cardc_(char *, ftnlen), cardd_(doublereal *), cardi_(
integer *);
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern integer sumai_(integer *, integer *);
extern /* Subroutine */ int scardc_(integer *, char *, ftnlen), scardd_(
integer *, doublereal *), remlac_(integer *, integer *, char *,
integer *, ftnlen);
extern integer bsrchc_(char *, integer *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int remlad_(integer *, integer *, doublereal *,
integer *), scardi_(integer *, integer *), remlai_(integer *,
integer *, integer *, integer *);
integer locval;
extern /* Subroutine */ int chkout_(char *, ftnlen);
integer locsym;
extern logical return_(void);
/* $ Abstract */
/* Pop a value associated with a particular symbol in a double */
/* precision symbol table. The first value associated with the */
/* symbol is removed, and subsequent values are moved forward. */
/* $ 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 */
/* SYMBOLS */
/* $ Keywords */
/* SYMBOLS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* NAME I Name of the symbol whose associated value is to be */
/* popped. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL I/O Components of the symbol table. */
/* VALUE O Value that was popped. */
/* FOUND O True if the symbol exists, false if it does not. */
/* $ Detailed_Input */
/* NAME is the name of the symbol whose associated value is to */
/* be popped. If NAME is not in the symbol table, FOUND is */
/* false. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL are the components of a double precision symbol table. */
/* $ Detailed_Output */
/* TABSYM, */
/* TABPTR, */
/* TABVAL are the components of a double precision symbol table. */
/* The value is removed from the symbol table, and the */
/* remaining values associated with the symbol are moved */
/* forward in the value table. If no other values are */
/* associated with the symbol, the symbol is removed from */
/* the symbol table. */
/* VALUE is the value that was popped. This value was the first */
/* value in the symbol table that was associated with the */
/* symbol NAME. */
/* FOUND is true if NAME is in the symbol table, otherwise */
/* it is false. */
/* $ Parameters */
/* None. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Particulars */
/* If there are no remaining values associated with the symbol */
/* after VALUE has been popped, the symbol is removed from the */
/* symbol table. */
/* $ Examples */
/* The contents of the symbol table are: */
/* BODY4_POLE_RA --> 3.17681D2 */
/* 1.08D-1 */
/* 0.0D0 */
/* DELTA_T_A --> 3.2184D1 */
/* K --> 1.657D-3 */
/* MEAN_ANOM --> 6.239996D0 */
/* 1.99096871D-7 */
/* ORBIT_ECC --> 1.671D-2 */
/* The call, */
/* CALL SYPOPD ( 'MEAN_ANOM', TABSYM, TABPTR, TABVAL, VALUE, FOUND ) */
/* modifies the contents of the symbol table to be: */
/* BODY4_POLE_RA --> 3.17681D2 */
/* 1.08D-1 */
/* 0.0D0C */
/* DELTA_T_A --> 3.2184D1 */
/* K --> 1.657D-3 */
/* MEAN_ANOM --> 1.99096871D-7 */
/* ORBIT_ECC --> 1.671D-2 */
/* FOUND is TRUE, and VALUE is 6.239996D0. */
/* The next call, */
/* CALL SYPOPD ( 'K', TABSYM, TABPTR, TABVAL, VALUE, FOUND ) */
/* modifies the contents of the symbol table to be: */
/* BODY4_POLE_RA --> 3.17681D2 */
/* 1.08D-1 */
/* 0.0D0C */
/* DELTA_T_A --> 3.2184D1 */
/* MEAN_ANOM --> 1.99096871D-7 */
/* ORBIT_ECC --> 1.671D-2 */
/* FOUND is TRUE, and VALUE is 1.657D-3. Note that because */
/* "K" had only one value associated with it, it was removed */
/* from the symbol table. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (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 (IMU) (HAN) */
/* -& */
/* $ Index_Entries */
/* pop a value from a particular symbol */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SYPOPD", (ftnlen)6);
}
/* How many symbols to start with? */
nsym = cardc_(tabsym, tabsym_len);
nptr = cardi_(tabptr);
nval = cardd_(tabval);
/* Is this symbol even in the table? */
locsym = bsrchc_(name__, &nsym, tabsym + tabsym_len * 6, name_len,
tabsym_len);
/* If it's not in the table, it's definitely a problem. */
if (locsym == 0) {
*found = FALSE_;
/* If it is in the table, we can proceed without fear of overflow. */
} else {
*found = TRUE_;
/* Begin by saving and removing the initial value for this */
/* symbol from the value table. */
i__1 = locsym - 1;
locval = sumai_(&tabptr[6], &i__1) + 1;
*value = tabval[locval + 5];
remlad_(&c__1, &locval, &tabval[6], &nval);
scardd_(&nval, tabval);
/* If this was the sole value for the symbol, remove the */
/* symbol from the name and pointer tables. Otherwise just */
/* decrement the dimension. */
if (tabptr[locsym + 5] == 1) {
remlac_(&c__1, &locsym, tabsym + tabsym_len * 6, &nsym,
tabsym_len);
scardc_(&nsym, tabsym, tabsym_len);
remlai_(&c__1, &locsym, &tabptr[6], &nptr);
scardi_(&nptr, tabptr);
} else {
--tabptr[locsym + 5];
}
}
chkout_("SYPOPD", (ftnlen)6);
return 0;
} /* sypopd_ */
/* $Procedure SDIFFI ( Symmetric difference of two integer sets ) */
/* Subroutine */ int sdiffi_(integer *a, integer *b, integer *c__)
{
integer over, acard, bcard, ccard;
extern integer cardi_(integer *);
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer csize;
extern integer sizei_(integer *);
extern /* Subroutine */ int scardi_(integer *, integer *);
integer apoint, bpoint;
extern /* Subroutine */ int excess_(integer *, char *, ftnlen), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Take the symmetric difference of two integer 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 Symmetric difference 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 symmetric difference of A and B */
/* (that is, all of the elements which are in A */
/* OR in B, but NOT in both). */
/* If the size (maximum cardinality) of C is smaller */
/* than the cardinality of the symmetric difference 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 SYMMETRIC DIFFERENCE of two sets contains every */
/* element which is in the first set OR in the second set, */
/* but NOT in both sets. */
/* {a,b} sym. difference {c,d} = {a,b,c,d} */
/* {a,b,c} {b,c,d} {a,d} */
/* {a,b,c,d} {} {a,b,c,d} */
/* {} {a,b,c,d} {a,b,c,d} */
/* {} {} {} */
/* The following call */
/* CALL SDIFFC ( PLANETS, ASTEROIDS, RESULT ) */
/* places the symmetric difference 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 SDIFFI ( CURRENT, NEW, CURRENT ) */
/* CALL SDIFFI ( 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 SDIFFI ( CURRENT, NEW, TEMP ) */
/* CALL COPYI ( TEMP, NEW ) */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* 1) If the symmetric difference of the two sets causes an excess of */
/* elements, the error SPICE(SETEXCESS) 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.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 */
/* symmetric difference of two integer sets */
/* -& */
/* $ Revisions */
/* - 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_("SDIFFI", (ftnlen)6);
/* Find the cardinality of the input sets, and the allowed size */
/* of the output set. */
acard = cardi_(a);
bcard = cardi_(b);
csize = sizei_(c__);
/* 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 end 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;
c__[ccard + 5] = b[bpoint + 5];
++bpoint;
} else if (bpoint > bcard) {
++ccard;
c__[ccard + 5] = a[apoint + 5];
++apoint;
} else if (a[apoint + 5] == b[bpoint + 5]) {
++apoint;
++bpoint;
} else if (a[apoint + 5] < b[bpoint + 5]) {
++ccard;
c__[ccard + 5] = a[apoint + 5];
++apoint;
} else if (b[bpoint + 5] < a[apoint + 5]) {
++ccard;
c__[ccard + 5] = b[bpoint + 5];
++bpoint;
}
/* Otherwise, stop folling 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 (a[apoint + 5] == b[bpoint + 5]) {
++apoint;
++bpoint;
} else if (a[apoint + 5] < b[bpoint + 5]) {
++over;
++apoint;
} else if (b[bpoint + 5] < a[apoint + 5]) {
++over;
++bpoint;
}
}
}
/* Set the cardinality of the output set. */
scardi_(&ccard, c__);
/* Report any excess. */
if (over > 0) {
excess_(&over, "set", (ftnlen)3);
sigerr_("SPICE(SETEXCESS)", (ftnlen)16);
}
chkout_("SDIFFI", (ftnlen)6);
return 0;
} /* sdiffi_ */
/* $Procedure PODBGI ( Pod, begin group, integer ) */
/* Subroutine */ int podbgi_(integer *pod)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer need, have;
extern integer cardi_(integer *);
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern integer sizei_(integer *);
extern /* Subroutine */ int scardi_(integer *, integer *), sigerr_(char *,
ftnlen), chkout_(char *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Begin a new (empty) group within a pod. */
/* $ 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 */
/* PODS */
/* $ Keywords */
/* ARRAYS */
/* CELLS */
/* PODS */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* POD I,O Pod. */
/* $ Detailed_Input */
/* POD on input, is an arbitrary pod. */
/* $ Detailed_Output */
/* POD on output, is the same pod, in which the active */
/* group has been sealed, and a new active group */
/* (containing no elements) begun. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If POD does not have sufficient free space to create a new */
/* group with room for at least one element, the pod is not */
/* changed, and the error SPICE(TOOMANYPEAS) is signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* There are two ways to create a new group within a pod. */
/* PODBG (begin group) seals the current contents of the pod, */
/* and creates a new active group containing no elements. */
/* PODDG (duplicate group) also seals the current contents */
/* of the pod, but places a copy of the previous active */
/* group into the new active group. */
/* In both cases, the active group and all previous groups are */
/* unavailable so long as the new group exists. */
/* The active group of a pod may be removed by any of the */
/* following routines: PODEG (end group), PODCG (close group), */
/* or PODRG (replace group). */
/* $ Examples */
/* Let the active group of POD be located in elements 21 */
/* through 40. Then following the call */
/* CALL PODBGI ( POD ) */
/* the active group is located in elements 42 through 41. */
/* In other words, element 41 has been appropriated by the */
/* pod itself, and the active group is empty. */
/* However, following the call */
/* CALL PODDG ( POD ) */
/* the active group is located in elements 42 through 61, */
/* and contains the same elements as the previous active */
/* group. */
/* $ Restrictions */
/* 1) In any pod, only the active group should be accessed, */
/* and its location should always be determined by PODBE */
/* or PODON. Never assume that the active group begins */
/* at POD(1). */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - Beta Version 1.0.0, 15-JUL-1989 (WLT) (IMU) */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("PODBGI", (ftnlen)6);
}
/* There must be at least two spaces at the end of the pod: */
/* one for bookkeeping, and one for the first element of */
/* the new group. */
have = sizei_(pod);
need = cardi_(pod) + 2;
if (have < need) {
sigerr_("SPICE(TOOMANYPEAS)", (ftnlen)18);
chkout_("PODBGI", (ftnlen)6);
return 0;
}
/* Okay: go ahead and create the group. The offset of the active */
/* group is stored in the first empty slot of the pod; when the */
/* new group is removed, this will be reinstated as the offset of */
/* the active group. */
pod[cardi_(pod) + 6] = pod[3];
/* This requires the cardinality of the pod to increase by one. */
i__1 = cardi_(pod) + 1;
scardi_(&i__1, pod);
/* Surprise! The new cardinality is the same as the offset of */
/* the new group! */
pod[3] = pod[5];
chkout_("PODBGI", (ftnlen)6);
return 0;
} /* podbgi_ */
/* $Procedure SYDUPC ( Create a duplicate of a symbol ) */
/* Subroutine */ int sydupc_(char *name__, char *copy, char *tabsym, integer *
tabptr, char *tabval, ftnlen name_len, ftnlen copy_len, ftnlen
tabsym_len, ftnlen tabval_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer nval, nptr, nsym, i__;
extern integer cardc_(char *, ftnlen), cardi_(integer *);
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
extern integer sizec_(char *, ftnlen), sumai_(integer *, integer *),
sizei_(integer *);
extern /* Subroutine */ int scardc_(integer *, char *, ftnlen), remlac_(
integer *, integer *, char *, integer *, ftnlen), scardi_(integer
*, integer *), inslac_(char *, integer *, integer *, char *,
integer *, ftnlen, ftnlen);
integer dimval[2];
extern /* Subroutine */ int inslai_(integer *, integer *, integer *,
integer *, integer *);
integer locval[2];
extern integer lstlec_(char *, integer *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int sigerr_(char *, ftnlen);
integer newval;
extern /* Subroutine */ int chkout_(char *, ftnlen), setmsg_(char *,
ftnlen);
integer locsym[2];
logical oldsym[2];
extern logical return_(void);
integer newsym;
/* $ Abstract */
/* Create a duplicate of a symbol within a character symbol table. */
/* If a symbol with the new name already exists, its components */
/* are replaced. */
/* $ 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 */
/* SYMBOLS */
/* $ Keywords */
/* SYMBOLS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* NAME I Name of the symbol to be duplicated. */
/* COPY I Name of the new symbol. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL I/O Components of the symbol table. */
/* $ Detailed_Input */
/* NAME is the name of the symbol to be duplicated. The */
/* components associated with NAME will be given to the */
/* new symbol COPY. If NAME is not in the symbol table, */
/* no duplicate symbol can be made. */
/* COPY is the name of the new symbol. If a symbol with the */
/* name COPY already exists in the symbol table, its */
/* components are replaced by the components of NAME. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL are the components of a character symbol table. */
/* $ Detailed_Output */
/* TABSYM, */
/* TABPTR, */
/* TABVAL are the components of a character symbol table. */
/* On output, the symbol table contains a new symbol COPY */
/* whose components are the same as the components of */
/* NAME. */
/* $ Parameters */
/* None. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* 1) If the symbol NAME is not in the symbol table, the error */
/* SPICE(NOSUCHSYMBOL) is signalled. */
/* 2) If duplication of the symbol causes an overflow in the */
/* name table, the error SPICE(NAMETABLEFULL) is signalled. */
/* 3) If duplication of the symbol causes an overflow in the */
/* pointer table, the error SPICE(POINTERTABLEFULL) is signalled. */
/* 4) If duplication of the symbol causes an overflow in the */
/* value table, the error SPICE(VALUETABLEFULL) is signalled. */
/* $ Particulars */
/* If the symbol NAME is not in the symbol table, no duplicate symbol */
/* can be made. */
/* If the symbol COPY is already in the symbol table, its components */
/* are replaced by the components of NAME. */
/* $ Examples */
/* The contents of the symbol table are: */
/* BOHR --> HYDROGEN ATOM */
/* EINSTEIN --> SPECIAL RELATIVITY */
/* PHOTOELECTRIC EFFECT */
/* BROWNIAN MOTION */
/* FERMI --> NUCLEAR FISSION */
/* The code, */
/* CALL SYDUPC ( 'FERMI', 'HAHN', TABSYM, TABPTR, TABVAL ) */
/* produces the symbol table: */
/* BOHR --> HYDROGEN ATOM */
/* EINSTEIN --> SPECIAL RELATIVITY */
/* PHOTOELECTRIC EFFECT */
/* BROWNIAN MOTION */
/* FERMI --> NUCLEAR FISSION */
/* HAHN --> NUCLEAR FISSION */
/* The code, */
/* CALL SYDUPC ( 'STRASSMAN', 'HAHN', TABSYM, TABPTR, TABVAL ) */
/* produces the error SPICE(NOSUCHSYMBOL) because the symbol */
/* "STRASSMAN" is not in the symbol table. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (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 (IMU) (HAN) */
/* -& */
/* $ Index_Entries */
/* create a duplicate of a symbol */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SYDUPC", (ftnlen)6);
}
/* How many symbols to start with? */
nsym = cardc_(tabsym, tabsym_len);
nptr = cardi_(tabptr);
nval = cardc_(tabval, tabval_len);
/* Where do these symbols belong? Are they already in the table? */
locsym[0] = lstlec_(name__, &nsym, tabsym + tabsym_len * 6, name_len,
tabsym_len);
locsym[1] = lstlec_(copy, &nsym, tabsym + tabsym_len * 6, copy_len,
tabsym_len);
oldsym[0] = locsym[0] != 0 && s_cmp(tabsym + (locsym[0] + 5) * tabsym_len,
name__, tabsym_len, name_len) == 0;
oldsym[1] = locsym[1] != 0 && s_cmp(tabsym + (locsym[1] + 5) * tabsym_len,
copy, tabsym_len, copy_len) == 0;
/* If the original symbol is not in the table, we can't make a copy. */
if (! oldsym[0]) {
setmsg_("SYDUPC: The symbol to be duplicated, #, is not in the symbo"
"l table.", (ftnlen)67);
errch_("#", name__, (ftnlen)1, name_len);
sigerr_("SPICE(NOSUCHSYMBOL)", (ftnlen)19);
/* Otherwise, we need to know the dimension, to check for overflow. */
} else {
i__1 = locsym[0] - 1;
locval[0] = sumai_(&tabptr[6], &i__1) + 1;
dimval[0] = tabptr[locsym[0] + 5];
/* If the new symbol already exists, we need to know its dimension */
/* too, for the same reason. */
if (oldsym[1]) {
i__1 = locsym[1] - 1;
locval[1] = sumai_(&tabptr[6], &i__1) + 1;
dimval[1] = tabptr[locsym[1] + 5];
newsym = 0;
} else {
locval[1] = sumai_(&tabptr[6], &locsym[1]) + 1;
dimval[1] = 0;
newsym = 1;
}
newval = dimval[0] - dimval[1];
/* Can we make a copy without overflow? */
if (nsym + newsym > sizec_(tabsym, tabsym_len)) {
setmsg_("SYDUPC: Duplication of the symbol # causes an overflow "
"in the name table.", (ftnlen)73);
errch_("#", name__, (ftnlen)1, name_len);
sigerr_("SPICE(NAMETABLEFULL)", (ftnlen)20);
} else if (nptr + newsym > sizei_(tabptr)) {
setmsg_("SYDUPC: Duplication of the symbol # causes an overflow "
"in the pointer table.", (ftnlen)76);
errch_("#", name__, (ftnlen)1, name_len);
sigerr_("SPICE(POINTERTABLEFULL)", (ftnlen)23);
} else if (nval + newval > sizec_(tabval, tabval_len)) {
setmsg_("SYDUPC: Duplication of the symbol # causes an overflow "
"in the value table.", (ftnlen)74);
errch_("#", name__, (ftnlen)1, name_len);
sigerr_("SPICE(VALUETABLEFULL)", (ftnlen)21);
/* Looks like we can. */
} else {
/* If the copy exists, remove the current contents and */
/* change the dimension. Otherwise add the new name and */
/* dimension to the name and pointer tables. */
if (dimval[1] > 0) {
remlac_(&dimval[1], &locval[1], tabval + tabval_len * 6, &
nval, tabval_len);
scardc_(&nval, tabval, tabval_len);
tabptr[locsym[1] + 5] = dimval[0];
if (locval[0] > locval[1]) {
locval[0] -= dimval[1];
}
} else {
i__1 = locsym[1] + 1;
inslac_(copy, &c__1, &i__1, tabsym + tabsym_len * 6, &nsym,
copy_len, tabsym_len);
scardc_(&nsym, tabsym, tabsym_len);
i__1 = locsym[1] + 1;
inslai_(dimval, &c__1, &i__1, &tabptr[6], &nptr);
scardi_(&nptr, tabptr);
}
/* In either case, allocate space for the new symbol values, */
/* and copy them in one by one. (INSLAx won't work if the */
/* copy is earlier in the table than the original.) */
i__1 = locval[1];
for (i__ = nval; i__ >= i__1; --i__) {
s_copy(tabval + (i__ + dimval[0] + 5) * tabval_len, tabval + (
i__ + 5) * tabval_len, tabval_len, tabval_len);
}
if (locval[0] > locval[1]) {
locval[0] += dimval[0];
}
i__1 = dimval[0] - 1;
for (i__ = 0; i__ <= i__1; ++i__) {
s_copy(tabval + (locval[1] + i__ + 5) * tabval_len, tabval + (
locval[0] + i__ + 5) * tabval_len, tabval_len,
tabval_len);
}
i__1 = nval + dimval[0];
scardc_(&i__1, tabval, tabval_len);
}
}
chkout_("SYDUPC", (ftnlen)6);
return 0;
} /* sydupc_ */
/* $Procedure COMMNT ( Comment utility program ) */
/* Main program */ MAIN__(void)
{
/* Initialized data */
static logical insbln = TRUE_;
static char maintl[20] = "COMMNT Options ";
static char mainvl[20*5] = "QUIT " "ADD_COMMENTS "
"READ_COMMENTS " "EXTRACT_COMMENTS " "DELETE_COMMENTS "
" ";
static char maintx[40*5] = "Quit. "
"Add comments to a binary file. " "Read the comments in"
" a binary file. " "Extract comments from a binary file. "
"Delete the comments in a binary file. ";
static char mainnm[1*5] = "Q" "A" "R" "E" "D";
/* System generated locals */
address a__1[3];
integer i__1[3], i__2, i__3, i__4, i__5;
cllist cl__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen), f_clos(cllist *);
/* Local variables */
static char arch[3];
static logical done;
static char line[1000];
static logical more;
static integer iopt;
static char type__[4];
static integer i__;
extern /* Subroutine */ int dasdc_(integer *);
extern integer cardi_(integer *);
static integer r__;
extern /* Subroutine */ int spcac_(integer *, integer *, char *, char *,
ftnlen, ftnlen), chkin_(char *, ftnlen), spcec_(integer *,
integer *), spcdc_(integer *), errch_(char *, char *, ftnlen,
ftnlen), repmc_(char *, char *, char *, char *, ftnlen, ftnlen,
ftnlen, ftnlen), reset_(void);
extern integer rtrim_(char *, ftnlen);
extern logical failed_(void);
extern /* Subroutine */ int dafhof_(integer *);
static integer handle;
extern /* Subroutine */ int dafcls_(integer *), dasacu_(integer *, char *,
char *, logical *, integer *, ftnlen, ftnlen), cleari_(integer *,
integer *), delfil_(char *, ftnlen), dasecu_(integer *, integer *
, logical *), scardi_(integer *, integer *), dashof_(integer *);
static logical fileok;
extern /* Subroutine */ int clcomm_(void), getfat_(char *, char *, char *,
ftnlen, ftnlen, ftnlen), cnfirm_(char *, logical *, ftnlen);
static char fnmtbl[128*2], messag[1000], errmsg[320], messgs[1000*7],
option[20], prmtbl[80*2], statbl[3*2];
extern logical exists_(char *, ftnlen);
static integer comlun;
static char status[1000*2];
static integer numfnm;
static char prmpts[80*2];
static integer numopn, opnset[7], tblidx[2];
static logical comnts, contnu, ndfnms, tryagn;
extern /* Subroutine */ int tkvrsn_(char *, char *, ftnlen, ftnlen),
erract_(char *, char *, ftnlen, ftnlen), errprt_(char *, char *,
ftnlen, ftnlen), tostdo_(char *, ftnlen), ssizei_(integer *,
integer *), getopt_(char *, integer *, char *, char *, integer *,
ftnlen, ftnlen, ftnlen), getfnm_(char *, char *, char *, logical *
, char *, ftnlen, ftnlen, ftnlen, ftnlen), setmsg_(char *, ftnlen)
, sigerr_(char *, ftnlen), txtopr_(char *, integer *, ftnlen),
dafopw_(char *, integer *, ftnlen), dasopw_(char *, integer *,
ftnlen), dascls_(integer *), dafopr_(char *, integer *, ftnlen),
spcrfl_(integer *, char *, logical *, ftnlen), spcrnl_(char *,
logical *, ftnlen), dasopr_(char *, integer *, ftnlen), txtopn_(
char *, integer *, ftnlen), chkout_(char *, ftnlen);
static logical eoc;
static char tkv[12];
/* $ Abstract */
/* NAIF Toolkit utility program for adding, reading, extracting, */
/* and deleting comments from a binary 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 */
/* SPC */
/* DAS */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* K.R. Gehringer (JPL) */
/* J.E. McLean (JPL) */
/* M.J. Spencer (JPL) */
/* $ Version */
/* - Version 6.0.1, 08-MAY-2001 (BVS) */
/* Increased LINLEN from 255 to 1000 to make it consistent */
/* with SPICELIB's SPC* and SUPPORT's DAF* internal line sizes. */
/* - Version 5.0.1, 21-JUL-1997 (WLT) */
/* Modified the banner at start up so that the version of the */
/* toolkit used to link COMMNT will be displayed. */
/* In addition all WRITE statements were replaced by calls to */
/* TOSTDO. */
/* - Version 5.0.0, 05-MAY-1994 (KRG) */
/* Modified the program to use the new file type identification */
/* capability that was added to spicelib. No file type menu is */
/* necessary now, as the file type is determined during the */
/* execution of the program. */
/* The prompts for the begin and end markers used to extract a */
/* subset of text lines from an input comment file which were then */
/* placed into the comment area of a SPICE binary kernel file have */
/* been removed. The entire input comment file is now placed into */
/* the comment area of the binary kernel file. This change */
/* simplifies the user interaction with the program. */
/* Added support for the new PCK binary kernel files. */
/* If an error occurs during the extraction of comments to a file, */
/* the file that was being created is deleted. We cannot know */
/* whether the file had been successfully created before the error */
/* occurred. */
/* - Version 4.0.0, 11-DEC-1992 (KRG) */
/* Added code to support the E-Kernel, and redesigned the */
/* user interface. */
/* - Version 3.1.0, 19-NOV-1991 (MJS) */
/* Variable QUIT initialized to FALSE. */
/* - Version 3.0.1, 10-AUG-1991 (CHA) (NJB) */
/* Updated comments to reflect status as a Toolkit */
/* utility program. Message indicating that no comments */
/* were found in the specified file was changed to include */
/* the file name. */
/* - Version 2.0.0, 28-JUN-1991 (JEM) */
/* The option to read the comments from the comment */
/* area of a binary SPK or CK was added to the menu. */
/* - Version 1.0.0, 05-APR-1991 (JEM) */
/* -& */
/* SPICELIB functions */
/* Parameters */
/* Set the version of the comment program. This should be updated */
/* every time a change is made, and it should agree with the */
/* version number in the header. */
/* Set a value for the logical unit which represents the standard */
/* output device, commonly a terminal. A value of 6 is widely used, */
/* but the Fortran standard does not specify a value, so it may be */
/* different for different Fortran implementations. */
/* Lower bound for a SPICELIB CELL data structure. */
/* Maximum number of open binary files allowed. */
/* Set a value for a replacement marker. */
/* Set a value for a filename prompt. */
/* File types */
/* Set a value for the length of a text line. */
/* Set a value for the length of an error message. */
/* Set a value for the length of a filename. */
/* Set a length for the prompts in the prompt table. */
/* Set a length for the status of a file: 'OLD' or 'NEW'. */
/* Set the length for the architecture of a file. */
/* Set the length for the type of a file. */
/* Set a length for the option values. */
/* Set a length for the title of a menu. */
/* Set a length for an option name (what is typed to select it) */
/* for a menu. */
/* Set the length of the text description of an option on a menu. */
/* The number of options available on the main menu. */
/* Set up some mnemonics for indexing the prompts in the prompt */
/* table. */
/* Set the maximum size of the filename table: this must be the */
/* number of distinct ``types'' of files that the program may */
/* require. */
/* Set up some mnemonics for indexing the messages in the message */
/* table. */
/* Set the maximum size of the message table: There should be a */
/* message for each ``type'' of action that the program can take. */
/* Set up some mnemonics for the OK and not OK status messages. */
/* Set the maximum number of status messages that are available. */
/* We need to have TKVLEN characters to hold the current version */
/* of the toolkit. */
/* Variables */
/* We want to insert a blank line between additions if there are */
/* already comments in the binary file. We indicate this by giving */
/* the variable INSBLN the value .TRUE.. */
/* Define the main menu title ... */
/* Define the main menu option values ... */
/* Define the main menu descriptive text for each option ... */
/* Define the main menu option names ... */
/* Register the COMMNT main program with the SPICELIB error handler. */
chkin_("COMMNT", (ftnlen)6);
clcomm_();
tkvrsn_("TOOLKIT", tkv, (ftnlen)7, (ftnlen)12);
r__ = rtrim_(tkv, (ftnlen)12);
/* Set the error action to 'RETURN'. We don't want the program */
/* to abort if an error is signalled. We check FAILED where */
/* necessary. If an error is signalled, we'll just handle the */
/* error, display an appropriate message, then call RESET at the */
/* end of the loop to continue. */
erract_("SET", "RETURN", (ftnlen)3, (ftnlen)6);
/* Set the error messages that we want to have displayed. We will */
/* diaplay the SPICELIB short and long error messages. This is done */
/* to ensure that some sort of an error message is displayed if an */
/* error occurs. In several places, long error messages are not set, */
/* so if only the long error messages were displayed, it would be */
/* possible to have an error signalled and not see any error */
/* information. This is not a very useful thing. */
errprt_("SET", "NONE, SHORT, LONG, TRACEBACK", (ftnlen)3, (ftnlen)28);
/* Set up the prompt table for the different types of files. */
s_copy(prmtbl + 80, "Enter the name of the comment file to be #.", (
ftnlen)80, (ftnlen)43);
s_copy(prmtbl, "Enter the name of the binary file.", (ftnlen)80, (ftnlen)
34);
/* Set up the message table for the different ``types'' of */
/* operations. The message table contains generic messages which will */
/* have their missing parts filled in after the option and file type */
/* havve been selected. */
s_copy(messgs, "Reading the comment area of the # file.", (ftnlen)1000, (
ftnlen)39);
s_copy(messgs + 1000, "Adding comments to the # file.", (ftnlen)1000, (
ftnlen)30);
s_copy(messgs + 2000, "Extracting comments from the # file.", (ftnlen)
1000, (ftnlen)36);
s_copy(messgs + 3000, "Deleting the comment area of # file.", (ftnlen)
1000, (ftnlen)36);
s_copy(messgs + 4000, "Quitting the program.", (ftnlen)1000, (ftnlen)21);
s_copy(messgs + 5000, "The comments were successfully #.", (ftnlen)1000, (
ftnlen)33);
s_copy(messgs + 6000, "The comments were NOT successfully #.", (ftnlen)
1000, (ftnlen)37);
/* Display a brief commercial with the name of the program and the */
/* version. */
s_copy(line, " Welcome to COMMNT Version: #", (ftnlen)1000, (ftnlen)31);
repmc_(line, "#", "6.0.1", line, (ftnlen)1000, (ftnlen)1, (ftnlen)5, (
ftnlen)1000);
tostdo_(" ", (ftnlen)1);
tostdo_(line, (ftnlen)1000);
/* Writing concatenation */
i__1[0] = 23, a__1[0] = " (Spice Toolkit ";
i__1[1] = r__, a__1[1] = tkv;
i__1[2] = 1, a__1[2] = ")";
s_cat(line, a__1, i__1, &c__3, (ftnlen)1000);
tostdo_(line, (ftnlen)1000);
tostdo_(" ", (ftnlen)1);
/* Initialize the CELL oriented set for collecting open DAF or DAS */
/* files in the event of an error. */
ssizei_(&c__1, opnset);
/* While there is still more to do ... */
done = FALSE_;
while(! done) {
/* We initialize a few things here, so that they get reset for */
/* every trip through the loop. */
/* Initialize the logical flags that we use. */
comnts = FALSE_;
contnu = TRUE_;
eoc = FALSE_;
ndfnms = FALSE_;
/* Initialize the filename table, ... */
s_copy(fnmtbl, " ", (ftnlen)128, (ftnlen)1);
s_copy(fnmtbl + 128, " ", (ftnlen)128, (ftnlen)1);
/* the file status table, ... */
s_copy(statbl, " ", (ftnlen)3, (ftnlen)1);
s_copy(statbl + 3, " ", (ftnlen)3, (ftnlen)1);
/* the table indices, ... */
tblidx[0] = 0;
tblidx[1] = 0;
/* set the number of file names to zero, ... */
numfnm = 0;
/* the prompts in the prompt table, ... */
s_copy(prmpts, " ", (ftnlen)80, (ftnlen)1);
s_copy(prmpts + 80, " ", (ftnlen)80, (ftnlen)1);
/* the message, and the option. */
s_copy(messag, " ", (ftnlen)1000, (ftnlen)1);
s_copy(option, " ", (ftnlen)20, (ftnlen)1);
/* Set the status messages. */
s_copy(status, messgs + 5000, (ftnlen)1000, (ftnlen)1000);
s_copy(status + 1000, messgs + 6000, (ftnlen)1000, (ftnlen)1000);
/* Get the option to be performed from the main menu. */
getopt_(maintl, &c__5, mainnm, maintx, &iopt, (ftnlen)20, (ftnlen)1, (
ftnlen)40);
s_copy(option, mainvl + ((i__2 = iopt - 1) < 5 && 0 <= i__2 ? i__2 :
s_rnge("mainvl", i__2, "commnt_", (ftnlen)502)) * 20, (ftnlen)
20, (ftnlen)20);
/* Set up the messages and other information for the option */
/* selected. */
if (contnu) {
if (s_cmp(option, "ADD_COMMENTS", (ftnlen)20, (ftnlen)12) == 0) {
ndfnms = TRUE_;
numfnm = 2;
s_copy(messag, messgs + 1000, (ftnlen)1000, (ftnlen)1000);
tblidx[0] = 2;
s_copy(prmpts, prmtbl + 80, (ftnlen)80, (ftnlen)80);
repmc_(prmpts, "#", "added", prmpts, (ftnlen)80, (ftnlen)1, (
ftnlen)5, (ftnlen)80);
s_copy(statbl + 3, "OLD", (ftnlen)3, (ftnlen)3);
tblidx[1] = 1;
s_copy(prmpts + 80, prmtbl, (ftnlen)80, (ftnlen)80);
s_copy(statbl, "OLD", (ftnlen)3, (ftnlen)3);
/* Set the operation status messages. */
s_copy(status, messgs + 5000, (ftnlen)1000, (ftnlen)1000);
repmc_(status, "#", "added", status, (ftnlen)1000, (ftnlen)1,
(ftnlen)5, (ftnlen)1000);
s_copy(status + 1000, messgs + 6000, (ftnlen)1000, (ftnlen)
1000);
repmc_(status + 1000, "#", "added", status + 1000, (ftnlen)
1000, (ftnlen)1, (ftnlen)5, (ftnlen)1000);
} else if (s_cmp(option, "READ_COMMENTS", (ftnlen)20, (ftnlen)13)
== 0) {
ndfnms = TRUE_;
numfnm = 1;
s_copy(messag, messgs, (ftnlen)1000, (ftnlen)1000);
tblidx[0] = 1;
s_copy(prmpts, prmtbl, (ftnlen)80, (ftnlen)80);
s_copy(statbl, "OLD", (ftnlen)3, (ftnlen)3);
/* Set the operation status messages. */
s_copy(status, messgs + 5000, (ftnlen)1000, (ftnlen)1000);
repmc_(status, "#", "read", status, (ftnlen)1000, (ftnlen)1, (
ftnlen)4, (ftnlen)1000);
s_copy(status + 1000, messgs + 6000, (ftnlen)1000, (ftnlen)
1000);
repmc_(status + 1000, "#", "read", status + 1000, (ftnlen)
1000, (ftnlen)1, (ftnlen)4, (ftnlen)1000);
} else if (s_cmp(option, "EXTRACT_COMMENTS", (ftnlen)20, (ftnlen)
16) == 0) {
ndfnms = TRUE_;
numfnm = 2;
s_copy(messag, messgs + 2000, (ftnlen)1000, (ftnlen)1000);
tblidx[0] = 1;
s_copy(prmpts, prmtbl, (ftnlen)80, (ftnlen)80);
s_copy(statbl, "OLD", (ftnlen)3, (ftnlen)3);
tblidx[1] = 2;
s_copy(prmpts + 80, prmtbl + 80, (ftnlen)80, (ftnlen)80);
repmc_(prmpts + 80, "#", "created", prmpts + 80, (ftnlen)80, (
ftnlen)1, (ftnlen)7, (ftnlen)80);
s_copy(statbl + 3, "NEW", (ftnlen)3, (ftnlen)3);
/* Set the operation status messages. */
s_copy(status, messgs + 5000, (ftnlen)1000, (ftnlen)1000);
repmc_(status, "#", "extracted", status, (ftnlen)1000, (
ftnlen)1, (ftnlen)9, (ftnlen)1000);
s_copy(status + 1000, messgs + 6000, (ftnlen)1000, (ftnlen)
1000);
repmc_(status + 1000, "#", "extracted", status + 1000, (
ftnlen)1000, (ftnlen)1, (ftnlen)9, (ftnlen)1000);
} else if (s_cmp(option, "DELETE_COMMENTS", (ftnlen)20, (ftnlen)
15) == 0) {
ndfnms = TRUE_;
numfnm = 1;
s_copy(messag, messgs + 3000, (ftnlen)1000, (ftnlen)1000);
tblidx[0] = 1;
s_copy(prmpts, prmtbl, (ftnlen)80, (ftnlen)80);
s_copy(statbl, "OLD", (ftnlen)3, (ftnlen)3);
/* Set the operation status messages. */
s_copy(status, messgs + 5000, (ftnlen)1000, (ftnlen)1000);
repmc_(status, "#", "deleted", status, (ftnlen)1000, (ftnlen)
1, (ftnlen)7, (ftnlen)1000);
s_copy(status + 1000, messgs + 6000, (ftnlen)1000, (ftnlen)
1000);
repmc_(status + 1000, "#", "deleted", status + 1000, (ftnlen)
1000, (ftnlen)1, (ftnlen)7, (ftnlen)1000);
} else if (s_cmp(option, "QUIT", (ftnlen)20, (ftnlen)4) == 0) {
s_copy(messag, messgs + 4000, (ftnlen)1000, (ftnlen)1000);
}
}
/* Collect any filenames that we may need. */
if (contnu && ndfnms) {
/* we always need at least one filename if we get to here. */
i__ = 1;
more = TRUE_;
while(more) {
fileok = FALSE_;
tryagn = TRUE_;
while(tryagn) {
tostdo_(" ", (ftnlen)1);
tostdo_(prmpts + ((i__2 = i__ - 1) < 2 && 0 <= i__2 ?
i__2 : s_rnge("prmpts", i__2, "commnt_", (ftnlen)
614)) * 80, (ftnlen)80);
tostdo_(" ", (ftnlen)1);
getfnm_("Filename? ", statbl + ((i__3 = tblidx[(i__2 =
i__ - 1) < 2 && 0 <= i__2 ? i__2 : s_rnge("tblidx"
, i__2, "commnt_", (ftnlen)617)] - 1) < 2 && 0 <=
i__3 ? i__3 : s_rnge("statbl", i__3, "commnt_", (
ftnlen)617)) * 3, fnmtbl + (((i__5 = tblidx[(i__4
= i__ - 1) < 2 && 0 <= i__4 ? i__4 : s_rnge("tbl"
"idx", i__4, "commnt_", (ftnlen)617)] - 1) < 2 &&
0 <= i__5 ? i__5 : s_rnge("fnmtbl", i__5, "commn"
"t_", (ftnlen)617)) << 7), &fileok, errmsg, (
ftnlen)10, (ftnlen)3, (ftnlen)128, (ftnlen)320);
/* If the filename is OK, increment the filename index */
/* and leave the try again loop. Otherwise, write out the */
/* error message, and give the opportunity to go around */
/* again. */
if (fileok) {
++i__;
tryagn = FALSE_;
} else {
tostdo_(" ", (ftnlen)1);
tostdo_(errmsg, (ftnlen)320);
tostdo_(" ", (ftnlen)1);
cnfirm_("Try again? (Yes/No) ", &tryagn, (ftnlen)20);
if (! tryagn) {
contnu = FALSE_;
more = FALSE_;
}
}
}
if (i__ > numfnm) {
more = FALSE_;
}
}
}
/* Get the file architecture and type. */
if (contnu && ndfnms) {
getfat_(fnmtbl, arch, type__, (ftnlen)128, (ftnlen)3, (ftnlen)4);
if (failed_()) {
contnu = FALSE_;
}
}
/* Check to see that we got back a valid architecture and type. */
if (contnu && ndfnms) {
if (s_cmp(arch, "?", (ftnlen)3, (ftnlen)1) == 0 || s_cmp(type__,
"?", (ftnlen)4, (ftnlen)1) == 0) {
contnu = FALSE_;
setmsg_("The architecture and type of the binary file '#' co"
"uld not be determined. A common error is to give the"
" name of a text file instead of the name of a binary"
" file.", (ftnlen)161);
errch_("#", fnmtbl, (ftnlen)1, (ftnlen)128);
sigerr_("SPICE(BADFILEFORMAT)", (ftnlen)20);
}
}
/* Customize the message. We know we can do this, because we */
/* need files, and so we don't have the QUIT message. */
if (contnu && ndfnms) {
repmc_(messag, "#", type__, messag, (ftnlen)1000, (ftnlen)1, (
ftnlen)4, (ftnlen)1000);
}
/* Process the option that was selected so long ago. */
if (contnu) {
if (s_cmp(option, "QUIT", (ftnlen)20, (ftnlen)4) == 0) {
tostdo_(" ", (ftnlen)1);
tostdo_(messag, (ftnlen)1000);
tostdo_(" ", (ftnlen)1);
done = TRUE_;
} else if (s_cmp(option, "ADD_COMMENTS", (ftnlen)20, (ftnlen)12)
== 0) {
tostdo_(" ", (ftnlen)1);
tostdo_(messag, (ftnlen)1000);
s_copy(line, "From File: #", (ftnlen)1000, (ftnlen)12);
repmc_(line, "#", fnmtbl + 128, line, (ftnlen)1000, (ftnlen)1,
(ftnlen)128, (ftnlen)1000);
tostdo_(" ", (ftnlen)1);
tostdo_(line, (ftnlen)1000);
s_copy(line, "To File : #", (ftnlen)1000, (ftnlen)12);
repmc_(line, "#", fnmtbl, line, (ftnlen)1000, (ftnlen)1, (
ftnlen)128, (ftnlen)1000);
tostdo_(line, (ftnlen)1000);
/* Open the text file which contains the comments to be */
/* added to the binary file. */
txtopr_(fnmtbl + 128, &comlun, (ftnlen)128);
if (! failed_()) {
if (s_cmp(type__, "CK", (ftnlen)4, (ftnlen)2) == 0) {
/* Open the binary file, add the comments, and close */
/* the binary file. */
dafopw_(fnmtbl, &handle, (ftnlen)128);
spcac_(&handle, &comlun, " ", " ", (ftnlen)1, (ftnlen)
1);
dafcls_(&handle);
} else if (s_cmp(type__, "PCK", (ftnlen)4, (ftnlen)3) ==
0) {
/* Open the binary file, add the comments, and close */
/* the binary file. */
dafopw_(fnmtbl, &handle, (ftnlen)128);
spcac_(&handle, &comlun, " ", " ", (ftnlen)1, (ftnlen)
1);
dafcls_(&handle);
} else if (s_cmp(type__, "SPK", (ftnlen)4, (ftnlen)3) ==
0) {
/* Open the binary file, add the comments, and close */
/* the binary file. */
dafopw_(fnmtbl, &handle, (ftnlen)128);
spcac_(&handle, &comlun, " ", " ", (ftnlen)1, (ftnlen)
1);
dafcls_(&handle);
} else if (s_cmp(type__, "EK", (ftnlen)4, (ftnlen)2) == 0)
{
/* Open the binary file, add the comments, and close */
/* the binary file. */
dasopw_(fnmtbl, &handle, (ftnlen)128);
dasacu_(&comlun, " ", " ", &insbln, &handle, (ftnlen)
1, (ftnlen)1);
dascls_(&handle);
}
/* Close the comment file. */
cl__1.cerr = 0;
cl__1.cunit = comlun;
cl__1.csta = 0;
f_clos(&cl__1);
}
/* Display the status of the operation that was selected. */
tostdo_(" ", (ftnlen)1);
if (failed_()) {
tostdo_(status + 1000, (ftnlen)1000);
} else {
tostdo_(status, (ftnlen)1000);
}
} else if (s_cmp(option, "READ_COMMENTS", (ftnlen)20, (ftnlen)13)
== 0) {
tostdo_(" ", (ftnlen)1);
tostdo_(messag, (ftnlen)1000);
s_copy(line, "File: #", (ftnlen)1000, (ftnlen)7);
repmc_(line, "#", fnmtbl, line, (ftnlen)1000, (ftnlen)1, (
ftnlen)128, (ftnlen)1000);
tostdo_(" ", (ftnlen)1);
tostdo_(line, (ftnlen)1000);
tostdo_(" ", (ftnlen)1);
if (s_cmp(type__, "CK", (ftnlen)4, (ftnlen)2) == 0) {
/* Open the binary file, read the comments, and close */
/* the binary file. */
dafopr_(fnmtbl, &handle, (ftnlen)128);
/* The comments are read a line at a time and displayed */
/* on the screen. */
spcrfl_(&handle, line, &eoc, (ftnlen)1000);
if (! failed_()) {
if (eoc) {
tostdo_("There were no comments found in the fil"
"e.", (ftnlen)41);
}
while(! eoc && ! failed_()) {
tostdo_(line, (ftnlen)1000);
spcrnl_(line, &eoc, (ftnlen)1000);
}
}
dafcls_(&handle);
} else if (s_cmp(type__, "PCK", (ftnlen)4, (ftnlen)3) == 0) {
/* Open the binary file, read the comments, and close */
/* the binary file. */
dafopr_(fnmtbl, &handle, (ftnlen)128);
/* The comments are read a line at a time and displayed */
/* on the screen. */
spcrfl_(&handle, line, &eoc, (ftnlen)1000);
if (! failed_()) {
if (eoc) {
tostdo_("There were no commentfound in the file.",
(ftnlen)39);
}
while(! eoc && ! failed_()) {
tostdo_(line, (ftnlen)1000);
spcrnl_(line, &eoc, (ftnlen)1000);
}
}
dafcls_(&handle);
} else if (s_cmp(type__, "SPK", (ftnlen)4, (ftnlen)3) == 0) {
/* Open the binary file, read the comments, and close */
/* the binary file. */
dafopr_(fnmtbl, &handle, (ftnlen)128);
/* The comments are read a line at a time and displayed */
/* on the screen. */
spcrfl_(&handle, line, &eoc, (ftnlen)1000);
if (! failed_()) {
if (eoc) {
tostdo_("There were no comments found in the fil"
"e.", (ftnlen)41);
}
while(! eoc && ! failed_()) {
tostdo_(line, (ftnlen)1000);
spcrnl_(line, &eoc, (ftnlen)1000);
}
}
dafcls_(&handle);
} else if (s_cmp(type__, "EK", (ftnlen)4, (ftnlen)2) == 0) {
/* Open the binary file, read the comments, and close */
/* the binary file. */
dasopr_(fnmtbl, &handle, (ftnlen)128);
dasecu_(&handle, &c__6, &comnts);
dascls_(&handle);
if (! comnts) {
s_copy(line, "There were no comments found in the fi"
"le.", (ftnlen)1000, (ftnlen)41);
tostdo_(line, (ftnlen)1000);
}
}
/* Display the status of the operation that was selected. */
tostdo_(" ", (ftnlen)1);
if (failed_()) {
tostdo_(status + 1000, (ftnlen)1000);
} else {
tostdo_(status, (ftnlen)1000);
}
} else if (s_cmp(option, "EXTRACT_COMMENTS", (ftnlen)20, (ftnlen)
16) == 0) {
tostdo_(" ", (ftnlen)1);
tostdo_(messag, (ftnlen)1000);
s_copy(line, "From File: #", (ftnlen)1000, (ftnlen)12);
repmc_(line, "#", fnmtbl, line, (ftnlen)1000, (ftnlen)1, (
ftnlen)128, (ftnlen)1000);
tostdo_(" ", (ftnlen)1);
tostdo_(line, (ftnlen)1000);
s_copy(line, "To File : #", (ftnlen)1000, (ftnlen)12);
repmc_(line, "#", fnmtbl + 128, line, (ftnlen)1000, (ftnlen)1,
(ftnlen)128, (ftnlen)1000);
tostdo_(line, (ftnlen)1000);
/* Open the text file. */
txtopn_(fnmtbl + 128, &comlun, (ftnlen)128);
if (! failed_()) {
if (s_cmp(type__, "CK", (ftnlen)4, (ftnlen)2) == 0) {
/* Open the binary file, extract the comments, and */
/* close the binary file. */
dafopr_(fnmtbl, &handle, (ftnlen)128);
spcec_(&handle, &comlun);
dafcls_(&handle);
} else if (s_cmp(type__, "PCK", (ftnlen)4, (ftnlen)3) ==
0) {
/* Open the binary file, extract the comments, and */
/* close the binary file. */
dafopr_(fnmtbl, &handle, (ftnlen)128);
spcec_(&handle, &comlun);
dafcls_(&handle);
} else if (s_cmp(type__, "SPK", (ftnlen)4, (ftnlen)3) ==
0) {
/* Open the binary file, extract the comments, and */
/* close the binary file. */
dafopr_(fnmtbl, &handle, (ftnlen)128);
spcec_(&handle, &comlun);
dafcls_(&handle);
} else if (s_cmp(type__, "EK", (ftnlen)4, (ftnlen)2) == 0)
{
/* Open the binary file, extract the comments, and */
/* close the binary file. */
dasopr_(fnmtbl, &handle, (ftnlen)128);
dasecu_(&handle, &comlun, &comnts);
dascls_(&handle);
if (! comnts) {
s_copy(line, "There were no comments found in th"
"e file.", (ftnlen)1000, (ftnlen)41);
tostdo_(line, (ftnlen)1000);
}
}
/* Close the text file that we opened. */
cl__1.cerr = 0;
cl__1.cunit = comlun;
cl__1.csta = 0;
f_clos(&cl__1);
}
/* Display the status of the operation that was selected. */
tostdo_(" ", (ftnlen)1);
if (failed_()) {
tostdo_(status + 1000, (ftnlen)1000);
} else {
tostdo_(status, (ftnlen)1000);
}
} else if (s_cmp(option, "DELETE_COMMENTS", (ftnlen)20, (ftnlen)
15) == 0) {
tostdo_(" ", (ftnlen)1);
tostdo_(messag, (ftnlen)1000);
s_copy(line, "File: #", (ftnlen)1000, (ftnlen)7);
repmc_(line, "#", fnmtbl, line, (ftnlen)1000, (ftnlen)1, (
ftnlen)128, (ftnlen)1000);
tostdo_(" ", (ftnlen)1);
tostdo_(line, (ftnlen)1000);
if (s_cmp(type__, "CK", (ftnlen)4, (ftnlen)2) == 0) {
/* Open the binary file, delete the comments, and close */
/* the binary file. */
dafopw_(fnmtbl, &handle, (ftnlen)128);
spcdc_(&handle);
dafcls_(&handle);
} else if (s_cmp(type__, "PCK", (ftnlen)4, (ftnlen)3) == 0) {
/* Open the binary file, delete the comments, and close */
/* the binary file. */
dafopw_(fnmtbl, &handle, (ftnlen)128);
spcdc_(&handle);
dafcls_(&handle);
} else if (s_cmp(type__, "SPK", (ftnlen)4, (ftnlen)3) == 0) {
/* Open the binary file, delete the comments, and close */
/* the binary file. */
dafopw_(fnmtbl, &handle, (ftnlen)128);
spcdc_(&handle);
dafcls_(&handle);
} else if (s_cmp(type__, "EK", (ftnlen)4, (ftnlen)2) == 0) {
/* Open the binary file, delete the comments, and close */
/* the binary file. */
dasopw_(fnmtbl, &handle, (ftnlen)128);
dasdc_(&handle);
dascls_(&handle);
}
/* Display the status of the operation that was selected. */
tostdo_(" ", (ftnlen)1);
if (failed_()) {
tostdo_(status + 1000, (ftnlen)1000);
} else {
tostdo_(status, (ftnlen)1000);
}
}
}
/* If anything failed, close any binary files that might still be */
/* open and reset the error handling before getting the next */
/* option. */
if (failed_()) {
/* Before we can attempt to perform any clean up actions if an */
/* error occurred, we need to reset the SPICELIB error handling */
/* mechanism so that we can call the SPICELIB routines that we */
/* need to. */
reset_();
/* Clear out any binary file handles in the open set, OPNSET. */
scardi_(&c__0, opnset);
cleari_(&c__1, &opnset[6]);
/* Get the handles for any DAF files which may still be open. */
dafhof_(opnset);
numopn = cardi_(opnset);
if (numopn > 0) {
i__2 = numopn;
for (i__ = 1; i__ <= i__2; ++i__) {
dafcls_(&opnset[(i__3 = i__ + 5) < 7 && 0 <= i__3 ? i__3 :
s_rnge("opnset", i__3, "commnt_", (ftnlen)1100)])
;
}
}
/* Clear out any binary file handles in the open set, OPNSET. */
scardi_(&c__0, opnset);
cleari_(&c__1, &opnset[6]);
/* Get the handles for any DAS files which may still be open. */
dashof_(opnset);
numopn = cardi_(opnset);
if (numopn > 0) {
i__2 = numopn;
for (i__ = 1; i__ <= i__2; ++i__) {
dascls_(&opnset[(i__3 = i__ + 5) < 7 && 0 <= i__3 ? i__3 :
s_rnge("opnset", i__3, "commnt_", (ftnlen)1121)])
;
}
}
/* If there was an error and we were extracting comments to a */
/* file, then we should delete the file that was created, */
/* because we do not know whether the extraction was completed */
/* successfully. */
if (s_cmp(option, "EXTRACT_COMMENTS", (ftnlen)20, (ftnlen)16) ==
0) {
if (exists_(fnmtbl + 128, (ftnlen)128)) {
delfil_(fnmtbl + 128, (ftnlen)128);
}
}
/* Finally, reset the error handling, and go get the next */
/* option. This is just to be sure. */
reset_();
}
}
chkout_("COMMNT", (ftnlen)6);
return 0;
} /* MAIN__ */
