/* Subroutine */ int objnth_(integer *objlis, integer *n, integer *obj, logical *found) { /* System generated locals */ integer i__1; /* Local variables */ integer nobj, used, size, i__; extern integer cardi_(integer *); integer mtasiz, ptr; /* $ Abstract */ /* Constants required by the family of "object" routines. */ /* $ Disclaimer */ /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */ /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */ /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */ /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */ /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */ /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */ /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */ /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */ /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */ /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */ /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */ /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */ /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */ /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */ /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */ /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */ /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */ /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */ /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */ /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */ /* $ Required_Reading */ /* None. */ /* $ Keywords */ /* OBJECTS */ /* $ Parameters */ /* LBCELL is the lower bound for all cells used throughout */ /* the SPICE library.. */ /* NULL is a constant used to indicate that a particular */ /* object in a list is unused. */ /* RMPOBJ is the slot in the object list that tells how */ /* many values are stored for each object. I.E. */ /* the number of values stored for each object */ /* in an object list OBJLIS is OBJLIS(RMPOBJ). */ /* NACTIV is the slot in an object list that tells hows */ /* many objects in the list are currently active. */ /* In otherwords the number of active objects */ /* in the object list OBJLIS is OBJLIS(NACTIV) */ /* LSTID is the slot in an object list that gives the */ /* last object unique ID that was assigned. */ /* In otherwords, the value of the last unique */ /* object ID code in the object list OBJLIS */ /* is OBJLIS(LSTID). */ /* $ Files */ /* None. */ /* $ Exceptions */ /* Not Applicable */ /* $ Particulars */ /* This include file contains the parameters used by the */ /* family of object routines. */ /* $ Author_and_Institution */ /* W.L. Taber (JPL) */ /* $ Literature_References */ /* None. */ /* $ Version */ /* - SPICELIB Version 1.0.0, 23-FEB-1996 (WLT) */ /* -& */ /* SPICELIB Functions */ /* Local Variables */ nobj = objlis[2]; mtasiz = objlis[3]; size = cardi_(objlis); used = nobj * mtasiz; if (*n <= 0) { obj[0] = 0; obj[1] = 0; *found = FALSE_; return 0; } if (*n > nobj) { obj[0] = 0; obj[1] = 0; *found = FALSE_; return 0; } /* The easy case is the one in which all objects are packed */ /* together with no null objects between them. */ if (used == size) { ptr = (*n - 1) * mtasiz + 1; obj[0] = ptr; obj[1] = objlis[ptr + 5]; *found = TRUE_; return 0; } /* Hmmmm. Well we don't have the easy case. Look through */ /* the objects until we find the n'th non-null object. */ ptr = 1 - mtasiz; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { ptr += mtasiz; while(objlis[ptr + 5] == 0) { ptr += mtasiz; } } obj[0] = ptr; obj[1] = objlis[ptr + 5]; return 0; } /* objnth_ */
/* Subroutine */ int objnxt_(integer *obj, integer *objlis, integer *objn, logical *found) { integer size, i__; extern integer cardi_(integer *); logical ok; extern /* Subroutine */ int objchk_(char *, integer *, integer *, logical *, ftnlen); integer mtasiz, ptr; /* $ Abstract */ /* Constants required by the family of "object" routines. */ /* $ Disclaimer */ /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */ /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */ /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */ /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */ /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */ /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */ /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */ /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */ /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */ /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */ /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */ /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */ /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */ /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */ /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */ /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */ /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */ /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */ /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */ /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */ /* $ Required_Reading */ /* None. */ /* $ Keywords */ /* OBJECTS */ /* $ Parameters */ /* LBCELL is the lower bound for all cells used throughout */ /* the SPICE library.. */ /* NULL is a constant used to indicate that a particular */ /* object in a list is unused. */ /* RMPOBJ is the slot in the object list that tells how */ /* many values are stored for each object. I.E. */ /* the number of values stored for each object */ /* in an object list OBJLIS is OBJLIS(RMPOBJ). */ /* NACTIV is the slot in an object list that tells hows */ /* many objects in the list are currently active. */ /* In otherwords the number of active objects */ /* in the object list OBJLIS is OBJLIS(NACTIV) */ /* LSTID is the slot in an object list that gives the */ /* last object unique ID that was assigned. */ /* In otherwords, the value of the last unique */ /* object ID code in the object list OBJLIS */ /* is OBJLIS(LSTID). */ /* $ Files */ /* None. */ /* $ Exceptions */ /* Not Applicable */ /* $ Particulars */ /* This include file contains the parameters used by the */ /* family of object routines. */ /* $ Author_and_Institution */ /* W.L. Taber (JPL) */ /* $ Literature_References */ /* None. */ /* $ Version */ /* - SPICELIB Version 1.0.0, 23-FEB-1996 (WLT) */ /* -& */ /* Spicelib Function */ /* Local Variables */ /* Perform some sanity checks on the OBJ. Note OBJCHK */ /* does all the required checking in and checking out. */ objchk_("OBJNXT", obj, objlis, &ok, (ftnlen)6); size = cardi_(objlis); mtasiz = objlis[3]; if (! ok) { return 0; } ptr = obj[0]; if (ptr == 0) { ptr = 1; } i__ = ptr + mtasiz; while(i__ < size) { /* If this object is a non-null object, then we're done */ /* looking. */ if (objlis[i__ + 5] != 0) { objn[0] = i__; objn[1] = objlis[i__ + 5]; *found = TRUE_; return 0; } /* Not done yet. Look at the next object. */ i__ += mtasiz; } /* If you get to this point, there wasn't a next object. */ /* point at the next "available" slot and set the identifier */ /* to null. */ *found = FALSE_; objn[0] = i__; objn[1] = 0; return 0; } /* objnxt_ */
/* $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 GETFAT ( Get file architecture and type ) */ /* Subroutine */ int getfat_(char *file, char *arch, char *kertyp, ftnlen file_len, ftnlen arch_len, ftnlen kertyp_len) { /* System generated locals */ integer i__1; cilist ci__1; olist o__1; cllist cl__1; inlist ioin__1; /* Builtin functions */ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); integer s_cmp(char *, char *, ftnlen, ftnlen), f_inqu(inlist *), s_rnge( char *, integer, char *, integer), f_open(olist *), s_rdue(cilist *), do_uio(integer *, char *, ftnlen), e_rdue(void), f_clos( cllist *), s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void); /* Local variables */ integer unit; extern /* Subroutine */ int zzddhfnh_(char *, integer *, logical *, ftnlen), zzddhgsd_(char *, integer *, char *, ftnlen, ftnlen), zzddhnfo_(integer *, char *, integer *, integer *, integer *, logical *, ftnlen), zzddhhlu_(integer *, char *, logical *, integer *, ftnlen); integer i__; extern integer cardi_(integer *); char fname[255]; extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *, ftnlen, ftnlen); integer which; extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen); logical found, exist; extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen), idw2at_(char *, char *, char *, ftnlen, ftnlen, ftnlen); integer handle; extern /* Subroutine */ int dafcls_(integer *); char filarc[32]; extern /* Subroutine */ int dashof_(integer *); integer intbff; logical opened; extern /* Subroutine */ int dafopr_(char *, integer *, ftnlen); integer intarc; extern /* Subroutine */ int dashlu_(integer *, integer *); char idword[12]; integer intamn, number; logical diropn, notdas; extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, ftnlen), getlun_(integer *), setmsg_(char *, ftnlen); integer iostat; extern /* Subroutine */ int errint_(char *, integer *, ftnlen), ssizei_( integer *, integer *), nextwd_(char *, char *, char *, ftnlen, ftnlen, ftnlen); char tmpwrd[12]; extern logical return_(void); integer myunit, handles[106]; extern /* Subroutine */ int zzckspk_(integer *, char *, ftnlen); /* Fortran I/O blocks */ static cilist io___19 = { 1, 0, 1, 0, 1 }; /* $ Abstract */ /* Determine the architecture and type of SPICE kernels. */ /* $ 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 */ /* KERNEL */ /* UTILITY */ /* $ Declarations */ /* $ Abstract */ /* Parameter declarations for the DAF/DAS handle manager. */ /* $ Disclaimer */ /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */ /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */ /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */ /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */ /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */ /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */ /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */ /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */ /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */ /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */ /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */ /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */ /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */ /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */ /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */ /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */ /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */ /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */ /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */ /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */ /* $ Required_Reading */ /* DAF, DAS */ /* $ Keywords */ /* PRIVATE */ /* $ Particulars */ /* This include file contains parameters defining limits and */ /* integer codes that are utilized in the DAF/DAS handle manager */ /* routines. */ /* $ Restrictions */ /* None. */ /* $ Author_and_Institution */ /* F.S. Turner (JPL) */ /* $ Literature_References */ /* None. */ /* $ Version */ /* - SPICELIB Version 2.5.0, 10-MAR-2014 (BVS) */ /* Updated for SUN-SOLARIS-64BIT-INTEL. */ /* - SPICELIB Version 2.4.0, 10-MAR-2014 (BVS) */ /* Updated for PC-LINUX-64BIT-IFORT. */ /* - SPICELIB Version 2.3.0, 10-MAR-2014 (BVS) */ /* Updated for PC-CYGWIN-GFORTRAN. */ /* - SPICELIB Version 2.2.0, 10-MAR-2014 (BVS) */ /* Updated for PC-CYGWIN-64BIT-GFORTRAN. */ /* - SPICELIB Version 2.1.0, 10-MAR-2014 (BVS) */ /* Updated for PC-CYGWIN-64BIT-GCC_C. */ /* - SPICELIB Version 2.0.0, 12-APR-2012 (BVS) */ /* Increased FTSIZE (from 1000 to 5000). */ /* - SPICELIB Version 1.20.0, 13-MAY-2010 (BVS) */ /* Updated for SUN-SOLARIS-INTEL. */ /* - SPICELIB Version 1.19.0, 13-MAY-2010 (BVS) */ /* Updated for SUN-SOLARIS-INTEL-CC_C. */ /* - SPICELIB Version 1.18.0, 13-MAY-2010 (BVS) */ /* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */ /* - SPICELIB Version 1.17.0, 13-MAY-2010 (BVS) */ /* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */ /* - SPICELIB Version 1.16.0, 13-MAY-2010 (BVS) */ /* Updated for PC-WINDOWS-64BIT-IFORT. */ /* - SPICELIB Version 1.15.0, 13-MAY-2010 (BVS) */ /* Updated for PC-LINUX-64BIT-GFORTRAN. */ /* - SPICELIB Version 1.14.0, 13-MAY-2010 (BVS) */ /* Updated for PC-64BIT-MS_C. */ /* - SPICELIB Version 1.13.0, 13-MAY-2010 (BVS) */ /* Updated for MAC-OSX-64BIT-INTEL_C. */ /* - SPICELIB Version 1.12.0, 13-MAY-2010 (BVS) */ /* Updated for MAC-OSX-64BIT-IFORT. */ /* - SPICELIB Version 1.11.0, 13-MAY-2010 (BVS) */ /* Updated for MAC-OSX-64BIT-GFORTRAN. */ /* - SPICELIB Version 1.10.0, 18-MAR-2009 (BVS) */ /* Updated for PC-LINUX-GFORTRAN. */ /* - SPICELIB Version 1.9.0, 18-MAR-2009 (BVS) */ /* Updated for MAC-OSX-GFORTRAN. */ /* - SPICELIB Version 1.8.0, 19-FEB-2008 (BVS) */ /* Updated for PC-LINUX-IFORT. */ /* - SPICELIB Version 1.7.0, 14-NOV-2006 (BVS) */ /* Updated for PC-LINUX-64BIT-GCC_C. */ /* - SPICELIB Version 1.6.0, 14-NOV-2006 (BVS) */ /* Updated for MAC-OSX-INTEL_C. */ /* - SPICELIB Version 1.5.0, 14-NOV-2006 (BVS) */ /* Updated for MAC-OSX-IFORT. */ /* - SPICELIB Version 1.4.0, 14-NOV-2006 (BVS) */ /* Updated for PC-WINDOWS-IFORT. */ /* - SPICELIB Version 1.3.0, 26-OCT-2005 (BVS) */ /* Updated for SUN-SOLARIS-64BIT-GCC_C. */ /* - SPICELIB Version 1.2.0, 03-JAN-2005 (BVS) */ /* Updated for PC-CYGWIN_C. */ /* - SPICELIB Version 1.1.0, 03-JAN-2005 (BVS) */ /* Updated for PC-CYGWIN. */ /* - SPICELIB Version 1.0.1, 17-JUL-2002 */ /* Added MAC-OSX environments. */ /* - SPICELIB Version 1.0.0, 07-NOV-2001 */ /* -& */ /* Unit and file table size parameters. */ /* FTSIZE is the maximum number of files (DAS and DAF) that a */ /* user may have open simultaneously. */ /* RSVUNT is the number of units protected from being locked */ /* to a particular handle by ZZDDHHLU. */ /* SCRUNT is the number of units protected for use by scratch */ /* files. */ /* UTSIZE is the maximum number of logical units this manager */ /* will utilize at one time. */ /* Access method enumeration. These parameters are used to */ /* identify which access method is associated with a particular */ /* handle. They need to be synchronized with the STRAMH array */ /* defined in ZZDDHGSD in the following fashion: */ /* STRAMH ( READ ) = 'READ' */ /* STRAMH ( WRITE ) = 'WRITE' */ /* STRAMH ( SCRTCH ) = 'SCRATCH' */ /* STRAMH ( NEW ) = 'NEW' */ /* These values are used in the file table variable FTAMH. */ /* Binary file format enumeration. These parameters are used to */ /* identify which binary file format is associated with a */ /* particular handle. They need to be synchronized with the STRBFF */ /* array defined in ZZDDHGSD in the following fashion: */ /* STRBFF ( BIGI3E ) = 'BIG-IEEE' */ /* STRBFF ( LTLI3E ) = 'LTL-IEEE' */ /* STRBFF ( VAXGFL ) = 'VAX-GFLT' */ /* STRBFF ( VAXDFL ) = 'VAX-DFLT' */ /* These values are used in the file table variable FTBFF. */ /* Some random string lengths... more documentation required. */ /* For now this will have to suffice. */ /* Architecture enumeration. These parameters are used to identify */ /* which file architecture is associated with a particular handle. */ /* They need to be synchronized with the STRARC array defined in */ /* ZZDDHGSD in the following fashion: */ /* STRARC ( DAF ) = 'DAF' */ /* STRARC ( DAS ) = 'DAS' */ /* These values will be used in the file table variable FTARC. */ /* For the following environments, record length is measured in */ /* characters (bytes) with eight characters per double precision */ /* number. */ /* Environment: Sun, Sun FORTRAN */ /* Source: Sun Fortran Programmer's Guide */ /* Environment: PC, MS FORTRAN */ /* Source: Microsoft Fortran Optimizing Compiler User's Guide */ /* Environment: Macintosh, Language Systems FORTRAN */ /* Source: Language Systems FORTRAN Reference Manual, */ /* Version 1.2, page 12-7 */ /* Environment: PC/Linux, g77 */ /* Source: Determined by experiment. */ /* Environment: PC, Lahey F77 EM/32 Version 4.0 */ /* Source: Lahey F77 EM/32 Language Reference Manual, */ /* page 144 */ /* Environment: HP-UX 9000/750, FORTRAN/9000 Series 700 computers */ /* Source: FORTRAN/9000 Reference-Series 700 Computers, */ /* page 5-110 */ /* Environment: NeXT Mach OS (Black Hardware), */ /* Absoft Fortran Version 3.2 */ /* Source: NAIF Program */ /* The following parameter defines the size of a string used */ /* to store a filenames on this target platform. */ /* The following parameter controls the size of the character record */ /* buffer used to read data from non-native files. */ /* $ Brief_I/O */ /* VARIABLE I/O DESCRIPTION */ /* -------- --- -------------------------------------------------- */ /* FILE I The name of a file to be examined. */ /* ARCH O The architecture of the kernel file. */ /* KERTYP O The type of the kernel file. */ /* $ Detailed_Input */ /* FILE is the name of a SPICE kernel file whose architecture */ /* and type are desired. */ /* $ Detailed_Output */ /* ARCH is the file architecture of the SPICE kernel file */ /* specified be FILE. If the architecture cannot be */ /* determined or is not recognized the value '?' is */ /* returned. */ /* Architectures currently recognized are: */ /* DAF - The file is based on the DAF architecture. */ /* DAS - The file is based on the DAS architecture. */ /* XFR - The file is in a SPICE transfer file format. */ /* DEC - The file is an old SPICE decimal text file. */ /* ASC -- An ASCII text file. */ /* KPL -- Kernel Pool File (i.e., a text kernel) */ /* TXT -- An ASCII text file. */ /* TE1 -- Text E-Kernel type 1. */ /* ? - The architecture could not be determined. */ /* This variable must be at least 3 characters long. */ /* KERTYP is the type of the SPICE kernel file. If the type */ /* can not be determined the value '?' is returned. */ /* Kernel file types may be any sequence of at most four */ /* printing characters. NAIF has reserved for its use */ /* types which contain all upper case letters. */ /* A file type of 'PRE' means that the file is a */ /* pre-release file. */ /* This variable may be at most 4 characters long. */ /* $ Parameters */ /* RECL is the record length of a binary kernel file. Each */ /* record must be large enough to hold 128 double */ /* precision numbers. The units in which the record */ /* length must be specified vary from environment to */ /* environment. For example, VAX Fortran requires */ /* record lengths to be specified in longwords, */ /* where two longwords equal one double precision */ /* number. */ /* $ Exceptions */ /* 1) If the filename specified is blank, then the error */ /* SPICE(BLANKFILENAME) is signaled. */ /* 2) If any inquire on the filename specified by FILE fails for */ /* some reason, the error SPICE(INQUIREERROR) is signaled. */ /* 3) If the file specified by FILE does not exist, the error */ /* SPICE(FILENOTFOUND) is signaled. */ /* 4) If the file specified by FILE is already open but not through */ /* SPICE interfaces, the error SPICE(EXTERNALOPEN) is signaled. */ /* 5) If an attempt to open the file specified by FILE fails when */ /* this routine requires that it succeed, the error */ /* SPICE(FILEOPENFAILED) is signaled. */ /* 6) If an attempt to read the file specified by FILE fails when */ /* this routine requires that it succeed, the error */ /* SPICE(FILEREADFAILED) is signaled. */ /* 7) Routines in the call tree of this routine may trap and */ /* signal errors. */ /* 8) If the ID word in a DAF based kernel is NAIF/DAF, then the */ /* algorithm GETFAT uses to distinguish between CK and SPK */ /* kernels may result in an indeterminate KERTYP if the SPK or */ /* CK files have invalid first segments. */ /* $ Files */ /* The SPICE kernel file specified by FILE is examined by this */ /* routine to determine its architecture and type. If the file */ /* named by FILE is not connected to a logical unit or loaded */ /* in the handle manager, this routine will OPEN and CLOSE it. */ /* $ Particulars */ /* This subroutine is a support utility routine that determines the */ /* architecture and type of a SPICE kernel file. */ /* $ Examples */ /* Suppose you wish to write a single routine for loading binary */ /* kernels. You can use this routine to determine the type of the */ /* file and then pass the file to the appropriate low level file */ /* loader to handle the actual loading of the file. */ /* CALL GETFAT ( FILE, ARCH, KERTYP ) */ /* IF ( KERTYP .EQ. 'SPK' ) THEN */ /* CALL SPKLEF ( FILE, HANDLE ) */ /* ELSE IF ( KERTYP .EQ. 'CK' ) THEN */ /* CALL CKLPF ( FILE, HANDLE ) */ /* ELSE IF ( KERTYP .EQ. 'EK' ) THEN */ /* CALL EKLEF ( FILE, HANDLE ) */ /* ELSE */ /* WRITE (*,*) 'The file could not be identified as a known' */ /* WRITE (*,*) 'kernel type. Did you load the wrong file' */ /* WRITE (*,*) 'by mistake?' */ /* END IF */ /* $ Restrictions */ /* 1) In order to properly determine the type of DAF based binary */ /* kernels, the routine requires that their first segments and */ /* the meta data necessary to address them are valid. */ /* $ Literature_References */ /* None. */ /* $ Author_and_Institution */ /* K.R. Gehringer (JPL) */ /* H.A. Neilan (JPL) */ /* W.L. Taber (JPL) */ /* F.S. Turner (JPL) */ /* E.D. Wright (JPL) */ /* $ Version */ /* - SPICELIB Version 4.25.0, 10-MAR-2014 (BVS) */ /* Updated for SUN-SOLARIS-64BIT-INTEL. */ /* - SPICELIB Version 4.24.0, 10-MAR-2014 (BVS) */ /* Updated for PC-LINUX-64BIT-IFORT. */ /* - SPICELIB Version 4.23.0, 10-MAR-2014 (BVS) */ /* Updated for PC-CYGWIN-GFORTRAN. */ /* - SPICELIB Version 4.22.0, 10-MAR-2014 (BVS) */ /* Updated for PC-CYGWIN-64BIT-GFORTRAN. */ /* - SPICELIB Version 4.21.0, 10-MAR-2014 (BVS) */ /* Updated for PC-CYGWIN-64BIT-GCC_C. */ /* - SPICELIB Version 4.20.0, 13-MAY-2010 (BVS) */ /* Updated for SUN-SOLARIS-INTEL. */ /* - SPICELIB Version 4.19.0, 13-MAY-2010 (BVS) */ /* Updated for SUN-SOLARIS-INTEL-CC_C. */ /* - SPICELIB Version 4.18.0, 13-MAY-2010 (BVS) */ /* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */ /* - SPICELIB Version 4.17.0, 13-MAY-2010 (BVS) */ /* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */ /* - SPICELIB Version 4.16.0, 13-MAY-2010 (BVS) */ /* Updated for PC-WINDOWS-64BIT-IFORT. */ /* - SPICELIB Version 4.15.0, 13-MAY-2010 (BVS) */ /* Updated for PC-LINUX-64BIT-GFORTRAN. */ /* - SPICELIB Version 4.14.0, 13-MAY-2010 (BVS) */ /* Updated for PC-64BIT-MS_C. */ /* - SPICELIB Version 4.13.0, 13-MAY-2010 (BVS) */ /* Updated for MAC-OSX-64BIT-INTEL_C. */ /* - SPICELIB Version 4.12.0, 13-MAY-2010 (BVS) */ /* Updated for MAC-OSX-64BIT-IFORT. */ /* - SPICELIB Version 4.11.0, 13-MAY-2010 (BVS) */ /* Updated for MAC-OSX-64BIT-GFORTRAN. */ /* - SPICELIB Version 4.10.0, 18-MAR-2009 (BVS) */ /* Updated for PC-LINUX-GFORTRAN. */ /* - SPICELIB Version 4.9.0, 18-MAR-2009 (BVS) */ /* Updated for MAC-OSX-GFORTRAN. */ /* - SPICELIB Version 4.8.0, 19-FEB-2008 (BVS) */ /* Updated for PC-LINUX-IFORT. */ /* - SPICELIB Version 4.7.0, 14-NOV-2006 (BVS) */ /* Updated for PC-LINUX-64BIT-GCC_C. */ /* - SPICELIB Version 4.6.0, 14-NOV-2006 (BVS) */ /* Updated for MAC-OSX-INTEL_C. */ /* - SPICELIB Version 4.5.0, 14-NOV-2006 (BVS) */ /* Updated for MAC-OSX-IFORT. */ /* - SPICELIB Version 4.4.0, 14-NOV-2006 (BVS) */ /* Updated for PC-WINDOWS-IFORT. */ /* - SPICELIB Version 4.3.0, 26-OCT-2005 (BVS) */ /* Updated for SUN-SOLARIS-64BIT-GCC_C. */ /* - SPICELIB Version 4.2.0, 03-JAN-2005 (BVS) */ /* Updated for PC-CYGWIN_C. */ /* - SPICELIB Version 4.1.0, 03-JAN-2005 (BVS) */ /* Updated for PC-CYGWIN. */ /* - SPICELIB Version 4.0.2, 24-APR-2003 (EDW) */ /* Added MAC-OSX-F77 to the list of platforms */ /* that require READONLY to read write protected */ /* kernels. */ /* - SPICELIB Version 4.0.1, 17-JUL-2002 (BVS) */ /* Added MAC-OSX environments. */ /* - SPICELIB Version 4.0.0, 22-AUG-2001 (WLT) (FST) (EDW) */ /* Added code so that the architecture and type of open binary */ /* SPICE kernels can be determined. */ /* Added exception for MACPPC_C (CodeWarrior Mac classic). */ /* Reduced RECL value to 12 to prevent expression of */ /* the fseek bug. */ /* - SPICELIB Version 3.2.0, 06-DEC-1999 (WLT) */ /* The heuristics for distinguishing between CK and SPK have */ /* been enhanced so that the routine is no longer requires */ /* that TICKS in C-kernels be positive or integral. */ /* - SPICELIB Version 3.1.4, 08-OCT-1999 (WLT) */ /* The environment lines were expanded so that the supported */ /* environments are now explicitely given. New */ /* environments are WIN-NT */ /* - SPICELIB Version 3.1.3, 22-SEP-1999 (NJB) */ /* CSPICE environments were added. Some typos were corrected. */ /* - SPICELIB Version 3.1.2, 28-JUL-1999 (WLT) */ /* The environment lines were expanded so that the supported */ /* environments are now explicitly given. New */ /* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */ /* - SPICELIB Version 3.1.1, 18-MAR-1999 (WLT) */ /* The environment lines were expanded so that the supported */ /* environments are now explicitly given. Previously, */ /* environments such as SUN-SUNOS and SUN-SOLARIS were implied */ /* by the environment label SUN. */ /* - SPICELIB Version 3.1.0, 11-FEB-1999 (FST) */ /* Added an integrality check to Test 3. If LASTDP is not */ /* an integral value, then GETFAT simply returns KERTYP = '?', */ /* since it is of an indeterminate type. */ /* - SPICELIB Version 3.0.0, 07-APR-1998 (NJB) */ /* Module was updated for the PC-LINUX platform. */ /* - SPICELIB Version 2.0.0, 19-DEC-1995 (KRG) */ /* Added several new features to the subroutine: */ /* - Error handling has been enhanced. */ /* - Several new file architectures have been added. */ /* Removed the mention of 1000 characters as a candidate for the */ /* record length of a file. */ /* Added the exception for a blank filename to the header. The */ /* error is signalled, but it was not listed in the header. */ /* Added IOSTAT values to the appropriate error messages. */ /* Non-printing characters are replaced with blanks in the ID */ /* word when it is read. This deals with the case where a */ /* platform allows a text file to be opened as an unformatted */ /* file and the ID word does not completely fill 8 characters. */ /* - SPICELIB Version 1.4.0, 5-JAN-1995 (HAN) */ /* Removed ENV11 since it is now the same as ENV2. */ /* Removed ENV10 since it is the same as the VAX environment. */ /* - SPICELIB Version 1.3.0, 30-AUG-1994 (HAN) */ /* Added two new environments, DEC Alpha/OpenVMS and */ /* Sun/Solaris, to the source master file. */ /* - SPICELIB Version 1.2.0, 25-MAR-1994 (HAN) */ /* Added two new environments, DEC Alpha/OpenVMS and */ /* Sun/Solaris, to the source master file. */ /* - SPICELIB Version 1.1.0, 25-MAR-1994 (HAN) */ /* Modified master source code file to use READONLY on platforms */ /* that support it. Also, changed some local declaration comment */ /* lines to match the standard NAIF template. */ /* - SPICELIB Version 1.0.0, 24-JUL-1993 (WLT) (HAN) (KRG) */ /* -& */ /* $ Index_Entries */ /* determine the architecture and type of a kernel file */ /* -& */ /* $ Revisions */ /* - SPICELIB Version 4.0.0, 22-AUG-2001 (WLT) (FST) */ /* Added code so that the architecture and type of open binary */ /* SPICE kernels can be determined. This uses the new DAF/DAS */ /* handle manager as well as examination of handles of open DAS */ /* files. Currently the handle manager deals only with DAF */ /* files. This routine should be updated again when the DAS */ /* system is integrated with the handle manager. */ /* Some slight changes were required to support ZZDDHFNH on */ /* the VAX environment. This resulted in the addition of */ /* the logical USEFNH that is set to true in most */ /* environments, and never used again other than to allow */ /* the invocation of the ZZDDHFNH module. */ /* - SPICELIB Version 2.0.0, 19-DEC-1995 (KRG) */ /* Added several new features to the subroutine: */ /* - Error handling has been enhanced. */ /* - Several new file architectures have been added. */ /* Removed the mention of 1000 characters as a candidate for the */ /* record length of a file. It seems unlikely that we will */ /* encounter an environment where 1000 characters of storage is */ /* larger than the storage necessary for 128 double precision */ /* numbers; typically there are 8 characters per double precision */ /* number, yeilding 1024 characters. */ /* Added the exception for a blank filename to the header. The */ /* error is signalled, but it was not listed in the header. */ /* Added IOSTAT values to the appropriate error messages. */ /* Non-printing characters are replaced with blanks in the ID */ /* word when it is read. This deals with the case where a */ /* platform allows a text file to be opened as an unformatted */ /* file and the ID word does not completely fill 8 characters. */ /* -& */ /* SPICELIB functions */ /* Local parameters */ /* Set the length of a SPICE kernel file ID word. */ /* Set minimum and maximum values for the range of ASCII printing */ /* characters. */ /* Local Variables */ /* Standard SPICE error handling. */ if (return_()) { return 0; } else { chkin_("GETFAT", (ftnlen)6); } /* Initialize the temporary storage variables that we use. */ s_copy(idword, " ", (ftnlen)12, (ftnlen)1); /* If the filename we have is blank, signal an error and return. */ if (s_cmp(file, " ", file_len, (ftnlen)1) == 0) { setmsg_("The file name is blank.", (ftnlen)23); sigerr_("SPICE(BLANKFILENAME)", (ftnlen)20); chkout_("GETFAT", (ftnlen)6); return 0; } /* See if this is a binary file that is currently open */ /* within the SPICE binary file management subsystem. At */ /* the moment, as far as we know, the file is not opened. */ opened = FALSE_; zzddhfnh_(file, &handle, &found, file_len); if (found) { /* If the file was recognized, we need to get the unit number */ /* associated with it. */ zzddhnfo_(&handle, fname, &intarc, &intbff, &intamn, &found, (ftnlen) 255); /* Translate the architecture ID to a string and retrieve the */ /* logical unit to use with this file. */ zzddhgsd_("ARCH", &intarc, filarc, (ftnlen)4, (ftnlen)32); zzddhhlu_(&handle, filarc, &c_false, &number, (ftnlen)32); opened = TRUE_; } else { /* We'll do a bit of inquiring before we try opening anything. */ ioin__1.inerr = 1; ioin__1.infilen = file_len; ioin__1.infile = file; ioin__1.inex = ∃ ioin__1.inopen = &opened; ioin__1.innum = 0; ioin__1.innamed = 0; ioin__1.inname = 0; ioin__1.inacc = 0; ioin__1.inseq = 0; ioin__1.indir = 0; ioin__1.infmt = 0; ioin__1.inform = 0; ioin__1.inunf = 0; ioin__1.inrecl = 0; ioin__1.innrec = 0; ioin__1.inblank = 0; iostat = f_inqu(&ioin__1); /* Not too likely, but if the INQUIRE statement fails... */ if (iostat != 0) { setmsg_("IOSTAT error in INQUIRE statement. IOSTAT = #.", (ftnlen) 46); errint_("#", &iostat, (ftnlen)1); sigerr_("SPICE(INQUIREERROR)", (ftnlen)19); chkout_("GETFAT", (ftnlen)6); return 0; } /* Note: the following two tests MUST be performed in the order */ /* in which they appear, since in some environments files that do */ /* not exist are considered to be open. */ if (! exist) { setmsg_("The kernel file '#' does not exist.", (ftnlen)35); errch_("#", file, (ftnlen)1, file_len); sigerr_("SPICE(FILENOTFOUND)", (ftnlen)19); chkout_("GETFAT", (ftnlen)6); return 0; } /* If the file is already open, it may be a DAS file. */ if (opened) { /* At the moment, the handle manager doesn't manage DAS */ /* handles. As a result we need to treat the case of an open */ /* DAS separately. When the Handle Manager is hooked in with */ /* DAS as well as DAF, we should remove the block below. */ /* =================================================== */ /* DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS */ /* vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv */ /* This file may or may not be a DAS file. Until we */ /* have determined otherwise, we assume it is not */ /* a DAS file. */ notdas = TRUE_; ioin__1.inerr = 1; ioin__1.infilen = file_len; ioin__1.infile = file; ioin__1.inex = 0; ioin__1.inopen = 0; ioin__1.innum = &unit; ioin__1.innamed = 0; ioin__1.inname = 0; ioin__1.inacc = 0; ioin__1.inseq = 0; ioin__1.indir = 0; ioin__1.infmt = 0; ioin__1.inform = 0; ioin__1.inunf = 0; ioin__1.inrecl = 0; ioin__1.innrec = 0; ioin__1.inblank = 0; iostat = f_inqu(&ioin__1); if (iostat != 0) { setmsg_("IOSTAT error in INQUIRE statement. IOSTAT = #.", ( ftnlen)46); errint_("#", &iostat, (ftnlen)1); sigerr_("SPICE(INQUIREERROR)", (ftnlen)19); chkout_("GETFAT", (ftnlen)6); return 0; } /* Get the set of handles of open DAS files. We will */ /* translate each of these handles to the associated */ /* logical unit. If the tranlation matches the result */ /* of the inquire, this must be a DAS file and we */ /* can proceed to determine the type. */ ssizei_(&c__100, handles); dashof_(handles); which = cardi_(handles); while(which > 0) { dashlu_(&handles[(i__1 = which + 5) < 106 && 0 <= i__1 ? i__1 : s_rnge("handles", i__1, "getfat_", (ftnlen)654)], & myunit); if (unit == myunit) { number = myunit; which = 0; notdas = FALSE_; } else { --which; } } /* If we reach this point and do not have a DAS, there */ /* is no point in going on. The user has opened this */ /* file outside the SPICE system. We shall not attempt */ /* to determine its type. */ if (notdas) { setmsg_("The file '#' is already open.", (ftnlen)29); errch_("#", file, (ftnlen)1, file_len); sigerr_("SPICE(EXTERNALOPEN)", (ftnlen)19); chkout_("GETFAT", (ftnlen)6); return 0; } /* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ */ /* DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS */ /* =================================================== */ } } /* Open the file with a record length of RECL (the length of the */ /* DAF and DAS records). We assume, for now, that opening the file as */ /* a direct access file will work. */ diropn = TRUE_; /* If the file is not already open (probably the case that */ /* happens most frequently) we try opening it for direct access */ /* and see if we can locate the idword. */ if (! opened) { getlun_(&number); o__1.oerr = 1; o__1.ounit = number; o__1.ofnmlen = file_len; o__1.ofnm = file; o__1.orl = 1024; o__1.osta = "OLD"; o__1.oacc = "DIRECT"; o__1.ofm = 0; o__1.oblnk = 0; iostat = f_open(&o__1); /* If we had trouble opening the file, try opening it as a */ /* sequential file. */ if (iostat != 0) { diropn = FALSE_; o__1.oerr = 1; o__1.ounit = number; o__1.ofnmlen = file_len; o__1.ofnm = file; o__1.orl = 0; o__1.osta = "OLD"; o__1.oacc = "SEQUENTIAL"; o__1.ofm = 0; o__1.oblnk = 0; iostat = f_open(&o__1); /* If we still have problems opening the file, we don't have a */ /* clue about the file architecture and type. */ if (iostat != 0) { s_copy(arch, "?", arch_len, (ftnlen)1); s_copy(kertyp, "?", kertyp_len, (ftnlen)1); setmsg_("Attempt to open the file '#' failed. IOSTAT = #.", ( ftnlen)48); errch_("#", file, (ftnlen)1, file_len); errint_("#", &iostat, (ftnlen)1); sigerr_("SPICE(FILEOPENFAILED)", (ftnlen)21); chkout_("GETFAT", (ftnlen)6); return 0; } } } /* We opened the file successfully, so let's try to read from the */ /* file. We need to be sure to use the correct form of the read */ /* statement, depending on whether the file was opened with direct */ /* acces or sequential access. */ if (diropn) { io___19.ciunit = number; iostat = s_rdue(&io___19); if (iostat != 0) { goto L100001; } iostat = do_uio(&c__1, tmpwrd, (ftnlen)12); if (iostat != 0) { goto L100001; } iostat = e_rdue(); L100001: /* If we couldn't read from the file as a direct access file with */ /* a fixed record length, then try to open the file as a */ /* sequential file and read from it. */ if (iostat != 0) { if (opened) { /* Something has gone wrong here. The file was opened */ /* as either a DAF or DAS prior to the call to GETFAT. */ /* We retrieved the unit number maintained by the */ /* underlying binary file management system, but we */ /* were unable to read the file as direct access. */ /* There's nothing we can do but abandon our quest to */ /* determine the type of the file. */ setmsg_("The file '#' is opened as a binary SPICE kernel. B" "ut it cannot be read using a direct access read. The" " value of IOSTAT returned by the attempted READ is #" ". ", (ftnlen)157); errch_("#", file, (ftnlen)1, file_len); errint_("#", &iostat, (ftnlen)1); sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21); chkout_("GETFAT", (ftnlen)6); return 0; } /* If we reach this point, the file was opened locally */ /* as a direct access file. We could not read it that */ /* way, so we'll try using a sequential read. However, */ /* we first need to close the file and then reopen it */ /* for sequential reading. */ cl__1.cerr = 0; cl__1.cunit = number; cl__1.csta = 0; f_clos(&cl__1); o__1.oerr = 1; o__1.ounit = number; o__1.ofnmlen = file_len; o__1.ofnm = file; o__1.orl = 0; o__1.osta = "OLD"; o__1.oacc = "SEQUENTIAL"; o__1.ofm = 0; o__1.oblnk = 0; iostat = f_open(&o__1); /* If we could not open the file, we don't have a clue about */ /* the file architecture and type. */ if (iostat != 0) { s_copy(arch, "?", arch_len, (ftnlen)1); s_copy(kertyp, "?", kertyp_len, (ftnlen)1); setmsg_("Attempt to open the file '#' failed. IOSTAT = #.", ( ftnlen)48); errch_("#", file, (ftnlen)1, file_len); errint_("#", &iostat, (ftnlen)1); sigerr_("SPICE(FILEOPENFAILED)", (ftnlen)21); chkout_("GETFAT", (ftnlen)6); return 0; } /* Try to read from the file. */ ci__1.cierr = 1; ci__1.ciend = 1; ci__1.ciunit = number; ci__1.cifmt = "(A)"; iostat = s_rsfe(&ci__1); if (iostat != 0) { goto L100002; } iostat = do_fio(&c__1, tmpwrd, (ftnlen)12); if (iostat != 0) { goto L100002; } iostat = e_rsfe(); L100002: ; } } else { ci__1.cierr = 1; ci__1.ciend = 1; ci__1.ciunit = number; ci__1.cifmt = "(A)"; iostat = s_rsfe(&ci__1); if (iostat != 0) { goto L100003; } iostat = do_fio(&c__1, tmpwrd, (ftnlen)12); if (iostat != 0) { goto L100003; } iostat = e_rsfe(); L100003: ; } /* If we had an error while reading, we don't recognize this file. */ if (iostat != 0) { s_copy(arch, "?", arch_len, (ftnlen)1); s_copy(kertyp, "?", kertyp_len, (ftnlen)1); cl__1.cerr = 0; cl__1.cunit = number; cl__1.csta = 0; f_clos(&cl__1); setmsg_("Attempt to read from file '#' failed. IOSTAT = #.", (ftnlen) 49); errch_("#", file, (ftnlen)1, file_len); errint_("#", &iostat, (ftnlen)1); sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21); chkout_("GETFAT", (ftnlen)6); return 0; } /* Close the file (if we opened it here), as we do not need it */ /* to be open any more. */ if (! opened) { cl__1.cerr = 0; cl__1.cunit = number; cl__1.csta = 0; f_clos(&cl__1); } /* At this point, we have a candidate for an ID word. To avoid */ /* difficulties with Fortran I/O and other things, we will now */ /* replace any non printing ASCII characters with blanks. */ for (i__ = 1; i__ <= 12; ++i__) { if (*(unsigned char *)&tmpwrd[i__ - 1] < 32 || *(unsigned char *)& tmpwrd[i__ - 1] > 126) { *(unsigned char *)&tmpwrd[i__ - 1] = ' '; } } /* Identify the architecture and type, if we can. */ ljust_(tmpwrd, tmpwrd, (ftnlen)12, (ftnlen)12); ucase_(tmpwrd, tmpwrd, (ftnlen)12, (ftnlen)12); nextwd_(tmpwrd, idword, tmpwrd, (ftnlen)12, (ftnlen)12, (ftnlen)12); if (s_cmp(idword, "DAFETF", (ftnlen)12, (ftnlen)6) == 0) { /* We have a DAF encoded transfer file. */ s_copy(arch, "XFR", arch_len, (ftnlen)3); s_copy(kertyp, "DAF", kertyp_len, (ftnlen)3); } else if (s_cmp(idword, "DASETF", (ftnlen)12, (ftnlen)6) == 0) { /* We have a DAS encoded transfer file. */ s_copy(arch, "XFR", arch_len, (ftnlen)3); s_copy(kertyp, "DAS", kertyp_len, (ftnlen)3); } else if (s_cmp(idword, "'NAIF/DAF'", (ftnlen)10, (ftnlen)10) == 0) { /* We have an old DAF decimal text file. */ s_copy(arch, "DEC", arch_len, (ftnlen)3); s_copy(kertyp, "DAF", kertyp_len, (ftnlen)3); } else if (s_cmp(idword, "NAIF/DAS", (ftnlen)8, (ftnlen)8) == 0) { /* We have a pre release DAS binary file. */ s_copy(arch, "DAS", arch_len, (ftnlen)3); s_copy(kertyp, "PRE", kertyp_len, (ftnlen)3); } else { /* Get the architecture and type from the ID word, if we can. */ idw2at_(idword, arch, kertyp, (ftnlen)8, arch_len, kertyp_len); } /* If the architecture is DAF and the type is unknown, '?', then we */ /* have either an SPK file, a CK file, or something we don't */ /* understand. Let's check it out. */ if (s_cmp(arch, "DAF", arch_len, (ftnlen)3) == 0 && s_cmp(kertyp, "?", kertyp_len, (ftnlen)1) == 0) { /* We have a DAF file and we do not know what the type is. This */ /* situation can occur for older SPK and CK files, before the ID */ /* word was used to store type information. */ /* We use Bill's (WLT'S) magic heuristics to determine the type */ /* of the file. */ /* Open the file and pass the handle to the private routine */ /* that deals with the dirty work. */ dafopr_(file, &handle, file_len); zzckspk_(&handle, kertyp, kertyp_len); dafcls_(&handle); } chkout_("GETFAT", (ftnlen)6); return 0; } /* getfat_ */
/* $Procedure SYPOPC ( Pop a value from a particular symbol ) */ /* Subroutine */ int sypopc_(char *name__, char *tabsym, integer *tabptr, char *tabval, char *value, logical *found, ftnlen name_len, ftnlen tabsym_len, ftnlen tabval_len, ftnlen value_len) { /* System generated locals */ integer i__1; /* Builtin functions */ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ integer nval, nptr, nsym; extern integer cardc_(char *, ftnlen), cardi_(integer *); extern /* Subroutine */ int chkin_(char *, ftnlen); extern integer sumai_(integer *, integer *); extern /* Subroutine */ int scardc_(integer *, char *, ftnlen), remlac_( integer *, integer *, char *, integer *, ftnlen); extern integer bsrchc_(char *, integer *, char *, ftnlen, ftnlen); extern /* Subroutine */ int 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 character */ /* 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 character symbol table. */ /* $ Detailed_Output */ /* TABSYM, */ /* TABPTR, */ /* TABVAL are the components of a character 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: */ /* BOHR --> HYDROGEN ATOM */ /* EINSTEIN --> SPECIAL RELATIVITY */ /* PHOTOELECTRIC EFFECT */ /* BROWNIAN MOTION */ /* FERMI --> NUCLEAR FISSION */ /* The call, */ /* CALL SYPOPC ( 'EINSTEIN', TABSYM, TABPTR, TABVAL, VALUE, FOUND ) */ /* modifies the contents of the symbol table to be: */ /* BOHR --> HYDROGEN ATOM */ /* EINSTEIN --> PHOTOELECTRIC EFFECT */ /* BROWNIAN MOTION */ /* FERMI --> NUCLEAR FISSION */ /* FOUND is TRUE, and VALUE is 'SPECIAL RELATIVITY'. */ /* The next call, */ /* CALL SYPOPC ( 'FERMI', TABSYM, TABPTR, TABVAL, VALUE, FOUND ) */ /* modifies the contents of the symbol table to be: */ /* BOHR --> HYDROGEN ATOM */ /* EINSTEIN --> SPECIAL RELATIVITY */ /* PHOTOELECTRIC EFFECT */ /* BROWNIAN MOTION */ /* FOUND is TRUE, and VALUE is 'NUCLEAR FISSION'. Note that because */ /* "FERMI" 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_("SYPOPC", (ftnlen)6); } /* How many symbols to start with? */ nsym = cardc_(tabsym, tabsym_len); nptr = cardi_(tabptr); nval = cardc_(tabval, tabval_len); /* 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; s_copy(value, tabval + (locval + 5) * tabval_len, value_len, tabval_len); remlac_(&c__1, &locval, tabval + tabval_len * 6, &nval, tabval_len); scardc_(&nval, tabval, tabval_len); /* 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_("SYPOPC", (ftnlen)6); return 0; } /* sypopc_ */
/* $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 PODONI ( Pod, offset and number, integer ) */ /* Subroutine */ int podoni_(integer *pod, integer *offset, integer *number) { extern integer cardi_(integer *); extern /* Subroutine */ int chkin_(char *, ftnlen), dcodei_(integer *, integer *), chkout_(char *, ftnlen); extern logical return_(void); /* $ Abstract */ /* Return the offset of the active group of a pod, and the number */ /* of elements in the group. */ /* $ 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 Pod. */ /* OFFSET O Offset of the active group of POD. */ /* NUMBER O Number of elements in active group. */ /* $ Detailed_Input */ /* POD is a pod. */ /* $ Detailed_Output */ /* OFFSET is the offset of the first item in the active group */ /* of POD. That is, POD(OFFSET + 1) is the first element */ /* of the active group. */ /* NUMBER is the number of items in the active group of POD. */ /* That is, the active group is located in POD(OFFSET+1), */ /* POD(OFFSET+2), ..., POD(OFFSET+NUMBER). */ /* $ Parameters */ /* None. */ /* $ Exceptions */ /* 1) If the active group of the pod contains no elements, */ /* NUMBER is zero. */ /* $ Files */ /* None. */ /* $ Particulars */ /* PODBE (begin and end) and PODON (offset and number) provide */ /* equivalent ways to access the elements of the active group */ /* of a pod. Note that there is no way to access any group other */ /* than the active group. */ /* $ Examples */ /* PODBE is typically used to process the elements of the active */ /* group of a pod one at a time, e.g., */ /* CALL PODBEI ( POD, BEGIN, END ) */ /* DO I = BEGIN, END */ /* CALL PROCESS ( ..., POD(I), ... ) */ /* END DO */ /* Note that if the elements are to be correlated with the elements */ /* of other arrays, PODON may be more convenient: */ /* CALL PODONI ( POD, OFFSET, N ) */ /* DO I = 1, N */ /* CALL PROCESS ( ..., POD(OFFSET+I), ARRAY(I), ... ) */ /* END DO */ /* PODON is also more convenient when the group is to be passed */ /* to a subprogram as an array: */ /* CALL SUBPROG ( ..., N, POD(OFFSET+1), ... ) */ /* For example, to sort the elements of the active group of */ /* a pod, */ /* CALL PODONI ( POD, OFFSET, N ) */ /* CALL SHELLI ( N, POD( OFFSET+1 ) ) */ /* $ 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 */ /* Standard SPICE error handling. */ if (return_()) { return 0; } else { chkin_("PODONI", (ftnlen)6); } /* The offset of the active group can be recovered directly from */ /* the control area of the pod. The cardinality of the pod always */ /* indicates the end of the active group. */ dcodei_(&pod[3], offset); *number = cardi_(pod) - *offset; chkout_("PODONI", (ftnlen)6); return 0; } /* podoni_ */
/* $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__ */