1 /* sysetc.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 SYSETC ( Set the value associated with a symbol ) */
sysetc_(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 sysetc_(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 /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
23
24 /* Local variables */
25 integer nval, nptr, nsym;
26 extern integer cardc_(char *, ftnlen), cardi_(integer *);
27 extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
28 ftnlen, ftnlen);
29 extern integer sizec_(char *, ftnlen), sumai_(integer *, integer *),
30 sizei_(integer *);
31 extern /* Subroutine */ int scardc_(integer *, char *, ftnlen), remlac_(
32 integer *, integer *, char *, integer *, ftnlen), scardi_(integer
33 *, integer *), inslac_(char *, integer *, integer *, char *,
34 integer *, ftnlen, ftnlen);
35 integer dimval;
36 extern /* Subroutine */ int inslai_(integer *, integer *, integer *,
37 integer *, integer *);
38 integer locval;
39 extern integer lstlec_(char *, integer *, char *, ftnlen, ftnlen);
40 extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
41 ftnlen), setmsg_(char *, ftnlen);
42 integer locsym;
43 logical oldsym;
44 extern logical return_(void);
45
46 /* $ Abstract */
47
48 /* Set the value of a particular symbol in a character symbol table. */
49 /* If the symbol already exists, the previous values associated with */
50 /* it are removed, otherwise a new symbol is created. */
51
52 /* $ Disclaimer */
53
54 /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
55 /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
56 /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
57 /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
58 /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
59 /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
60 /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
61 /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
62 /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
63 /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
64
65 /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
66 /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
67 /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
68 /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
69 /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
70 /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
71
72 /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
73 /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
74 /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
75 /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
76
77 /* $ Required_Reading */
78
79 /* SYMBOLS */
80
81 /* $ Keywords */
82
83 /* SYMBOLS */
84
85 /* $ Declarations */
86 /* $ Brief_I/O */
87
88 /* VARIABLE I/O DESCRIPTION */
89 /* -------- --- -------------------------------------------------- */
90 /* NAME I Name of the symbol whose associated value is to be */
91 /* set. */
92 /* VALUE I Associated value of the symbol NAME. */
93
94 /* TABSYM, */
95 /* TABPTR, */
96 /* TABVAL I/O Components of the symbol table. */
97
98 /* $ Detailed_Input */
99
100 /* NAME is the name of the symbol whose associated value is to */
101 /* be set. If NAME has values associated with it, they are */
102 /* removed, and VALUE becomes the only value associated */
103 /* with NAME. If NAME is not in the symbol table, a new */
104 /* symbol is created, provided there is room in the */
105 /* symbol table. */
106
107 /* VALUE is the new value associated with the symbol NAME. */
108
109 /* TABSYM, */
110 /* TABPTR, */
111 /* TABVAL are the components of a character symbol table. */
112
113 /* $ Detailed_Output */
114
115 /* TABSYM, */
116 /* TABPTR, */
117 /* TABVAL are the components of a character symbol table. */
118 /* If NAME has values associated with it, they are */
119 /* removed, and VALUE becomes the only value associated */
120 /* with NAME. If NAME is not in the symbol table, a new */
121 /* symbol is created, provided there is room in the */
122 /* symbol table. */
123
124 /* $ Parameters */
125
126 /* None. */
127
128 /* $ Files */
129
130 /* None. */
131
132 /* $ Exceptions */
133
134 /* 1) If the addition of a new symbol causes an overflow in the */
135 /* name table, the error SPICE(NAMETABLEFULL) is signalled. */
136
137 /* 2) If the addition of a new symbol causes an overflow in the */
138 /* pointer table, the error SPICE(POINTERTABLEFULL) is signalled. */
139
140 /* 3) If the addition of a new symbolcauses an overflow in the */
141 /* value table, the error SPICE(VALUETABLEFULL) is signalled. */
142
143 /* $ Particulars */
144
145 /* If NAME has values associated with it, they are */
146 /* removed, and VALUE becomes the only value associated */
147 /* with NAME. If NAME is not in the symbol table, a new */
148 /* symbol is created, provided there is room in the */
149 /* symbol table. */
150
151 /* $ Examples */
152
153 /* The contents of the symbol table are: */
154
155 /* BOHR --> HYDROGEN ATOM */
156 /* EINSTEIN --> SPECIAL RELATIVITY */
157 /* PHOTOELECTRIC EFFECT */
158 /* BROWNIAN MOTION */
159 /* FERMI --> NUCLEAR FISSION */
160 /* PAULI --> EXCLUSION PRINCIPLE */
161 /* NEUTRINO */
162
163 /* The call, */
164
165 /* CALL SYSETC ( 'EINSTEIN', 'GENERAL RELATIVITY', */
166 /* . TABSYM, TABPTR, TABVAL ) */
167
168 /* modifies the contents of the symbol table to be: */
169
170 /* BOHR --> HYDROGEN ATOM */
171 /* EINSTEIN --> GENERAL RELATIVITY */
172 /* FERMI --> NUCLEAR FISSION */
173 /* PAULI --> EXCLUSION PRINCIPLE */
174 /* NEUTRINO */
175
176 /* Note that the previous values associated with the symbol */
177 /* "EINSTEIN" have been deleted, and now only the new value is */
178 /* associated with the symbol. */
179
180
181 /* The next call, */
182
183 /* CALL SYSETC ( 'MILLIKAN', 'PHOTOELECTRIC EFFECT' */
184 /* . TABSYM, TABPTR, TABVAL ) */
185
186 /* modifies the contents of the symbol table to be: */
187
188 /* BOHR --> HYDROGEN ATOM */
189 /* EINSTEIN --> GENERAL RELATIVITY */
190 /* FERMI --> NUCLEAR FISSION */
191 /* MILLIKAN --> PHOTOELECTRIC EFFECT */
192 /* PAULI --> EXCLUSION PRINCIPLE */
193 /* NEUTRINOC */
194
195 /* Note that the new symbol "MILLIKAN" was created by the last call. */
196 /* A new symbol is created only if there is room in the symbol */
197 /* table. */
198
199 /* $ Restrictions */
200
201 /* None. */
202
203 /* $ Literature_References */
204
205 /* None. */
206
207 /* $ Author_and_Institution */
208
209 /* H.A. Neilan (JPL) */
210 /* I.M. Underwood (JPL) */
211
212 /* $ Version */
213
214 /* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
215
216 /* Comment section for permuted index source lines was added */
217 /* following the header. */
218
219 /* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) (HAN) */
220
221 /* -& */
222 /* $ Index_Entries */
223
224 /* set the value associated with a symbol */
225
226 /* -& */
227
228 /* SPICELIB functions */
229
230
231 /* Local variables */
232
233
234 /* Standard SPICE error handling. */
235
236 if (return_()) {
237 return 0;
238 } else {
239 chkin_("SYSETC", (ftnlen)6);
240 }
241
242 /* How many symbols to start with? */
243
244 nsym = cardc_(tabsym, tabsym_len);
245 nptr = cardi_(tabptr);
246 nval = cardc_(tabval, tabval_len);
247
248 /* Where does this symbol belong? Is it already in the table? */
249
250 locsym = lstlec_(name__, &nsym, tabsym + tabsym_len * 6, name_len,
251 tabsym_len);
252 oldsym = locsym != 0 && s_cmp(tabsym + (locsym + 5) * tabsym_len, name__,
253 tabsym_len, name_len) == 0;
254
255 /* If it's already in the table, there's no chance of overflow. */
256 /* Leave the name where it is. Remove all but one of the existing */
257 /* values, replacing that with the new value. And set the dimension */
258 /* to one. */
259
260 if (oldsym) {
261 i__1 = locsym - 1;
262 locval = sumai_(&tabptr[6], &i__1) + 1;
263 dimval = tabptr[locsym + 5];
264 if (dimval > 1) {
265 i__1 = dimval - 1;
266 remlac_(&i__1, &locval, tabval + tabval_len * 6, &nval,
267 tabval_len);
268 scardc_(&nval, tabval, tabval_len);
269 }
270 tabptr[locsym + 5] = 1;
271 s_copy(tabval + (locval + 5) * tabval_len, value, tabval_len,
272 value_len);
273
274 /* Otherwise, we can't proceed unless we know that we have enough */
275 /* room for one extra addition in all three tables. */
276
277 } else if (nsym >= sizec_(tabsym, tabsym_len)) {
278 setmsg_("SYSETC: Addition of the new symbol # causes an overflow in "
279 "the name table.", (ftnlen)74);
280 errch_("#", name__, (ftnlen)1, name_len);
281 sigerr_("SPICE(NAMETABLEFULL)", (ftnlen)20);
282 } else if (nptr >= sizei_(tabptr)) {
283 setmsg_("SYSETC: Addition of the new symbol # causes an overflow in "
284 "the pointer table.", (ftnlen)77);
285 errch_("#", name__, (ftnlen)1, name_len);
286 sigerr_("SPICE(POINTERTABLEFULL)", (ftnlen)23);
287 } else if (nval >= sizec_(tabval, tabval_len)) {
288 setmsg_("SYSETC: Addition of the new symbol # causes an overflow in"
289 " the value table.", (ftnlen)76);
290 errch_("#", name__, (ftnlen)1, name_len);
291 sigerr_("SPICE(VALUETABLEFULL)", (ftnlen)21);
292
293 /* If there's room, add the new name to the name table. Give the */
294 /* symbol dimension one, and put the value in the right place. */
295
296 } else {
297 i__1 = locsym + 1;
298 inslac_(name__, &c__1, &i__1, tabsym + tabsym_len * 6, &nsym,
299 name_len, tabsym_len);
300 scardc_(&nsym, tabsym, tabsym_len);
301 i__1 = locsym + 1;
302 inslai_(&c__1, &c__1, &i__1, &tabptr[6], &nptr);
303 scardi_(&nptr, tabptr);
304 locval = sumai_(&tabptr[6], &locsym) + 1;
305 inslac_(value, &c__1, &locval, tabval + tabval_len * 6, &nval,
306 value_len, tabval_len);
307 scardc_(&nval, tabval, tabval_len);
308 }
309 chkout_("SYSETC", (ftnlen)6);
310 return 0;
311 } /* sysetc_ */
312
313