1 /* spksub.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__2 = 2;
11 static integer c__6 = 6;
12
13 /* $Procedure SPKSUB ( S/P Kernel, subset ) */
spksub_(integer * handle,doublereal * descr,char * ident,doublereal * begin,doublereal * end,integer * newh,ftnlen ident_len)14 /* Subroutine */ int spksub_(integer *handle, doublereal *descr, char *ident,
15 doublereal *begin, doublereal *end, integer *newh, ftnlen ident_len)
16 {
17 logical okay;
18 integer type__, baddr, eaddr;
19 doublereal alpha, omega;
20 extern /* Subroutine */ int chkin_(char *, ftnlen), dafps_(integer *,
21 integer *, doublereal *, integer *, doublereal *), dafus_(
22 doublereal *, integer *, integer *, doublereal *, integer *);
23 doublereal ndscr[5];
24 extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen), spks01_(
25 integer *, integer *, integer *, doublereal *, doublereal *),
26 spks02_(integer *, integer *, integer *, doublereal *, doublereal
27 *), spks03_(integer *, integer *, integer *, doublereal *,
28 doublereal *), spks10_(integer *, doublereal *, integer *,
29 doublereal *, char *, ftnlen), spks05_(integer *, integer *,
30 integer *, doublereal *, doublereal *), spks12_(integer *,
31 integer *, integer *, doublereal *, doublereal *), spks13_(
32 integer *, integer *, integer *, doublereal *, doublereal *),
33 spks08_(integer *, integer *, integer *, doublereal *, doublereal
34 *), spks09_(integer *, integer *, integer *, doublereal *,
35 doublereal *), spks14_(integer *, doublereal *, integer *,
36 doublereal *, char *, ftnlen), spks15_(integer *, integer *,
37 integer *, doublereal *, doublereal *), spks17_(integer *,
38 integer *, integer *, doublereal *, doublereal *), spks18_(
39 integer *, integer *, integer *, doublereal *, doublereal *),
40 spks19_(integer *, integer *, integer *, doublereal *, doublereal
41 *), spks20_(integer *, integer *, integer *, doublereal *,
42 doublereal *), spks21_(integer *, integer *, integer *,
43 doublereal *, doublereal *);
44 doublereal dc[2];
45 extern /* Subroutine */ int dafbna_(integer *, doublereal *, char *,
46 ftnlen);
47 integer ic[6];
48 extern /* Subroutine */ int dafena_(void), sigerr_(char *, ftnlen),
49 chkout_(char *, ftnlen), setmsg_(char *, ftnlen), errint_(char *,
50 integer *, ftnlen);
51 extern logical return_(void);
52
53 /* $ Abstract */
54
55 /* Extract a subset of the data in an SPK segment into a */
56 /* separate segment. */
57
58 /* $ Disclaimer */
59
60 /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
61 /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
62 /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
63 /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
64 /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
65 /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
66 /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
67 /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
68 /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
69 /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
70
71 /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
72 /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
73 /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
74 /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
75 /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
76 /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
77
78 /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
79 /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
80 /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
81 /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
82
83 /* $ Required_Reading */
84
85 /* SPK */
86 /* DAF */
87
88 /* $ Keywords */
89
90 /* EPHEMERIS */
91
92 /* $ Declarations */
93 /* $ Brief_I/O */
94
95 /* Variable I/O Description */
96 /* -------- --- -------------------------------------------------- */
97 /* HANDLE I Handle of source segment. */
98 /* DESCR I Descriptor of source segment. */
99 /* IDENT I Identifier of source segment. */
100 /* BEGIN I Beginning (initial epoch) of subset. */
101 /* END I End (final epoch) of subset. */
102 /* NEWH I Handle of new segment. */
103
104 /* $ Detailed_Input */
105
106 /* HANDLE, */
107 /* DESCR, */
108 /* IDENT are the file handle assigned to a SPK file, the */
109 /* descriptor for a segment within the file, and the */
110 /* identifier for that segment. Together they determine */
111 /* a complete set of ephemeris data, from which a */
112 /* subset is to be extracted. */
113
114 /* BEGIN, */
115 /* END are the initial and final epochs (ephemeris time) */
116 /* of the subset. */
117
118 /* NEWH is the file handle assigned to the file in which */
119 /* the new segment is to be written. The file must */
120 /* be open for write access. NEWH and HANDLE may refer */
121 /* to the same file. */
122
123 /* $ Detailed_Output */
124
125 /* See $Files section. */
126
127 /* $ Parameters */
128
129 /* None. */
130
131 /* $ Exceptions */
132
133 /* 1) If the condition */
134
135 /* ALPHA < BEGIN < END < OMEGA */
136 /* - - - */
137
138 /* is not satisfied (where ALPHA and OMEGA are the initial */
139 /* and final epochs of the segment respectively), the error */
140 /* 'SPICE(SPKNOTASUBSET)' is signaled. */
141
142 /* 2) If the segment type is not supported by the current */
143 /* version of SPKSUB, the error 'SPICE(SPKTYPENOTSUPP)' */
144 /* is signaled. */
145
146 /* $ Files */
147
148 /* A new segment, which contains a subset of the data in the */
149 /* segment specified by DESCR and HANDLE, is written to the SPK */
150 /* file attached to NEWH. */
151
152 /* $ Particulars */
153
154 /* Sometimes, the segments in official source files---planetary */
155 /* Developmental Ephemeris (DE) files, archival spacecraft */
156 /* ephemeris files, and so on---contain more data than is needed */
157 /* by a particular user. SPKSUB allows a user to extract from a */
158 /* segment the smallest amount of ephemeris data sufficient to */
159 /* cover a specific interval. */
160
161 /* The new segment is written with the same identifier as the */
162 /* original segment, and with the same descriptor, with the */
163 /* following components changed: */
164
165 /* 1) ALPHA and OMEGA (DCD(1) and DCD(2)) are assigned the values */
166 /* specified by BEGIN and END. */
167
168 /* 2) The beginning and ending segment addresses (ICD(5) and ICD(6)) */
169 /* are changed to reflect the location of the new segment. */
170
171 /* $ Examples */
172
173 /* In the following code fragment, the descriptor for each segment */
174 /* in a source SPK file is examined. For each segment that covers a */
175 /* specified time interval, the smallest possible subset of data */
176 /* from that segment, sufficient to cover the interval, is extracted */
177 /* into a custom SPK file. */
178
179 /* Assume that the source and custom files have been opened, for */
180 /* read and write access, with handles SRC and CUST respectively. */
181
182 /* CALL DAFBFS ( SRC ) */
183 /* CALL DAFFNA ( FOUND ) */
184
185 /* DO WHILE ( FOUND ) */
186 /* CALL DAFGS ( DESCR ) */
187 /* CALL DAFUS ( DESCR, 2, 6, DC, IC ) */
188
189 /* IF ( DC(1) .LE. BEGIN .AND. END .LE. DC(2) ) THEN */
190 /* CALL DAFGN ( IDENT ) */
191 /* CALL SPKSUB ( SRC, DESCR, IDENT, BEGIN, END, CUST ) */
192 /* END IF */
193
194 /* CALL DAFFNA ( FOUND ) */
195 /* END DO */
196
197
198 /* $ Restrictions */
199
200 /* 1) There is no way for SPKSUB to verify that the descriptor and */
201 /* identifier are the original ones for the segment. Changing */
202 /* the descriptor can cause the data in the new segment to be */
203 /* evaluated incorrectly; changing the identifier can destroy */
204 /* the path from the data back to its original source. */
205
206 /* $ Literature_References */
207
208 /* NAIF Document 168.0, "S- and P- Kernel (SPK) Specification and */
209 /* User's Guide" */
210
211 /* $ Author_and_Institution */
212
213 /* K.R. Gehringer (JPL) */
214 /* W.L. Taber (JPL) */
215 /* N.J. Bachman (JPL) */
216 /* J.M. Lynch (JPL) */
217 /* R.E. Thurman (JPL) */
218 /* I.M. Underwood (JPL) */
219
220 /* $ Version */
221
222 /* - SPICELIB Version 9.0.0, 23-DEC-2013 (NJB) */
223
224 /* The routine was updated to handle types 19, 20 and 21. Some */
225 /* minor changes were made to comments. */
226
227 /* - SPICELIB Version 8.0.0, 12-AUG-2002 (NJB) */
228
229 /* The routine was updated to handle type 18. */
230
231 /* - SPICELIB Version 7.0.0, 06-NOV-1999 (NJB) */
232
233 /* The routine was updated to handle types 12 and 13. */
234
235 /* - SPICELIB Version 6.0.0, 30-JUN-1997 (WLT) */
236
237 /* The routine was updated to handle types 10 and 17. */
238
239 /* - SPICELIB Version 5.0.0, 10-MAR-1995 (KRG) */
240
241 /* The routine was updated to handle type 14. */
242
243 /* - SPICELIB Version 4.0.0, 07-NOV-1994 (WLT) */
244
245 /* The routine was updated to handle type 15. */
246
247 /* - SPICELIB Version 3.0.0, 05-AUG-1993 (NJB) */
248
249 /* The routine was updated to handle types 08 and 09. */
250
251 /* - SPICELIB Version 2.0.0, 01-APR-1992 (JML) */
252
253 /* 1) The routine was updated to handle type 05. */
254
255 /* 2) DESCR was being used as both an input and output */
256 /* variable when it was only supposed to be used for */
257 /* input. A new local variable, NDSCR, was added where DESCR */
258 /* was being altered. */
259
260 /* - SPICELIB Version 1.0.1, 22-MAR-1990 (HAN) */
261
262 /* Literature references added to the header. */
263
264 /* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) (RET) */
265
266 /* -& */
267 /* $ Index_Entries */
268
269 /* subset of spk file */
270
271 /* -& */
272 /* $ Revisions */
273
274 /* - SPICELIB Version 9.0.0, 23-DEC-2013 (NJB) */
275
276 /* The routine was updated to handle types 19, 20 and 21. Some */
277 /* minor changes were made to comments. */
278
279 /* - SPICELIB Version 8.0.0, 12-AUG-2002 (NJB) */
280
281 /* The routine was updated to handle type 18. */
282
283 /* - SPICELIB Version 6.0.0, 30-JUN-1997 (WLT) */
284
285 /* The routine was updated to handle types 10 and 17. */
286
287 /* - SPICELIB Version 5.0.0, 10-MAR-1995 (KRG) */
288
289 /* The routine was updated to handle type 14. */
290
291 /* - SPICELIB Version 4.0.0, 07-NOV-1994 (WLT) */
292
293 /* The routine was updated to handle type 15. */
294
295 /* - SPICELIB Version 3.0.0, 05-AUG-1993 (NJB) */
296
297 /* The routine was updated to handle types 08 and 09. */
298
299 /* - SPICELIB Version 2.0.0, 01-APR-1992 (JML) */
300
301 /* 1) The routine was updated to handle type 05. */
302
303 /* 2) DESCR was being used as both an input and output */
304 /* variable when it was only supposed to be used for */
305 /* input. A new local variable, NDSCR, was added where DESCR */
306 /* was being altered. */
307
308 /* -& */
309
310 /* SPICELIB functions */
311
312
313 /* Local variables */
314
315
316 /* Standard SPICE error handling. */
317
318 if (return_()) {
319 return 0;
320 } else {
321 chkin_("SPKSUB", (ftnlen)6);
322 }
323
324 /* Unpack the descriptor. */
325
326 dafus_(descr, &c__2, &c__6, dc, ic);
327 alpha = dc[0];
328 omega = dc[1];
329 type__ = ic[3];
330 baddr = ic[4];
331 eaddr = ic[5];
332
333 /* Make sure the epochs check out. */
334
335 okay = alpha <= *begin && *begin <= *end && *end <= omega;
336 if (! okay) {
337 setmsg_("Specified interval [#, #] is not a subset of segment interv"
338 "al [#, #].", (ftnlen)69);
339 errdp_("#", begin, (ftnlen)1);
340 errdp_("#", end, (ftnlen)1);
341 errdp_("#", &alpha, (ftnlen)1);
342 errdp_("#", &omega, (ftnlen)1);
343 sigerr_("SPICE(SPKNOTASUBSET)", (ftnlen)20);
344 chkout_("SPKSUB", (ftnlen)6);
345 return 0;
346 }
347
348 /* Begin the new segment, with a descriptor containing the subset */
349 /* epochs. */
350
351 dc[0] = *begin;
352 dc[1] = *end;
353 dafps_(&c__2, &c__6, dc, ic, ndscr);
354
355 /* Let the type-specific (SPKSnn) routines decide what to move. */
356
357 if (type__ == 1) {
358 dafbna_(newh, ndscr, ident, ident_len);
359 spks01_(handle, &baddr, &eaddr, begin, end);
360 dafena_();
361 } else if (type__ == 2) {
362 dafbna_(newh, ndscr, ident, ident_len);
363 spks02_(handle, &baddr, &eaddr, begin, end);
364 dafena_();
365 } else if (type__ == 3) {
366 dafbna_(newh, ndscr, ident, ident_len);
367 spks03_(handle, &baddr, &eaddr, begin, end);
368 dafena_();
369
370 /* Type 04 has not been yet been added to SPICELIB. */
371
372 /* ELSE IF ( TYPE .EQ. 04 ) THEN */
373 /* CALL DAFBNA ( NEWH, NDSCR, IDENT ) */
374 /* CALL SPKS04 ( HANDLE, BADDR, EADDR, BEGIN, END ) */
375 /* CALL DAFENA */
376 } else if (type__ == 5) {
377 dafbna_(newh, ndscr, ident, ident_len);
378 spks05_(handle, &baddr, &eaddr, begin, end);
379 dafena_();
380 } else if (type__ == 8) {
381 dafbna_(newh, ndscr, ident, ident_len);
382 spks08_(handle, &baddr, &eaddr, begin, end);
383 dafena_();
384 } else if (type__ == 9) {
385 dafbna_(newh, ndscr, ident, ident_len);
386 spks09_(handle, &baddr, &eaddr, begin, end);
387 dafena_();
388 } else if (type__ == 10) {
389 spks10_(handle, descr, newh, ndscr, ident, ident_len);
390 } else if (type__ == 12) {
391 dafbna_(newh, ndscr, ident, ident_len);
392 spks12_(handle, &baddr, &eaddr, begin, end);
393 dafena_();
394 } else if (type__ == 13) {
395 dafbna_(newh, ndscr, ident, ident_len);
396 spks13_(handle, &baddr, &eaddr, begin, end);
397 dafena_();
398 } else if (type__ == 14) {
399 spks14_(handle, descr, newh, ndscr, ident, ident_len);
400 } else if (type__ == 15) {
401 dafbna_(newh, ndscr, ident, ident_len);
402 spks15_(handle, &baddr, &eaddr, begin, end);
403 dafena_();
404 } else if (type__ == 17) {
405 dafbna_(newh, ndscr, ident, ident_len);
406 spks17_(handle, &baddr, &eaddr, begin, end);
407 dafena_();
408 } else if (type__ == 18) {
409 dafbna_(newh, ndscr, ident, ident_len);
410 spks18_(handle, &baddr, &eaddr, begin, end);
411 dafena_();
412 } else if (type__ == 19) {
413 dafbna_(newh, ndscr, ident, ident_len);
414 spks19_(handle, &baddr, &eaddr, begin, end);
415 dafena_();
416 } else if (type__ == 20) {
417 dafbna_(newh, ndscr, ident, ident_len);
418 spks20_(handle, &baddr, &eaddr, begin, end);
419 dafena_();
420 } else if (type__ == 21) {
421 dafbna_(newh, ndscr, ident, ident_len);
422 spks21_(handle, &baddr, &eaddr, begin, end);
423 dafena_();
424 } else {
425 setmsg_("SPK data type # is not supported.", (ftnlen)33);
426 errint_("#", &type__, (ftnlen)1);
427 sigerr_("SPICE(SPKTYPENOTSUPP)", (ftnlen)21);
428 chkout_("SPKSUB", (ftnlen)6);
429 return 0;
430 }
431 chkout_("SPKSUB", (ftnlen)6);
432 return 0;
433 } /* spksub_ */
434
435