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