/* $Procedure SYPOPD ( Pop a value from a particular symbol ) */ /* Subroutine */ int sypopd_(char *name__, char *tabsym, integer *tabptr, doublereal *tabval, doublereal *value, logical *found, ftnlen name_len, ftnlen tabsym_len) { /* System generated locals */ integer i__1; /* Local variables */ integer nval, nptr, nsym; extern integer cardc_(char *, ftnlen), cardd_(doublereal *), cardi_( integer *); extern /* Subroutine */ int chkin_(char *, ftnlen); extern integer sumai_(integer *, integer *); extern /* Subroutine */ int scardc_(integer *, char *, ftnlen), scardd_( integer *, doublereal *), remlac_(integer *, integer *, char *, integer *, ftnlen); extern integer bsrchc_(char *, integer *, char *, ftnlen, ftnlen); extern /* Subroutine */ int remlad_(integer *, integer *, doublereal *, integer *), scardi_(integer *, integer *), remlai_(integer *, integer *, integer *, integer *); integer locval; extern /* Subroutine */ int chkout_(char *, ftnlen); integer locsym; extern logical return_(void); /* $ Abstract */ /* Pop a value associated with a particular symbol in a double */ /* precision symbol table. The first value associated with the */ /* symbol is removed, and subsequent values are moved forward. */ /* $ Disclaimer */ /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */ /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */ /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */ /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */ /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */ /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */ /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */ /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */ /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */ /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */ /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */ /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */ /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */ /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */ /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */ /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */ /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */ /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */ /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */ /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */ /* $ Required_Reading */ /* SYMBOLS */ /* $ Keywords */ /* SYMBOLS */ /* $ Declarations */ /* $ Brief_I/O */ /* VARIABLE I/O DESCRIPTION */ /* -------- --- -------------------------------------------------- */ /* NAME I Name of the symbol whose associated value is to be */ /* popped. */ /* TABSYM, */ /* TABPTR, */ /* TABVAL I/O Components of the symbol table. */ /* VALUE O Value that was popped. */ /* FOUND O True if the symbol exists, false if it does not. */ /* $ Detailed_Input */ /* NAME is the name of the symbol whose associated value is to */ /* be popped. If NAME is not in the symbol table, FOUND is */ /* false. */ /* TABSYM, */ /* TABPTR, */ /* TABVAL are the components of a double precision symbol table. */ /* $ Detailed_Output */ /* TABSYM, */ /* TABPTR, */ /* TABVAL are the components of a double precision symbol table. */ /* The value is removed from the symbol table, and the */ /* remaining values associated with the symbol are moved */ /* forward in the value table. If no other values are */ /* associated with the symbol, the symbol is removed from */ /* the symbol table. */ /* VALUE is the value that was popped. This value was the first */ /* value in the symbol table that was associated with the */ /* symbol NAME. */ /* FOUND is true if NAME is in the symbol table, otherwise */ /* it is false. */ /* $ Parameters */ /* None. */ /* $ Files */ /* None. */ /* $ Exceptions */ /* None. */ /* $ Particulars */ /* If there are no remaining values associated with the symbol */ /* after VALUE has been popped, the symbol is removed from the */ /* symbol table. */ /* $ Examples */ /* The contents of the symbol table are: */ /* BODY4_POLE_RA --> 3.17681D2 */ /* 1.08D-1 */ /* 0.0D0 */ /* DELTA_T_A --> 3.2184D1 */ /* K --> 1.657D-3 */ /* MEAN_ANOM --> 6.239996D0 */ /* 1.99096871D-7 */ /* ORBIT_ECC --> 1.671D-2 */ /* The call, */ /* CALL SYPOPD ( 'MEAN_ANOM', TABSYM, TABPTR, TABVAL, VALUE, FOUND ) */ /* modifies the contents of the symbol table to be: */ /* BODY4_POLE_RA --> 3.17681D2 */ /* 1.08D-1 */ /* 0.0D0C */ /* DELTA_T_A --> 3.2184D1 */ /* K --> 1.657D-3 */ /* MEAN_ANOM --> 1.99096871D-7 */ /* ORBIT_ECC --> 1.671D-2 */ /* FOUND is TRUE, and VALUE is 6.239996D0. */ /* The next call, */ /* CALL SYPOPD ( 'K', TABSYM, TABPTR, TABVAL, VALUE, FOUND ) */ /* modifies the contents of the symbol table to be: */ /* BODY4_POLE_RA --> 3.17681D2 */ /* 1.08D-1 */ /* 0.0D0C */ /* DELTA_T_A --> 3.2184D1 */ /* MEAN_ANOM --> 1.99096871D-7 */ /* ORBIT_ECC --> 1.671D-2 */ /* FOUND is TRUE, and VALUE is 1.657D-3. Note that because */ /* "K" had only one value associated with it, it was removed */ /* from the symbol table. */ /* $ Restrictions */ /* None. */ /* $ Literature_References */ /* None. */ /* $ Author_and_Institution */ /* H.A. Neilan (JPL) */ /* I.M. Underwood (JPL) */ /* $ Version */ /* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */ /* Comment section for permuted index source lines was added */ /* following the header. */ /* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) (HAN) */ /* -& */ /* $ Index_Entries */ /* pop a value from a particular symbol */ /* -& */ /* SPICELIB functions */ /* Local variables */ /* Standard SPICE error handling. */ if (return_()) { return 0; } else { chkin_("SYPOPD", (ftnlen)6); } /* How many symbols to start with? */ nsym = cardc_(tabsym, tabsym_len); nptr = cardi_(tabptr); nval = cardd_(tabval); /* Is this symbol even in the table? */ locsym = bsrchc_(name__, &nsym, tabsym + tabsym_len * 6, name_len, tabsym_len); /* If it's not in the table, it's definitely a problem. */ if (locsym == 0) { *found = FALSE_; /* If it is in the table, we can proceed without fear of overflow. */ } else { *found = TRUE_; /* Begin by saving and removing the initial value for this */ /* symbol from the value table. */ i__1 = locsym - 1; locval = sumai_(&tabptr[6], &i__1) + 1; *value = tabval[locval + 5]; remlad_(&c__1, &locval, &tabval[6], &nval); scardd_(&nval, tabval); /* If this was the sole value for the symbol, remove the */ /* symbol from the name and pointer tables. Otherwise just */ /* decrement the dimension. */ if (tabptr[locsym + 5] == 1) { remlac_(&c__1, &locsym, tabsym + tabsym_len * 6, &nsym, tabsym_len); scardc_(&nsym, tabsym, tabsym_len); remlai_(&c__1, &locsym, &tabptr[6], &nptr); scardi_(&nptr, tabptr); } else { --tabptr[locsym + 5]; } } chkout_("SYPOPD", (ftnlen)6); return 0; } /* sypopd_ */
/* $Procedure DASSDR ( DAS, segregate data records ) */ /* Subroutine */ int dassdr_(integer *handle) { /* Initialized data */ static integer next[3] = { 2,3,1 }; static integer prev[3] = { 3,1,2 }; /* System generated locals */ integer i__1, i__2, i__3; /* Builtin functions */ integer s_rnge(char *, integer, char *, integer); /* Local variables */ integer base; char crec[1024]; doublereal drec[128]; integer free, irec[256], lrec, dest; logical more; integer unit, type__, i__, j, n; extern /* Subroutine */ int chkin_(char *, ftnlen); integer ncomc; extern /* Subroutine */ int maxai_(integer *, integer *, integer *, integer *); char savec[1024]; doublereal saved[128]; integer recno, savei[256]; extern integer sumai_(integer *, integer *); integer ncomr, total, lword, count[4], ltype, start; extern logical failed_(void); extern /* Subroutine */ int dasadi_(integer *, integer *, integer *), cleari_(integer *, integer *); integer drbase; extern /* Subroutine */ int dasioc_(char *, integer *, integer *, char *, ftnlen, ftnlen), dasiod_(char *, integer *, integer *, doublereal *, ftnlen), dasllc_(integer *), dasrdi_(integer *, integer *, integer *, integer *), dashfs_(integer *, integer *, integer *, integer *, integer *, integer *, integer *, integer *, integer *), dasudi_(integer *, integer *, integer *, integer *); integer minadr, maxadr, scrhan, lastla[3]; extern /* Subroutine */ int dassih_(integer *, char *, ftnlen), dashlu_( integer *, integer *), daswbr_(integer *), dasrri_(integer *, integer *, integer *, integer *, integer *); integer offset; extern /* Subroutine */ int dasioi_(char *, integer *, integer *, integer *, ftnlen); integer lastrc[3]; extern /* Subroutine */ int dasops_(integer *), dasufs_(integer *, integer *, integer *, integer *, integer *, integer *, integer *, integer *, integer *), chkout_(char *, ftnlen); integer lastwd[3], nresvc; extern logical return_(void); integer nresvr, savtyp, prvtyp, loc, pos; /* $ Abstract */ /* Segregate the data records in a DAS file into clusters, using */ /* one cluster per data type present in the file. */ /* $ Disclaimer */ /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */ /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */ /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */ /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */ /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */ /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */ /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */ /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */ /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */ /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */ /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */ /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */ /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */ /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */ /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */ /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */ /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */ /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */ /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */ /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */ /* $ Required_Reading */ /* DAS */ /* $ Keywords */ /* DAS */ /* FILES */ /* ORDER */ /* SORT */ /* $ Declarations */ /* $ Brief_I/O */ /* Variable I/O Description */ /* -------- --- -------------------------------------------------- */ /* HANDLE I DAS file handle. */ /* $ Detailed_Input */ /* HANDLE is a file handle of a DAS file opened for writing. */ /* $ Detailed_Output */ /* None. See $Particulars for a description of the effect of this */ /* routine. */ /* $ Parameters */ /* None. */ /* $ Exceptions */ /* 1) If the input file handle is invalid, the error will be */ /* diagnosed by routines called by this routine. */ /* 2) If a Fortran read attempted by this routine fails, the */ /* error will be diagnosed by routines called by this routine. */ /* The state of the DAS file undergoing re-ordering will be */ /* indeterminate. */ /* 3) If a Fortran write attempted by this routine fails, the */ /* error will be diagnosed by routines called by this routine. */ /* The state of the DAS file undergoing re-ordering will be */ /* indeterminate. */ /* 4) If any other I/O error occurs during the re-arrangement of */ /* the records in the indicated DAS file, the error will be */ /* diagnosed by routines called by this routine. */ /* $ Files */ /* See the description of the argument HANDLE in $Detailed_Input. */ /* $ Particulars */ /* Normally, there should be no need for routines outside of */ /* SPICELIB to call this routine. */ /* The effect of this routine is to re-arrange the data records */ /* in a DAS file so that the file contains a single cluster for */ /* each data type present in the file: in the general case, there */ /* will be a single cluster of each of the integer, double */ /* precision, and character data types. */ /* The relative order of data records of a given type is not */ /* affected by this re-ordering. After the re-ordering, the DAS */ /* file contains a single directory record that has one descriptor */ /* for each cluster. After that point, the order in the file of the */ /* sets of data records of the various data types will be: */ /* +-------+ */ /* | CHAR | */ /* +-------+ */ /* | DP | */ /* +-------+ */ /* | INT | */ /* +-------+ */ /* Files that contain multiple directory records will have all but */ /* the first directory record moved to the end of the file when the */ /* re-ordering is complete. These records are not visible to the */ /* DAS system and will be overwritten if data is subsequently added */ /* to the DAS file. */ /* The purpose of segregating a DAS file's data records into three */ /* clusters is to make read access more efficient: when a DAS file */ /* contains a single directory with at most three cluster type */ /* descriptors, mapping logical to physical addresses can be done */ /* in constant time. */ /* $ Examples */ /* 1) Segregate data records in a DAS file designated by */ /* HANDLE: */ /* CALL DASSDR ( HANDLE ) */ /* $ Restrictions */ /* None. */ /* $ Literature_References */ /* None. */ /* $ Author_and_Institution */ /* K.R. Gehringer (JPL) */ /* N.J. Bachman (JPL) */ /* W.L. Taber (JPL) */ /* $ Version */ /* - SPICELIB Version 2.0.1 19-DEC-1995 (NJB) */ /* Corrected title of permuted index entry section. */ /* - EKLIB Version 2.0.0, 17-NOV-1993 (KRG) */ /* Added test of FAILED after each DAS call, or sequence of calls, */ /* which returns immediately if FAILED is true. This fixes a bug */ /* where DASOPS signals an error and then DASSDR has a */ /* segmentation fault. */ /* Removed references to specific DAS file open routines in the */ /* $ Detailed_Input section of the header. This was done in order */ /* to minimize documentation changes if the DAS open routines ever */ /* change. */ /* - EKLIB Version 1.2.0, 07-OCT-1993 (NJB) (HAN) (MJS) */ /* Bug fix: call to CLEARD replaced with call to */ /* CLEARI. */ /* - EKLIB Version 1.1.0, 08-JUL-1993 (NJB) (MJS) */ /* Bug fix: extraneous commas removed from argument lists */ /* in calls to DASADI. */ /* - SPICELIB Version 1.0.0, 11-NOV-1992 (NJB) (WLT) */ /* -& */ /* $ Index_Entries */ /* segregate the data records in a DAS file */ /* -& */ /* $ Revisions */ /* - EKLIB Version 2.0.0, 17-NOV-1993 (KRG) */ /* Added test of failed after each DAS call, or sequence of calls, */ /* which returns immediately if FAILED is true. This fixes a bug */ /* where DASOPS signals an error and then DASSDR has a */ /* segmentation fault. */ /* Removed references to specific DAS file open routines in the */ /* $ Detailed_Input section of the header. This was done in order */ /* to minimize documentation changes if the DAS open routines ever */ /* change. */ /* - EKLIB Version 1.2.0, 07-OCT-1993 (NJB) (HAN) (MJS) */ /* Bug fix: call to CLEARD replaced with call to */ /* CLEARI. */ /* - EKLIB Version 1.1.0, 08-JUL-1993 (NJB) */ /* Bug fix: extraneous commas removed from argument lists */ /* in calls to DASADI. This bug had no visible effect on */ /* VAX and Sun systems, but generated a compile error under */ /* Lahey Fortran. */ /* -& */ /* SPICELIB functions */ /* Local parameters */ /* Data type parameters */ /* Directory pointer locations (backward and forward): */ /* Directory address range location base */ /* Location of first type descriptor */ /* Local variables */ /* Saved variables */ /* NEXT and PREV map the DAS data type codes to their */ /* successors and predecessors, respectively. */ /* Initial values */ /* Standard SPICE error handling. */ if (return_()) { return 0; } else { chkin_("DASSDR", (ftnlen)6); } /* Before starting, make sure that this DAS file is open for */ /* writing. */ dassih_(handle, "WRITE", (ftnlen)5); /* Get the logical unit for this file. */ dashlu_(handle, &unit); if (failed_()) { chkout_("DASSDR", (ftnlen)6); return 0; } /* Write out any buffered records that belong to the file. */ daswbr_(handle); if (failed_()) { chkout_("DASSDR", (ftnlen)6); return 0; } /* We're going to re-order the physical records in the DAS file, */ /* starting with the first record after the first directory. */ /* The other directory records are moved to the end of the file */ /* as a result of the re-ordering. */ /* The re-ordering algorithm is based on that used in the REORDx */ /* routines. To use this algorithm, we'll build an order vector */ /* for the records to be ordered; we'll construct this order vector */ /* in a scratch DAS file. First, we'll traverse the directories */ /* to build up a sort of inverse order vector that tells us the */ /* final destination and data type of each data record; from this */ /* inverse vector we can easily build a true order vector. The */ /* cycles of the true order vector can be traversed without */ /* repetitive searching, and with a minimum of assignment of the */ /* contents of data records to temporary variables. */ /* Allocate a scratch DAS file to keep our vectors in. */ dasops_(&scrhan); if (failed_()) { chkout_("DASSDR", (ftnlen)6); return 0; } /* Now build up our `inverse order vector'. This array is an */ /* inverse order vector only in loose sense: it actually consists */ /* of an integer array that contains a sequence of pairs of integers, */ /* the first of which indicates a data type, and the second of which */ /* is an ordinal number. There is one pair for each data record in */ /* the file. The ordinal number gives the ordinal position of the */ /* record described by the number pair, relative to the other records */ /* of the same type. Directory records are considered to have type */ /* `directory', which is represented by the code DIR. */ /* We also must maintain a count of records of each type. */ cleari_(&c__4, count); /* Get the file summary for the DAS file to be segregated. */ dashfs_(handle, &nresvr, &nresvc, &ncomr, &ncomc, &free, lastla, lastrc, lastwd); if (failed_()) { chkout_("DASSDR", (ftnlen)6); return 0; } /* Find the record and word positions LREC and LWORD of the last */ /* descriptor in the file, and also find the type of the descriptor */ /* LTYPE. */ maxai_(lastrc, &c__3, &lrec, &loc); lword = 0; for (i__ = 1; i__ <= 3; ++i__) { if (lastrc[(i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("lastrc", i__1, "dassdr_", (ftnlen)451)] == lrec && lastwd[(i__2 = i__ - 1) < 3 && 0 <= i__2 ? i__2 : s_rnge("lastwd", i__2, "dassd" "r_", (ftnlen)451)] > lword) { lword = lastwd[(i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge( "lastwd", i__1, "dassdr_", (ftnlen)454)]; ltype = i__; } } /* The first directory starts after the last comment record. */ recno = nresvr + ncomr + 2; while(recno <= lrec && recno > 0) { /* Read the directory record. */ dasrri_(handle, &recno, &c__1, &c__256, irec); if (failed_()) { chkout_("DASSDR", (ftnlen)6); return 0; } /* Increment the directory count. */ ++count[3]; /* Add the data type (`directory') and count (1) of the current */ /* record to the inverse order vector. */ dasadi_(&scrhan, &c__1, &c__4); dasadi_(&scrhan, &c__1, &count[3]); if (failed_()) { chkout_("DASSDR", (ftnlen)6); return 0; } /* Set up our `finite state machine' that tells us the data */ /* types of the records described by the last read directory. */ type__ = irec[8]; prvtyp = prev[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge( "prev", i__1, "dassdr_", (ftnlen)498)]; /* Now traverse the directory and update the inverse order */ /* vector based on the descriptors we find. */ more = TRUE_; i__ = 10; while(more) { /* Obtain the count for the current descriptor. */ n = (i__2 = irec[(i__1 = i__ - 1) < 256 && 0 <= i__1 ? i__1 : s_rnge("irec", i__1, "dassdr_", (ftnlen)512)], abs(i__2)); /* Update our inverse order vector to describe the positions */ /* of the N records described by the current descriptor. */ i__1 = n; for (j = 1; j <= i__1; ++j) { dasadi_(&scrhan, &c__1, &type__); i__3 = count[(i__2 = type__ - 1) < 4 && 0 <= i__2 ? i__2 : s_rnge("count", i__2, "dassdr_", (ftnlen)521)] + j; dasadi_(&scrhan, &c__1, &i__3); if (failed_()) { chkout_("DASSDR", (ftnlen)6); return 0; } } /* Adjust the count of records of data type TYPE. */ count[(i__1 = type__ - 1) < 4 && 0 <= i__1 ? i__1 : s_rnge("count" , i__1, "dassdr_", (ftnlen)533)] = count[(i__2 = type__ - 1) < 4 && 0 <= i__2 ? i__2 : s_rnge("count", i__2, "dass" "dr_", (ftnlen)533)] + n; /* Find the next type. */ ++i__; if (i__ > 256 || recno == lrec && i__ > lword) { more = FALSE_; } else { if (irec[(i__1 = i__ - 1) < 256 && 0 <= i__1 ? i__1 : s_rnge( "irec", i__1, "dassdr_", (ftnlen)547)] > 0) { type__ = next[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("next", i__1, "dassdr_", (ftnlen)548)]; } else if (irec[(i__1 = i__ - 1) < 256 && 0 <= i__1 ? i__1 : s_rnge("irec", i__1, "dassdr_", (ftnlen)550)] < 0) { type__ = prev[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("prev", i__1, "dassdr_", (ftnlen)551)]; } else { more = FALSE_; } } } /* The forward pointer in this directory tells us where the */ /* next directory record is. When there are no more directory */ /* records, this pointer will be zero. */ recno = irec[1]; } /* At this point, the inverse order vector is set up. The array */ /* COUNT contains counts of the number of records of each type we've */ /* seen. Set TOTAL to the total number of records that we've going */ /* to permute. */ total = sumai_(count, &c__4); /* The next step is to build a true order vector. Let BASE be */ /* the base address for the order vector; this address is the */ /* last logical address of the inverse order vector. */ base = total << 1; /* We'll store the actual order vector in locations BASE + 1 */ /* through BASE + TOTAL. In addition, we'll build a parallel array */ /* that contains, for each element of the order vector, the type of */ /* data corresponding to that element. This type vector will */ /* reside in locations BASE + TOTAL + 1 through BASE + 2*TOTAL. */ /* Before setting the values of the order vector and its parallel */ /* type vector, we'll allocate space in the scratch DAS file by */ /* zeroing out the locations we plan to use. After this, locations */ /* BASE+1 through BASE + 2*TOTAL can be written to in random access */ /* fashion using DASUDI. */ i__1 = total << 1; for (i__ = 1; i__ <= i__1; ++i__) { dasadi_(&scrhan, &c__1, &c__0); } if (failed_()) { chkout_("DASSDR", (ftnlen)6); return 0; } /* We note that the way to construct the inverse of a permutation */ /* SIGMA in a single loop is suggested by the relation */ /* -1 */ /* SIGMA ( SIGMA(I) ) = I */ /* We'll use this method. In our case, our order vector plays */ /* the role of */ /* -1 */ /* SIGMA */ /* and the `inverse order vector' plays the role of SIGMA. We'll */ /* exclude the first directory from the order vector, since it's */ /* an exception: we wish to reserve this record. Since the first */ /* element of the order vector (logically) contains the index 1, we */ /* can ignore it. */ i__1 = total; for (i__ = 2; i__ <= i__1; ++i__) { i__2 = (i__ << 1) - 1; i__3 = (i__ << 1) - 1; dasrdi_(&scrhan, &i__2, &i__3, &type__); i__2 = i__ << 1; i__3 = i__ << 1; dasrdi_(&scrhan, &i__2, &i__3, &dest); if (failed_()) { chkout_("DASSDR", (ftnlen)6); return 0; } /* Set DEST to the destination location, measured as an offset */ /* from the last comment record, of the Ith record by adding */ /* on the count of the predecessors of the block of records of */ /* TYPE. */ for (j = 1; j <= 3; ++j) { if (type__ > j) { dest += count[(i__2 = j - 1) < 4 && 0 <= i__2 ? i__2 : s_rnge( "count", i__2, "dassdr_", (ftnlen)648)]; } } /* The destination offset of each record should be incremented to */ /* allow room for the first directory record. However, we don't */ /* need to do this for directory records; they'll already have */ /* this offset accounted for. */ if (type__ != 4) { ++dest; } /* The value of element DEST of the order vector is I. */ /* Write this value to location BASE + DEST. */ i__2 = base + dest; i__3 = base + dest; dasudi_(&scrhan, &i__2, &i__3, &i__); /* We want the ith element of the order vector to give us the */ /* number of the record to move to position i (offset from the */ /* last comment record), but we want the corresponding element */ /* of the type array to give us the type of the record currently */ /* occupying position i. */ i__2 = base + i__ + total; i__3 = base + i__ + total; dasudi_(&scrhan, &i__2, &i__3, &type__); if (failed_()) { chkout_("DASSDR", (ftnlen)6); return 0; } } /* Ok, here's what we've got in the scratch file that's still of */ /* interest: */ /* -- In integer logical addresses BASE + 1 : BASE + TOTAL, */ /* we have an order vector. The Ith element of this */ /* vector indicates the record that should be moved to */ /* location DRBASE + I in the DAS file we're re-ordering, */ /* where DRBASE is the base address of the data records */ /* (the first directory record follows the record having this */ /* index). */ /* -- In integer logical addresses BASE + TOTAL + 1 : BASE + */ /* 2*TOTAL, we have data type indicators for the records to */ /* be re-ordered. The type for the Ith record in the file, */ /* counted from the last comment record, is located in logical */ /* address BASE + TOTAL + I. */ drbase = nresvr + ncomr + 1; /* As we traverse the order vector, we flip the sign of elements */ /* we've accessed, so that we can tell when we encounter an element */ /* of a cycle that we've already traversed. */ /* Traverse the order vector. The variable START indicates the */ /* first element to look at. Ignore the first element; it's a */ /* singleton cycle. */ start = 2; while(start < total) { /* Traverse the current cycle of the order vector. */ /* We `make a hole' in the file by saving the record in position */ /* START, then we traverse the cycle in reverse order, filling in */ /* the hole at the ith position with the record whose number is */ /* the ith element of the order vector. At the end, we deposit */ /* the saved record into the `hole' left behind by the last */ /* record we moved. */ /* We're going to read and write records to and from the DAS file */ /* directly, rather than going through the buffering system. */ /* This will allow us to avoid any untoward interactions between */ /* the buffers for different data types. */ i__1 = base + total + start; i__2 = base + total + start; dasrdi_(&scrhan, &i__1, &i__2, &savtyp); i__1 = base + start; i__2 = base + start; dasrdi_(&scrhan, &i__1, &i__2, &offset); /* Save the record at the location DRBASE + START. */ if (savtyp == 1) { i__1 = drbase + start; dasioc_("READ", &unit, &i__1, savec, (ftnlen)4, (ftnlen)1024); } else if (savtyp == 2) { i__1 = drbase + start; dasiod_("READ", &unit, &i__1, saved, (ftnlen)4); } else { i__1 = drbase + start; dasioi_("READ", &unit, &i__1, savei, (ftnlen)4); } if (failed_()) { chkout_("DASSDR", (ftnlen)6); return 0; } /* Let I be the index of the record that we are going to move */ /* data into next. I is an offset from the last comment record. */ i__ = start; while(offset != start) { /* Mark the order vector element by writing its negative */ /* back to the location it came from. */ i__1 = base + i__; i__2 = base + i__; i__3 = -offset; dasudi_(&scrhan, &i__1, &i__2, &i__3); /* Move the record at location */ /* DRBASE + OFFSET */ /* to location */ /* DRBASE + I */ /* There is no need to do anything about the corresponding */ /* elements of the type vector; we won't need them again. */ /* The read and write operations, as well as the temporary */ /* record required to perform the move, are dependent on the */ /* data type of the record to be moved. */ i__1 = base + total + offset; i__2 = base + total + offset; dasrdi_(&scrhan, &i__1, &i__2, &type__); if (failed_()) { chkout_("DASSDR", (ftnlen)6); return 0; } /* Only pick records up if we're going to put them down in */ /* a location other than their original one. */ if (i__ != offset) { if (type__ == 1) { i__1 = drbase + offset; dasioc_("READ", &unit, &i__1, crec, (ftnlen)4, (ftnlen) 1024); i__1 = drbase + i__; dasioc_("WRITE", &unit, &i__1, crec, (ftnlen)5, (ftnlen) 1024); } else if (type__ == 2) { i__1 = drbase + offset; dasiod_("READ", &unit, &i__1, drec, (ftnlen)4); i__1 = drbase + i__; dasiod_("WRITE", &unit, &i__1, drec, (ftnlen)5); } else { i__1 = drbase + offset; dasioi_("READ", &unit, &i__1, irec, (ftnlen)4); i__1 = drbase + i__; dasioi_("WRITE", &unit, &i__1, irec, (ftnlen)5); } if (failed_()) { chkout_("DASSDR", (ftnlen)6); return 0; } } /* OFFSET is the index of the next order vector element to */ /* look at. */ i__ = offset; i__1 = base + i__; i__2 = base + i__; dasrdi_(&scrhan, &i__1, &i__2, &offset); i__1 = base + i__ + total; i__2 = base + i__ + total; dasrdi_(&scrhan, &i__1, &i__2, &type__); if (failed_()) { chkout_("DASSDR", (ftnlen)6); return 0; } } /* The last value of I is the location in the cycle that element */ /* START followed. Therefore, the saved record corresponding */ /* to index START should be written to this location. */ if (savtyp == 1) { i__1 = drbase + i__; dasioc_("WRITE", &unit, &i__1, savec, (ftnlen)5, (ftnlen)1024); } else if (savtyp == 2) { i__1 = drbase + i__; dasiod_("WRITE", &unit, &i__1, saved, (ftnlen)5); } else { i__1 = drbase + i__; dasioi_("WRITE", &unit, &i__1, savei, (ftnlen)5); } /* Mark the order vector element by writing its negative */ /* back to the location it came from. */ i__1 = base + i__; i__2 = base + i__; i__3 = -start; dasudi_(&scrhan, &i__1, &i__2, &i__3); if (failed_()) { chkout_("DASSDR", (ftnlen)6); return 0; } /* Update START so that it points to the first element of a cycle */ /* of the order vector that has not yet been traversed. This will */ /* be the first positive element of the order vector in a location */ /* indexed higher than the current value of START. Note that */ /* this way of updating START guarantees that we don't have to */ /* backtrack to find an element in the next cycle. */ offset = -1; while(offset < 0 && start < total) { ++start; i__1 = base + start; i__2 = base + start; dasrdi_(&scrhan, &i__1, &i__2, &offset); if (failed_()) { chkout_("DASSDR", (ftnlen)6); return 0; } } /* At this point, START is the index of an element in the order */ /* vector that belongs to a cycle where no routine has gone */ /* before, or else START is the last index in the order vector, */ /* in which case we're done. */ } /* At this point, the records in the DAS are organized as follows: */ /* +----------------------------------+ */ /* | File record | ( 1 ) */ /* +----------------------------------+ */ /* | Reserved records | ( 0 or more ) */ /* | | */ /* +----------------------------------+ */ /* | Comment records | ( 0 or more ) */ /* | | */ /* | | */ /* +----------------------------------+ */ /* | First directory record | ( 1 ) */ /* +----------------------------------+ */ /* | Character data records | ( 0 or more ) */ /* | | */ /* +----------------------------------+ */ /* | Double precision data records | ( 0 or more ) */ /* | | */ /* +----------------------------------+ */ /* | Integer data records | ( 0 or more ) */ /* | | */ /* +----------------------------------+ */ /* | Additional directory records | ( 0 or more ) */ /* | | */ /* +----------------------------------+ */ /* Not all of the indicated components must be present; only the */ /* file record and first directory record will exist in all cases. */ /* The `additional directory records' at the end of the file serve */ /* no purpose; if more data is appended to the file, they will be */ /* overwritten. */ /* The last step in preparing the file is to fill in the first */ /* directory record with the correct information, and to update */ /* the file summary. */ recno = drbase + 1; cleari_(&c__256, irec); /* Set the logical address ranges in the directory record, for each */ /* data type. */ for (type__ = 1; type__ <= 3; ++type__) { maxadr = lastla[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge( "lastla", i__1, "dassdr_", (ftnlen)957)]; if (maxadr > 0) { minadr = 1; } else { minadr = 0; } irec[(i__1 = type__ << 1) < 256 && 0 <= i__1 ? i__1 : s_rnge("irec", i__1, "dassdr_", (ftnlen)965)] = minadr; irec[(i__1 = (type__ << 1) + 1) < 256 && 0 <= i__1 ? i__1 : s_rnge( "irec", i__1, "dassdr_", (ftnlen)966)] = maxadr; } /* Set the descriptors in the directory. Determine which type */ /* comes first: the order of priority is character, double */ /* precision, integer. */ pos = 9; for (type__ = 1; type__ <= 3; ++type__) { if (lastla[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("las" "tla", i__1, "dassdr_", (ftnlen)979)] > 0) { if (pos == 9) { /* This is the first type for which any data is present. */ /* We must enter a type code at position BEGDSC in the */ /* directory, and we must enter a count at position */ /* BEGDSC+1. */ irec[8] = type__; irec[9] = count[(i__1 = type__ - 1) < 4 && 0 <= i__1 ? i__1 : s_rnge("count", i__1, "dassdr_", (ftnlen)989)]; lastrc[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge( "lastrc", i__1, "dassdr_", (ftnlen)990)] = recno; lastwd[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge( "lastwd", i__1, "dassdr_", (ftnlen)991)] = 10; pos += 2; prvtyp = type__; } else { /* Place an appropriately signed count at location POS in */ /* the directory. */ if (type__ == next[(i__1 = prvtyp - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("next", i__1, "dassdr_", (ftnlen)1000)]) { irec[(i__1 = pos - 1) < 256 && 0 <= i__1 ? i__1 : s_rnge( "irec", i__1, "dassdr_", (ftnlen)1001)] = count[( i__2 = type__ - 1) < 4 && 0 <= i__2 ? i__2 : s_rnge("count", i__2, "dassdr_", (ftnlen)1001)]; } else { irec[(i__1 = pos - 1) < 256 && 0 <= i__1 ? i__1 : s_rnge( "irec", i__1, "dassdr_", (ftnlen)1003)] = -count[( i__2 = type__ - 1) < 4 && 0 <= i__2 ? i__2 : s_rnge("count", i__2, "dassdr_", (ftnlen)1003)]; } lastrc[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge( "lastrc", i__1, "dassdr_", (ftnlen)1006)] = recno; lastwd[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge( "lastwd", i__1, "dassdr_", (ftnlen)1007)] = pos; ++pos; prvtyp = type__; } } } /* Since we've done away with all but the first directory, the first */ /* free record is decremented by 1 less than the directory count. */ free = free - count[3] + 1; /* Write out the new directory record. Don't use the DAS buffered */ /* write mechanism; this could trash the file by dumping buffered */ /* records in the wrong places. */ dasioi_("WRITE", &unit, &recno, irec, (ftnlen)5); /* Write out the updated file summary. */ dasufs_(handle, &nresvr, &nresvc, &ncomr, &ncomc, &free, lastla, lastrc, lastwd); /* Clean up the DAS data buffers: we don't want buffered scratch */ /* file records hanging around there. Then get rid of the scratch */ /* file. */ daswbr_(&scrhan); dasllc_(&scrhan); chkout_("DASSDR", (ftnlen)6); return 0; } /* dassdr_ */
/* $Procedure SYTRNI (Transpose two values associated with a symbol) */ /* Subroutine */ int sytrni_(char *name__, integer *i__, integer *j, char * tabsym, integer *tabptr, integer *tabval, ftnlen name_len, ftnlen tabsym_len) { /* System generated locals */ integer i__1; /* Local variables */ integer nsym; extern integer cardc_(char *, ftnlen); integer n; extern /* Subroutine */ int chkin_(char *, ftnlen); extern integer sumai_(integer *, integer *); extern /* Subroutine */ int swapi_(integer *, integer *); extern integer bsrchc_(char *, integer *, char *, ftnlen, ftnlen); integer locval; extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *, ftnlen); integer locsym; extern logical return_(void); /* $ Abstract */ /* Transpose two values associated with a particular symbol in an */ /* integer symbol table. */ /* $ 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 values are to */ /* be transposed. */ /* I I Index of the first associated value to be */ /* transposed. */ /* J I Index of the second associated value to be */ /* transposed. */ /* TABSYM, */ /* TABPTR, */ /* TABVAL I/O Components of the symbol table. */ /* $ Detailed_Input */ /* NAME is the name of the symbol whose associated values are */ /* to be transposed. If NAME is not in the symbol table, */ /* the symbol tables are not modified. */ /* I is the index of the first associated value to be */ /* transposed. */ /* J is the index of the second associated value to be */ /* transposed. */ /* TABSYM, */ /* TABPTR, */ /* TABVAL are components of the integer symbol table. */ /* $ Detailed_Output */ /* TABSYM, */ /* TABPTR, */ /* TABVAL are components of the integer symbol table. */ /* If the symbol NAME is not in the symbol table */ /* the symbol tables are not modified. Otherwise, */ /* the values that I and J refer to are transposed */ /* in the value table. */ /* $ Parameters */ /* None. */ /* $ Files */ /* None. */ /* $ Exceptions */ /* 1) If I < 1, J < 1, I > the dimension of NAME, or J > the */ /* dimension of NAME, the error SPICE(INVALIDINDEX) is signaled. */ /* 2) If NAME is not in the symbol table, the symbol tables are not */ /* modified. */ /* $ Particulars */ /* None. */ /* $ Examples */ /* The contents of the symbol table are: */ /* books --> 5 */ /* erasers --> 6 */ /* pencils --> 12 */ /* 18 */ /* 24 */ /* pens --> 10 */ /* 20 */ /* 30 */ /* 40 */ /* The call, */ /* CALL SYTRNI ( 'pens', 2, 3, TABSYM, TABPTR, TABVAL ) */ /* modifies the contents of the symbol table to be: */ /* books --> 5 */ /* erasers --> 6 */ /* pencils --> 12 */ /* 18 */ /* 24 */ /* pens --> 10 */ /* 30 */ /* 20 */ /* 40 */ /* The next call, */ /* CALL SYTRNI ( 'pencils', 2, 4, TABSYM, TABPTR, TABVAL ) */ /* causes the error SPICE(INVALIDINDEX) to be signaled. */ /* $ Restrictions */ /* None. */ /* $ Literature_References */ /* None. */ /* $ Author_and_Institution */ /* N.J. Bachman (JPL) */ /* H.A. Neilan (JPL) */ /* I.M. Underwood (JPL) */ /* $ Version */ /* - SPICELIB Version 1.1.0, 09-SEP-2005 (NJB) */ /* Updated so no "exchange" occurs if I equals J. */ /* - 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 */ /* transpose two values associated with a symbol */ /* -& */ /* $ Revisions */ /* - SPICELIB Version 1.1.0, 09-SEP-2005 (NJB) */ /* Updated so no "exchange" occurs if I equals J. */ /* - Beta Version 2.0.0, 16-JAN-1989 (HAN) */ /* If one of the indices of the values to be transposed is */ /* invalid, an error is signaled and the symbol table is */ /* not modified. */ /* -& */ /* SPICELIB functions */ /* Local variables */ /* Standard SPICE error handling. */ if (return_()) { return 0; } else { chkin_("SYTRNI", (ftnlen)6); } /* How many symbols? */ nsym = cardc_(tabsym, tabsym_len); /* Is this symbol even in the table? */ locsym = bsrchc_(name__, &nsym, tabsym + tabsym_len * 6, name_len, tabsym_len); if (locsym > 0) { /* Are there enough values associated with the symbol? */ n = tabptr[locsym + 5]; /* Are the indices valid? */ if (*i__ >= 1 && *i__ <= n && *j >= 1 && *j <= n) { /* Exchange the values in place. */ if (*i__ != *j) { i__1 = locsym - 1; locval = sumai_(&tabptr[6], &i__1) + 1; swapi_(&tabval[locval + *i__ + 4], &tabval[locval + *j + 4]); } } else { setmsg_("The first index was *. The second index was *.", (ftnlen) 46); errint_("*", i__, (ftnlen)1); errint_("*", j, (ftnlen)1); sigerr_("SPICE(INVALIDINDEX)", (ftnlen)19); } } chkout_("SYTRNI", (ftnlen)6); return 0; } /* sytrni_ */
/* $Procedure SYNTHI ( Return the Nth component of a symbol ) */ /* Subroutine */ int synthi_(char *name__, integer *nth, char *tabsym, integer *tabptr, integer *tabval, integer *value, logical *found, ftnlen name_len, ftnlen tabsym_len) { /* System generated locals */ integer i__1; /* Local variables */ integer nsym; extern integer cardc_(char *, ftnlen); extern /* Subroutine */ int chkin_(char *, ftnlen); extern integer sumai_(integer *, integer *), bsrchc_(char *, integer *, char *, ftnlen, ftnlen); integer locval; extern /* Subroutine */ int chkout_(char *, ftnlen); integer locsym; extern logical return_(void); /* $ Abstract */ /* Return the Nth component of a particular symbol in an integer */ /* symbol table. */ /* $ 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 Nth component is to be */ /* returned. */ /* NTH I Index of the value to be returned. */ /* TABSYM, */ /* TABPTR, */ /* TABVAL I Components of the symbol table. */ /* VALUE O Nth value associated with the symbol. */ /* FOUND O True if the Nth value of the symbol exists, false */ /* if it does not. */ /* $ Detailed_Input */ /* NAME is the name of the symbol whose Nth component is to be */ /* returned. If NAME is not in the symbol table, FOUND is */ /* false. */ /* NTH is the index of the component to be returned. If the */ /* value of NTH is out of range ( NTH < 1 or NTH is */ /* greater than the dimension of the symbol ) FOUND is */ /* false. */ /* TABSYM, */ /* TABPTR, */ /* TABVAL are the components of an integer symbol table. */ /* The symbol table is not modified by this subroutine. */ /* $ Detailed_Output */ /* VALUES is the NTH component of the symbol NAME. */ /* FOUND is true if NAME is in the symbol table and the NTH */ /* component of NAME exists. Otherwise FOUND is false. */ /* $ Parameters */ /* None. */ /* $ Files */ /* None. */ /* $ Exceptions */ /* None. */ /* $ Particulars */ /* Two conditions will cause the value of FOUND to be false: */ /* 1) The symbol NAME is not in the symbol table. */ /* 2) NTH is out of range ( NTH < 1 or NTH is greater than the */ /* dimension of the symbol ). */ /* $ Examples */ /* The contents of the symbol table are: */ /* books --> 5 */ /* erasers --> 6 */ /* pencils --> 12 */ /* 24 */ /* pens --> 10 */ /* 12 */ /* 24 */ /* The calls, */ /* CALL SYNTHI ( 'pens', 2, TABSYM, TABPTR, TABVAL, VALUE, */ /* . FOUND ) */ /* CALL SYNTHI ( 'pencils', 3, TABSYM, TABPTR, TABVAL, VALUE, */ /* . FOUND ) */ /* CALL SYNTHI ( 'chairs', 1, TABPTR, TABVAL, TABVAL, VALUE, */ /* . FOUND ) */ /* return the values of VALUE and FOUND corresponding to NAME and */ /* NTH: */ /* NAME NTH VALUE FOUND */ /* ---------- ----- ------- ------- */ /* pens 2 12 TRUE */ /* pencils FALSE */ /* chairs FALSE */ /* $ 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 */ /* fetch nth value associated with a symbol */ /* -& */ /* SPICELIB functions */ /* Local variables */ /* Standard SPICE error handling. */ if (return_()) { return 0; } else { chkin_("SYNTHI", (ftnlen)6); } /* How many symbols to start with? */ nsym = cardc_(tabsym, tabsym_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 the value of NTH is out of range, that's a problem too. */ } else if (*nth < 1 || *nth > tabptr[locsym + 5]) { *found = FALSE_; /* Otherwise, we can proceed without fear of error. Merely locate */ /* and return the appropriate component from the values table. */ } else { *found = TRUE_; i__1 = locsym - 1; locval = sumai_(&tabptr[6], &i__1) + *nth; *value = tabval[locval + 5]; } chkout_("SYNTHI", (ftnlen)6); return 0; } /* synthi_ */
/* $Procedure REPSUB ( Replace one substring with another ) */ /* Subroutine */ int repsub_(char *in, integer *left, integer *right, char * string, char *out, ftnlen in_len, ftnlen string_len, ftnlen out_len) { /* System generated locals */ integer i__1, i__2; /* Builtin functions */ integer i_len(char *, ftnlen); /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ integer next, i__; extern /* Subroutine */ int chkin_(char *, ftnlen); integer inlen; extern integer sumai_(integer *, integer *); integer remain; extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *, ftnlen); integer strlen, outlen; extern logical return_(void); integer end, use[3]; /* $ Abstract */ /* Replace the substring (LEFT:RIGHT) with a string of any length. */ /* $ Disclaimer */ /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */ /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */ /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */ /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */ /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */ /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */ /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */ /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */ /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */ /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */ /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */ /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */ /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */ /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */ /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */ /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */ /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */ /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */ /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */ /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */ /* $ Required_Reading */ /* None. */ /* $ Keywords */ /* ASSIGNMENT */ /* CHARACTER */ /* STRING */ /* $ Declarations */ /* $ Brief_I/O */ /* VARIABLE I/O DESCRIPTION */ /* -------- --- -------------------------------------------------- */ /* IN I Input string. */ /* LEFT, */ /* RIGHT I Ends of substring to be replaced. */ /* STRING I Replacement string. */ /* OUT O Resulting string. */ /* $ Detailed_Input */ /* IN is an arbitrary character string. */ /* LEFT, */ /* RIGHT are the ends of the substring to be replaced. */ /* Legitimate substrings satisfy the following */ /* conditions */ /* RIGHT > LEFT - 2 */ /* LEFT > 1 */ /* RIGHT < LEN(STRING) + 1 */ /* This allows users to refer to zero-length substrings */ /* (null substrings) of IN. */ /* STRING is the replacement string. Essentially, the */ /* substring (LEFT:RIGHT) is removed from the */ /* input string, and STRING is inserted at the */ /* point of removal. */ /* $ Detailed_Output */ /* OUT is the resulting string. OUT may overwrite IN. */ /* $ Parameters */ /* None. */ /* $ Exceptions */ /* 1) If RIGHT is one less than LEFT, the substring to */ /* replace will be the null substring. In this case, */ /* STRING will be inserted between IN(:RIGHT) and IN(LEFT:). */ /* 2) If LEFT is smaller than one, the error SPICE(BEFOREBEGSTR) */ /* is signalled. */ /* 3) If RIGHT is greater than the length of the input string, */ /* the error SPICE(PASTENDSTR) is signalled. */ /* 4) If RIGHT is less than LEFT-1, the error SPICE(BADSUBSTR) */ /* is signalled. */ /* 5) Whenever the output string is too small to hold the result, */ /* the result is truncated on the right. */ /* $ Files */ /* None. */ /* $ Particulars */ /* Ideally, replacement could be done with simple concatenation, */ /* OUT = IN(1:LEFT-1) // STRING // IN(RIGHT+1: ) */ /* but the Fortran 77 standard makes this illegal for strings of */ /* unknown length. */ /* $ Examples */ /* A typical use for this routine might be to replace all */ /* occurrences of one word in a string with another word. */ /* For example, the following code fragment replaces every */ /* occurrence of the word 'AND' with the word 'OR' in the */ /* character string LINE. */ /* LEFT = WDINDX ( LINE, 'AND' ) */ /* DO WHILE ( LEFT .NE. 0 ) */ /* CALL REPSUB ( LINE, LEFT, LEFT+2, 'OR', LINE ) */ /* LEFT = WDINDX ( LINE, 'AND' ) */ /* END DO */ /* This routine can also be used to insert substring between */ /* two characters. Consider the string: */ /* IN = 'The defendent,, was found innocent.' */ /* to insert ' Emelda Marcos' between the first and second commas */ /* determine the location of the pair ',,' */ /* RIGHT = POS ( IN, ',,', 1 ) */ /* LEFT = RIGHT + 1 */ /* then */ /* CALL REPSUB ( IN, LEFT, RIGHT, ' Emelda Marcos', OUT ) */ /* The output (OUT) will have the value: */ /* 'The defendent, Emelda Marcos, was found innocent.' */ /* $ Restrictions */ /* The memory used by STRING and OUT must be disjoint. The memory */ /* used by IN and OUT must be identical or disjoint. */ /* $ Literature_References */ /* None. */ /* $ Author_and_Institution */ /* W.L. Taber (JPL) */ /* I.M. Underwood (JPL) */ /* $ Version */ /* - SPICELIB Version 1.0.2, 17-JUN-1999 (WLT) */ /* Fixed example code fragment. */ /* - 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, 24-AUG-1990 (WLT) (IMU) */ /* -& */ /* $ Index_Entries */ /* replace one substring with another substring */ /* -& */ /* SPICELIB functions */ /* Local variables */ /* Standard SPICE error handling. */ if (return_()) { return 0; } else { chkin_("REPSUB", (ftnlen)6); } /* Get the lengths of all the strings involved in this transaction. */ inlen = i_len(in, in_len); strlen = i_len(string, string_len); outlen = i_len(out, out_len); /* Reject bad inputs. */ if (*left < 1) { setmsg_("REPSUB error: LEFT (#) must not be less than 1.", (ftnlen)47) ; errint_("#", left, (ftnlen)1); sigerr_("SPICE(BEFOREBEGSTR)", (ftnlen)19); chkout_("REPSUB", (ftnlen)6); return 0; } else if (*right > inlen) { setmsg_("REPSUB error: RIGHT (#) must not exceed length of IN (#).", ( ftnlen)57); errint_("#", right, (ftnlen)1); errint_("#", &inlen, (ftnlen)1); sigerr_("SPICE(PASTENDSTR)", (ftnlen)17); chkout_("REPSUB", (ftnlen)6); return 0; } else if (*right < *left - 1) { setmsg_("REPSUB error: LEFT (#) must not exceed RIGHT+1 (# + 1). ", ( ftnlen)56); errint_("#", left, (ftnlen)1); errint_("#", right, (ftnlen)1); sigerr_("SPICE(BADSUBSTR)", (ftnlen)16); chkout_("REPSUB", (ftnlen)6); return 0; } /* Consider three separate sections: */ /* 1) The front of the original string. */ /* 2) The replacement string. */ /* 3) The end of the original string. */ /* Determine how much of each section to use in the output string. */ /* REMAIN is the number of characters that will fit in the output */ /* string. */ remain = outlen; /* Computing MIN */ i__1 = remain, i__2 = *left - 1; use[0] = min(i__1,i__2); remain -= use[0]; use[1] = min(remain,strlen); remain -= use[1]; /* Computing MIN */ i__1 = remain, i__2 = inlen - *right; use[2] = min(i__1,i__2); /* Move the third section first. It gets moved back to front */ /* or front to back, depending on whether the replacement string */ /* is longer than the original substring. The main thing is to */ /* avoid overwriting characters that have yet to be moved. */ end = sumai_(use, &c__3); if (*left + strlen > *right) { next = end; for (i__ = use[2]; i__ >= 1; --i__) { i__1 = *right + i__ - 1; s_copy(out + (next - 1), in + i__1, (ftnlen)1, *right + i__ - i__1); --next; } } else { next = *left + strlen; i__1 = use[2]; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *right + i__ - 1; s_copy(out + (next - 1), in + i__2, (ftnlen)1, *right + i__ - i__2); ++next; } } /* The first two sections can be moved directly to the front of */ /* the output string. */ next = 1; i__1 = use[0]; for (i__ = 1; i__ <= i__1; ++i__) { *(unsigned char *)&out[next - 1] = *(unsigned char *)&in[i__ - 1]; ++next; } i__1 = use[1]; for (i__ = 1; i__ <= i__1; ++i__) { *(unsigned char *)&out[next - 1] = *(unsigned char *)&string[i__ - 1]; ++next; } /* Pad with blanks, if the output string was not filled. */ if (end < outlen) { i__1 = end; s_copy(out + i__1, " ", out_len - i__1, (ftnlen)1); } chkout_("REPSUB", (ftnlen)6); return 0; } /* repsub_ */
/* $Procedure SYORDD ( Order the components of a single symbol ) */ /* Subroutine */ int syordd_(char *name__, char *tabsym, integer *tabptr, doublereal *tabval, ftnlen name_len, ftnlen tabsym_len) { /* System generated locals */ integer i__1; /* Local variables */ integer nsym; extern integer cardc_(char *, ftnlen); integer n; extern /* Subroutine */ int chkin_(char *, ftnlen); extern integer sumai_(integer *, integer *), bsrchc_(char *, integer *, char *, ftnlen, ftnlen); extern /* Subroutine */ int shelld_(integer *, doublereal *); integer locval; extern /* Subroutine */ int chkout_(char *, ftnlen); integer locsym; extern logical return_(void); /* $ Abstract */ /* Order the components of a single symbol in a double precision */ /* symbol table. The components are sorted in increasing order. */ /* $ 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 components are to be */ /* ordered. */ /* TABSYM, */ /* TABPTR, */ /* TABVAL I/O Components of the symbol table. */ /* $ Detailed_Input */ /* NAME is the name of the symbol whose components are to be */ /* ordered. If NAME is not in the symbol table, the symbol */ /* table is not modified. */ /* TABSYM, */ /* TABPTR, */ /* TABVAL are the components of a double precision symbol table. */ /* $ Detailed_Output */ /* TABSYM, */ /* TABPTR, */ /* TABVAL are the components of a double precision symbol table. */ /* The components of the symbol are sorted in increasing */ /* order. */ /* $ Parameters */ /* None. */ /* $ Files */ /* None. */ /* $ Exceptions */ /* None. */ /* $ Particulars */ /* If the symbol NAME is not in the symbol table, the symbol table */ /* is not modified. */ /* $ Examples */ /* The contents of the symbol table are: */ /* BODY4_POLE_RA --> 3.17681D2 */ /* 1.08D-1 */ /* 0.0D0 */ /* DELTA_T_A --> 3.2184D1 */ /* K --> 1.657D-3 */ /* MEAN_ANOM --> 6.239996D0 */ /* 1.99096871D-7 */ /* ORBIT_ECC --> 1.671D-2 */ /* The call, */ /* CALL SYORDD ( 'BODY4_POLE_RA', TABSYM, TABPTR, TABVAL ) */ /* modifies the contents of the symbol table to be: */ /* BODY4_POLE_RA --> 0.0D0 */ /* 1.08D-1 */ /* 3.17681D2 */ /* DELTA_T_A --> 3.2184D1 */ /* K --> 1.657D-3 */ /* MEAN_ANOM --> 6.239996D0 */ /* 1.99096871D-7 */ /* ORBIT_ECC --> 1.671D-2 */ /* Note that the call, */ /* CALL SYORDD ( 'BODY4_PRIME', TABSYM, TABPTR, TABVAL ) */ /* will not modify the symbol table because the symbol "BODY4_PRIME" */ /* 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 */ /* order the components of a single symbol */ /* -& */ /* SPICELIB functions */ /* Local variables */ /* Standard SPICE error handling. */ if (return_()) { return 0; } else { chkin_("SYORDD", (ftnlen)6); } /* How many symbols? */ nsym = cardc_(tabsym, tabsym_len); /* Is this symbol even in the table? */ locsym = bsrchc_(name__, &nsym, tabsym + tabsym_len * 6, name_len, tabsym_len); /* If so, sort the components in place. */ if (locsym > 0) { i__1 = locsym - 1; locval = sumai_(&tabptr[6], &i__1) + 1; n = tabptr[locsym + 5]; shelld_(&tabptr[locsym + 5], &tabval[locval + 5]); } chkout_("SYORDD", (ftnlen)6); return 0; } /* syordd_ */
/* $Procedure SYSELD ( Select a subset of the values of a symbol ) */ /* Subroutine */ int syseld_(char *name__, integer *begin, integer *end, char *tabsym, integer *tabptr, doublereal *tabval, doublereal *values, logical *found, ftnlen name_len, ftnlen tabsym_len) { /* System generated locals */ integer i__1; /* Local variables */ integer nsym; extern integer cardc_(char *, ftnlen); integer n; extern /* Subroutine */ int chkin_(char *, ftnlen), moved_(doublereal *, integer *, doublereal *); extern integer sumai_(integer *, integer *), bsrchc_(char *, integer *, char *, ftnlen, ftnlen); integer locval; extern /* Subroutine */ int chkout_(char *, ftnlen); integer locsym; extern logical return_(void); /* $ Abstract */ /* Select a subset of the values associated with a particular */ /* symbol in a double precision symbol table. */ /* $ 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 values are to */ /* be returned. */ /* BEGIN I Index of the first associated value to be returned. */ /* END I Index of the last associated value to be returned. */ /* TABSYM, */ /* TABPTR, */ /* TABVAL I Components of the symbol table. */ /* VALUES O Subset of the values associated with the symbol */ /* NAME. */ /* FOUND O True if the subset of values exists. */ /* $ Detailed_Input */ /* NAME is the name of the symbol whose subset of associated */ /* values to be returned. If NAME is not in the symbol */ /* table, FOUND is false. */ /* BEGIN is the index of the first associated value to be */ /* returned. If BEGIN is out of range (BEGIN < 1 or */ /* BEGIN > END) FOUND is false. */ /* END is the index of the last associated value to be */ /* returned. If END is out of range (END < 1 or */ /* END > is greater than the dimension of NAME) */ /* FOUND is false. */ /* TABSYM, */ /* TABPTR, */ /* TABVAL are components of the double precision symbol table. */ /* $ Detailed_Output */ /* VALUES is a subset of the values associated with the */ /* symbol NAME. If the subset specified by BEGIN and */ /* END exists, as many values as will fit in VALUES */ /* are returned. If the subset does not exist, no */ /* values are returned and FOUND is false. */ /* FOUND is true if the subset of values is exists. */ /* FOUND is false if BEGIN < 1, BEGIN > END, END < 1, */ /* END > the dimension of NAME, or NAME is not */ /* in the symbol table. */ /* $ Parameters */ /* None. */ /* $ Exceptions */ /* 1) This subroutine does not check to see if the output array */ /* VALUES is large enough to hold the selected set of values. */ /* The caller must provide the required space. */ /* $ Files */ /* None. */ /* $ Particulars */ /* FOUND will be false if the bounds of the subset specified by */ /* BEGIN and END are out of range. Values of BEGIN and END which */ /* specify bounds out of range are BEGIN < 1, BEGIN > END, */ /* END < 1, or END > the dimension of NAME. FOUND is also false */ /* if the symbol NAME is not in the symbol table. */ /* $ Examples */ /* The contents of the symbol table are: */ /* BODY4_POLE_RA --> 3.17681D2 */ /* 1.08D-1 */ /* 0.0D0 */ /* DELTA_T_A --> 3.2184D1 */ /* K --> 1.657D-3 */ /* MEAN_ANOM --> 6.239996D0 */ /* 1.99096871D-7 */ /* ORBIT_ECC --> 1.671D-2 */ /* Let the dimension of the array VALUES be 3. */ /* The ouput values of VALUES and FOUND for the input values of */ /* NAME, BEGIN, and END are contained in this table: */ /* NAME BEGIN END VALUES FOUND */ /* ------------- ----- --- --------------------- ------- */ /* MEAN_ANOM 1 2 6.239996D0 TRUE */ /* 1.99096871D-7 */ /* BODY4_POLE_RA 1 3 3.17681D2 */ /* 1.08D-1 */ /* 0.0D0 */ /* BODY4_PRIME 1 3 FALSE */ /* MEAN_ANOM 2 1 FALSE */ /* ORBIT_ECC 1 -2 FALSE */ /* K 1 5 FALSE */ /* ---------------------------------------------------------------- */ /* Note that FOUND is FALSE for examples 3 through 6 because: */ /* - In the 3rd example, the symbol 'BODY4_PRIME' is not in the */ /* symbol table. */ /* - In the 4th example, BEGIN > END. */ /* - In the 5th example, END < 0. */ /* - In the 6th example, END is greater than the dimension of the */ /* symbol 'K'. */ /* $ Restrictions */ /* 1) See Exceptions section. */ /* $ Literature_References */ /* None. */ /* $ Author_and_Institution */ /* H.A. Neilan (JPL) */ /* I.M. Underwood (JPL) */ /* $ Version */ /* - SPICELIB Version 1.0.2, 03-NOV-2005 (NJB) */ /* Various header corrections were made. In particular, */ /* the header no longer asserts that this routine will */ /* "return as many values as will fit" in the output array */ /* VALUES. */ /* - 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 */ /* select a subset of the values of a symbol */ /* -& */ /* SPICELIB functions */ /* Local variables */ /* Standard SPICE error handling. */ if (return_()) { return 0; } else { chkin_("SYSELD", (ftnlen)6); } /* How many symbols to start with? */ nsym = cardc_(tabsym, tabsym_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_; } else { /* We could still have a problem: do these components exist? */ /* Does this request even make sense? */ n = tabptr[locsym + 5]; if (*begin >= 1 && *begin <= n && *end >= 1 && *end <= n && *begin <= *end) { *found = TRUE_; i__1 = locsym - 1; locval = sumai_(&tabptr[6], &i__1) + 1; i__1 = *end - *begin + 1; moved_(&tabval[locval + *begin + 4], &i__1, values); } else { *found = FALSE_; } } chkout_("SYSELD", (ftnlen)6); return 0; } /* syseld_ */
/* $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_ */