1 /* syrend.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__0 = 0;
11 static integer c__1 = 1;
12
13 /* $Procedure SYREND ( Rename an existing symbol ) */
syrend_(char * old,char * new__,char * tabsym,integer * tabptr,doublereal * tabval,ftnlen old_len,ftnlen new_len,ftnlen tabsym_len)14 /* Subroutine */ int syrend_(char *old, char *new__, char *tabsym, integer *
15 tabptr, doublereal *tabval, ftnlen old_len, ftnlen new_len, ftnlen
16 tabsym_len)
17 {
18 /* System generated locals */
19 integer i__1;
20
21 /* Builtin functions */
22 integer s_cmp(char *, char *, ftnlen, ftnlen);
23 /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
24
25 /* Local variables */
26 integer nsym;
27 extern integer cardc_(char *, ftnlen);
28 extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
29 ftnlen, ftnlen);
30 extern integer sumai_(integer *, integer *), bsrchc_(char *, integer *,
31 char *, ftnlen, ftnlen);
32 integer olddim, oldloc;
33 extern /* Subroutine */ int swapac_(integer *, integer *, integer *,
34 integer *, char *, ftnlen), swapad_(integer *, integer *, integer
35 *, integer *, doublereal *);
36 integer oldval;
37 extern /* Subroutine */ int sydeld_(char *, char *, integer *, doublereal
38 *, ftnlen, ftnlen), swapai_(integer *, integer *, integer *,
39 integer *, integer *);
40 extern integer lstlec_(char *, integer *, char *, ftnlen, ftnlen);
41 integer newloc;
42 extern /* Subroutine */ int sigerr_(char *, ftnlen);
43 integer newval;
44 extern /* Subroutine */ int chkout_(char *, ftnlen), setmsg_(char *,
45 ftnlen);
46 extern logical return_(void);
47
48 /* $ Abstract */
49
50 /* Rename an existing symbol in a double precision symbol table. */
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 /* OLD I Name of the symbol to be renamed. */
91 /* NEW I New name of the symbol. */
92
93 /* TABSYM, */
94 /* TABPTR, */
95 /* TABVAL I Components of the symbol table. */
96
97 /* $ Detailed_Input */
98
99 /* OLD is the name of the symbol to be renamed. If OLD is */
100 /* not in the symbol table, the tables are not modified. */
101
102 /* NEW is the new name of the symbol. If the symbol NEW */
103 /* already exists in the symbol table, it is deleted. */
104 /* OLD is then renamed to NEW. */
105
106 /* TABSYM, */
107 /* TABPTR, */
108 /* TABVAL are components of the double precision symbol table. */
109
110 /* $ Detailed_Output */
111
112 /* TABSYM, */
113 /* TABPTR, */
114 /* TABVAL are components of the double precision symbol table. */
115 /* The values previously associated with OLD are now */
116 /* associated with NEW. If OLD is not in the symbol */
117 /* table, the symbol tables are not modified. */
118
119 /* $ Parameters */
120
121 /* None. */
122
123 /* $ Files */
124
125 /* None. */
126
127 /* $ Exceptions */
128
129 /* If the symbol OLD is not in the symbol table, the error */
130 /* SPICE(NOSUCHSYMBOL) is signalled. */
131
132 /* $ Particulars */
133
134 /* None. */
135
136 /* $ Examples */
137
138 /* The contents of the symbol table are: */
139
140 /* BODY4_POLE_RA --> 3.17681D2 */
141 /* 1.08D-1 */
142 /* 0.0D0 */
143 /* DELTA_T_A --> 3.2184D1 */
144 /* K --> 1.657D-3 */
145 /* MEAN_ANOM --> 6.239996D0 */
146 /* 1.99096871D-7 */
147 /* ORBIT_ECC --> 1.671D-2 */
148
149
150 /* The call, */
151
152 /* CALL SYREND ( 'K', 'EB', TABSYM, TABPTR, TABVAL ) */
153
154 /* modifies the contents of the symbol table to be: */
155
156 /* BODY4_POLE_RA --> 3.17681D2 */
157 /* 1.08D-1 */
158 /* 0.0D0 */
159 /* DELTA_T_A --> 3.2184D1 */
160 /* EB --> 1.657D-3 */
161 /* MEAN_ANOM --> 6.239996D0 */
162 /* 1.99096871D-7 */
163 /* ORBIT_ECC --> 1.671D-2 */
164 /* 1.08D-1 */
165 /* 0.0D0 */
166
167 /* The next call, */
168
169 /* CALL SYREND ( 'EB', 'DELTA_T_A', TABSYM, TABPTR, TABVAL ) */
170
171 /* modifies the contents of the table to be: */
172
173 /* BODY4_POLE_RA --> 3.17681D2 */
174 /* 1.08D-1 */
175 /* 0.0D0 */
176 /* DELTA_T_A --> 1.657D-3 */
177 /* MEAN_ANOM --> 6.239996D0 */
178 /* 1.99096871D-7 */
179 /* ORBIT_ECC --> 1.671D-2 */
180 /* 1.08D-1 */
181 /* 0.0D0 */
182
183 /* Note that the symbol "DELTA_T_A" was deleted from the table, */
184 /* and the symbol "EB" was then renamed to "DELTA_T_A". If the */
185 /* new symbol exists, it is deleted from the table before its name */
186 /* is given to another symbol. */
187
188
189 /* The next call, */
190
191 /* CALL SYREND ( 'K', 'EB', TABSYM, TABPTR, TABVAL ) */
192
193 /* does not modify the contents of the symbol table. It signals */
194 /* the error SPICE(NOSUCHSYMBOL) because the symbol "K" does not */
195 /* exist in the symbol table. */
196
197 /* $ Restrictions */
198
199 /* None. */
200
201 /* $ Literature_References */
202
203 /* None. */
204
205 /* $ Author_and_Institution */
206
207 /* N.J. Bachman (JPL) */
208 /* H.A. Neilan (JPL) */
209 /* I.M. Underwood (JPL) */
210
211 /* $ Version */
212
213 /* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
214
215 /* Comment section for permuted index source lines was added */
216 /* following the header. */
217
218 /* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) (HAN) */
219
220 /* -& */
221 /* $ Index_Entries */
222
223 /* rename an existing symbol */
224
225 /* -& */
226 /* $ Revisions */
227
228 /* - Beta Version 1.1.0, 17-FEB-1989 (NJB) */
229
230 /* Declaration of the unused function SIZEC removed. */
231
232 /* -& */
233
234 /* SPICELIB functions */
235
236
237 /* Local variables */
238
239
240 /* Standard SPICE error handling. */
241
242 if (return_()) {
243 return 0;
244 } else {
245 chkin_("SYREND", (ftnlen)6);
246 }
247
248 /* Where was the old symbol? */
249
250 nsym = cardc_(tabsym, tabsym_len);
251 oldloc = bsrchc_(old, &nsym, tabsym + tabsym_len * 6, old_len, tabsym_len)
252 ;
253
254 /* An overflow is simply not possible here. The only thing that can */
255 /* go wrong is that the old symbol does not exist. */
256
257 if (oldloc == 0) {
258 setmsg_("SYREND: The symbol # is not in the symbol table.", (ftnlen)
259 48);
260 errch_("#", old, (ftnlen)1, old_len);
261 sigerr_("SPICE(NOSUCHSYMBOL)", (ftnlen)19);
262
263 /* Are these the same symbol? */
264
265 } else if (s_cmp(new__, old, new_len, old_len) != 0) {
266
267 /* If the new symbol already exists, delete it. */
268
269 sydeld_(new__, tabsym, tabptr, tabval, new_len, tabsym_len);
270 nsym = cardc_(tabsym, tabsym_len);
271 oldloc = bsrchc_(old, &nsym, tabsym + tabsym_len * 6, old_len,
272 tabsym_len);
273
274 /* Swap N elements at the old location with zero elements */
275 /* at the new location. */
276
277 newloc = lstlec_(new__, &nsym, tabsym + tabsym_len * 6, new_len,
278 tabsym_len) + 1;
279 i__1 = oldloc - 1;
280 oldval = sumai_(&tabptr[6], &i__1) + 1;
281 i__1 = newloc - 1;
282 newval = sumai_(&tabptr[6], &i__1) + 1;
283 olddim = tabptr[oldloc + 5];
284 swapad_(&olddim, &oldval, &c__0, &newval, &tabval[6]);
285
286 /* Move the name and dimension the same way. */
287
288 swapac_(&c__1, &oldloc, &c__0, &newloc, tabsym + tabsym_len * 6,
289 tabsym_len);
290 swapai_(&c__1, &oldloc, &c__0, &newloc, &tabptr[6]);
291 if (oldloc < newloc) {
292 --newloc;
293 }
294 s_copy(tabsym + (newloc + 5) * tabsym_len, new__, tabsym_len, new_len)
295 ;
296 }
297 chkout_("SYREND", (ftnlen)6);
298 return 0;
299 } /* syrend_ */
300
301