1 /* sypshc.f -- translated by f2c (version 19980913).
2 You must link the resulting object file with the libraries:
3 -lf2c -lm (in that order)
4 */
5
6 #include "f2c.h"
7
8 /* Table of constant values */
9
10 static integer c__1 = 1;
11
12 /* $Procedure SYPSHC ( Push a value onto a particular symbol ) */
sypshc_(char * name__,char * value,char * tabsym,integer * tabptr,char * tabval,ftnlen name_len,ftnlen value_len,ftnlen tabsym_len,ftnlen tabval_len)13 /* Subroutine */ int sypshc_(char *name__, char *value, char *tabsym, integer
14 *tabptr, char *tabval, ftnlen name_len, ftnlen value_len, ftnlen
15 tabsym_len, ftnlen tabval_len)
16 {
17 /* System generated locals */
18 integer i__1;
19
20 /* Builtin functions */
21 integer s_cmp(char *, char *, ftnlen, ftnlen);
22
23 /* Local variables */
24 integer nval, nsym;
25 extern integer cardc_(char *, ftnlen);
26 extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
27 ftnlen, ftnlen);
28 extern integer sizec_(char *, ftnlen), sumai_(integer *, integer *);
29 extern /* Subroutine */ int scardc_(integer *, char *, ftnlen), inslac_(
30 char *, integer *, integer *, char *, integer *, ftnlen, ftnlen);
31 integer locval;
32 extern integer lstlec_(char *, integer *, char *, ftnlen, ftnlen);
33 extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
34 ftnlen), setmsg_(char *, ftnlen);
35 integer locsym;
36 logical oldsym;
37 extern /* Subroutine */ int sysetc_(char *, char *, char *, integer *,
38 char *, ftnlen, ftnlen, ftnlen, ftnlen);
39 extern logical return_(void);
40
41 /* $ Abstract */
42
43 /* Push a value onto a particular symbol in a character symbol table. */
44 /* The previous value(s) associated with the symbol is extended at */
45 /* the front. A new symbol is created if necessary. */
46
47 /* $ Disclaimer */
48
49 /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
50 /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
51 /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
52 /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
53 /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
54 /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
55 /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
56 /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
57 /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
58 /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
59
60 /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
61 /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
62 /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
63 /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
64 /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
65 /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
66
67 /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
68 /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
69 /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
70 /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
71
72 /* $ Required_Reading */
73
74 /* SYMBOLS */
75
76 /* $ Keywords */
77
78 /* SYMBOLS */
79
80 /* $ Declarations */
81 /* $ Brief_I/O */
82
83 /* VARIABLE I/O DESCRIPTION */
84 /* -------- --- -------------------------------------------------- */
85 /* NAME I Name of the symbol onto which the value is to be */
86 /* pushed. */
87 /* VALUE I Value that is to be pushed onto the symbol NAME. */
88
89 /* TABSYM, */
90 /* TABPTR, */
91 /* TABVAL I/O Components of the symbol table. */
92
93 /* $ Detailed_Input */
94
95 /* NAME is the name of the symbol onto which the value is to */
96 /* be pushed. If NAME is not in the symbol table, a new */
97 /* symbol is created. */
98
99 /* TABSYM, */
100 /* TABPTR, */
101 /* TABVAL are the components of a character symbol table. */
102
103 /* $ Detailed_Output */
104
105 /* TABSYM, */
106 /* TABPTR, */
107 /* TABVAL are the components of a character symbol table. */
108 /* The value is added to the symbol table at the front */
109 /* of the previous value(s) associated with the symbol */
110 /* NAME. If NAME is not originally in the symbol table, */
111 /* a new symbol is created. */
112
113 /* $ Parameters */
114
115 /* None. */
116
117 /* $ Files */
118
119 /* None. */
120
121 /* $ Exceptions */
122
123 /* 1) If the addition of the new value to the symbol table */
124 /* causes an overflow in the value table, the error */
125 /* SPICE(VALUETABLEFULL) is signalled. */
126
127 /* $ Particulars */
128
129 /* If the symbol NAME is not in the symbol table, a new symbol */
130 /* is created. */
131
132 /* $ Examples */
133
134 /* The contents of the symbol table are: */
135
136 /* BOHR --> HYDROGEN ATOM */
137 /* EINSTEIN --> SPECIAL RELATIVITY */
138 /* PHOTOELECTRIC EFFECT */
139 /* BROWNIAN MOTION */
140 /* FERMI --> NUCLEAR FISSION */
141 /* PAULI --> EXCLUSION PRINCIPLE */
142
143 /* The call, */
144
145 /* CALL SYPSHC ( 'PAULI', 'NEUTRINO', TABSYM, TABPTR, TABVAL ) */
146
147 /* modifies the contents of the symbol table to be: */
148
149 /* BOHR --> HYDROGEN ATOM */
150 /* EINSTEIN --> SPECIAL RELATIVITY */
151 /* PHOTOELECTRIC EFFECT */
152 /* BROWNIAN MOTION */
153 /* FERMI --> NUCLEAR FISSION */
154 /* PAULI --> NEUTRINO */
155 /* EXCLUSION PRINCIPLE */
156
157 /* The next call, */
158
159 /* CALL SYPSHC ( 'MILLIKAN', 'PHOTOELECTRIC EFFECT', */
160 /* . TABSYM, TABPTR, TABVAL ) */
161
162 /* modifies the contents of the symbol table to be: */
163
164 /* BOHR --> HYDROGEN ATOM */
165 /* EINSTEIN --> SPECIAL RELATIVITY */
166 /* PHOTOELECTRIC EFFECT */
167 /* BROWNIAN MOTION */
168 /* FERMI --> NUCLEAR FISSION */
169 /* MILLIKAN --> PHOTOELECTRIC EFFECT */
170 /* PAULI --> NEUTRINO */
171 /* EXCLUSION PRINCIPLE */
172
173 /* Note that a new symbol "MILLIKAN" was created by the last call. */
174
175 /* $ Restrictions */
176
177 /* None. */
178
179 /* $ Literature_References */
180
181 /* None. */
182
183 /* $ Author_and_Institution */
184
185 /* H.A. Neilan (JPL) */
186 /* I.M. Underwood (JPL) */
187
188 /* $ Version */
189
190 /* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
191
192 /* Comment section for permuted index source lines was added */
193 /* following the header. */
194
195 /* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) (HAN) */
196
197 /* -& */
198 /* $ Index_Entries */
199
200 /* push a value onto a particular symbol */
201
202 /* -& */
203
204 /* SPICELIB functions */
205
206
207 /* Local variables */
208
209
210 /* Standard SPICE error handling. */
211
212 if (return_()) {
213 return 0;
214 } else {
215 chkin_("SYPSHC", (ftnlen)6);
216 }
217
218 /* How many symbols to start with? */
219
220 nsym = cardc_(tabsym, tabsym_len);
221 nval = cardc_(tabval, tabval_len);
222
223 /* Where does this symbol belong? Is it already in the table? */
224
225 locsym = lstlec_(name__, &nsym, tabsym + tabsym_len * 6, name_len,
226 tabsym_len);
227 oldsym = locsym != 0 && s_cmp(tabsym + (locsym + 5) * tabsym_len, name__,
228 tabsym_len, name_len) == 0;
229
230 /* If it's not already in the table, use SET to create a brand new */
231 /* symbol. */
232
233 if (! oldsym) {
234 sysetc_(name__, value, tabsym, tabptr, tabval, name_len, value_len,
235 tabsym_len, tabval_len);
236
237 /* If it is in the table, we can't proceed unless we know that we */
238 /* have enough room for one extra addition in the value table. */
239
240 } else if (nval >= sizec_(tabval, tabval_len)) {
241 setmsg_("SYPSHC: The addition of the value $ to the symbol # causes "
242 "an overflow in the value table.", (ftnlen)90);
243 errch_("$", value, (ftnlen)1, value_len);
244 errch_("#", name__, (ftnlen)1, name_len);
245 sigerr_("SPICE(VALUETABLEFULL)", (ftnlen)21);
246
247 /* If there's room, add the new value to the value table. Add one */
248 /* to the dimension, and put the value in the right place. */
249
250 } else {
251 i__1 = locsym - 1;
252 locval = sumai_(&tabptr[6], &i__1) + 1;
253 inslac_(value, &c__1, &locval, tabval + tabval_len * 6, &nval,
254 value_len, tabval_len);
255 scardc_(&nval, tabval, tabval_len);
256 ++tabptr[locsym + 5];
257 }
258 chkout_("SYPSHC", (ftnlen)6);
259 return 0;
260 } /* sypshc_ */
261
262