1 /* locati.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 /* $Procedure LOCATI ( Locate an identifier in a list ) */
locati_(integer * id,integer * idsz,integer * list,integer * pool,integer * at,logical * presnt)9 /* Subroutine */ int locati_(integer *id, integer *idsz, integer *list,
10 integer *pool, integer *at, logical *presnt)
11 {
12 /* System generated locals */
13 integer list_dim1, list_offset, i__1;
14
15 /* Local variables */
16 integer head;
17 logical same, more;
18 integer last, i__;
19 extern /* Subroutine */ int chkin_(char *, ftnlen);
20 integer nfree;
21 extern /* Subroutine */ int lnkan_(integer *, integer *);
22 integer psize;
23 extern /* Subroutine */ int lnkilb_(integer *, integer *, integer *);
24 extern integer lnknfn_(integer *);
25 extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
26 ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
27 ftnlen);
28 extern integer lnksiz_(integer *);
29 extern /* Subroutine */ int lnkxsl_(integer *, integer *, integer *);
30 integer new__;
31
32 /* $ Abstract */
33
34 /* This routine locates the current location of an identifier */
35 /* within a list or finds a location within the list to */
36 /* store it and then does so. It returns the location of */
37 /* the identifier and a flag indicating whether or not the */
38 /* identifier was already present. */
39
40 /* $ Disclaimer */
41
42 /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
43 /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
44 /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
45 /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
46 /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
47 /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
48 /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
49 /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
50 /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
51 /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
52
53 /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
54 /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
55 /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
56 /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
57 /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
58 /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
59
60 /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
61 /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
62 /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
63 /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
64
65 /* $ Required_Reading */
66
67 /* None. */
68
69 /* $ Keywords */
70
71 /* UTILITY */
72
73 /* $ Declarations */
74 /* $ Brief_I/O */
75
76 /* VARIABLE I/O DESCRIPTION */
77 /* -------- --- -------------------------------------------------- */
78 /* ID I An array of integers that comprise an identifier */
79 /* IDSZ I The number of integer components per identifier */
80 /* LIST I/O A list of known identifiers */
81 /* POOL I/O A doubly linked list used for search the list */
82 /* AT I/O Location of the ID in the list */
83 /* PRESNT O If ID was already in the list TRUE otherwise FALSE */
84
85 /* $ Detailed_Input */
86
87 /* ID is an integer array that serves as an identifier */
88 /* for some object. For example it might be a SPICE */
89 /* id code for a planet or satellite; it might be the */
90 /* instrument id and mode of operation of an instrument. */
91 /* See the examples section for more details. */
92
93 /* IDSZ is the number of components in the array ID. */
94
95 /* LIST is an array containing several ID's. The array */
96 /* should be declared so as to have the same upper */
97 /* bound at least as large as the upper bound used */
98 /* in the declaration of POOL. */
99
100 /* POOL is a linked list pool that gives the search order */
101 /* for examining LIST to locate ID's. The declaration */
102 /* of POOL and LIST need to be compatible. Normally, */
103 /* the declaration should look like this: */
104
105 /* INTEGER LIST (IDSZ, LSTSIZ ) */
106 /* INTEGER POOL ( 2, LBPOOL: LSTSIZ ) */
107
108 /* If POOL is declared with the statement */
109
110 /* INTEGER POOL ( 2, LBPOOL: PSIZE ) */
111
112 /* then you must make sure that PSIZE is less than */
113 /* or equal to LSTSIZ. */
114
115 /* POOL should be initialized before the first */
116 /* call to this routine with the SPICE routine */
117 /* LNKINI. */
118
119 /* AT is a value that is set by this routine and that */
120 /* you should never reset yourself. It points */
121 /* to the head of the linked list used for */
122 /* searching LIST. Changing AT will destroy the */
123 /* link between POOL and LIST. */
124
125 /* There is one exception to these restrictions. */
126 /* The first call to this routine that occurs after */
127 /* initializing POOL, AT may have any value. It will */
128 /* be set upon output and from that time on, you should */
129 /* not alter its value except by calling this routine */
130 /* to do so. */
131
132 /* $ Detailed_Output */
133
134 /* AT on output AT points to the location in LIST */
135 /* of ID. */
136
137 /* PRESNT is a logical flag. It indicates whether or not */
138 /* ID was already present in the LIST when this */
139 /* routine was called. If ID was already in LIST */
140 /* PRESNT is returned with the value TRUE. Otherwise */
141 /* it is returned with the value FALSE. */
142
143 /* $ Parameters */
144
145 /* None. */
146
147 /* $ Files */
148
149 /* None. */
150
151 /* $ Exceptions */
152
153 /* 1) If the value of AT is less than zero or greater than */
154 /* the declared size of POOL (except immediately after */
155 /* initializing or re-initializing POOL) the */
156 /* error 'SPICE(ADDRESSOUTOFBOUNDS)' will be signalled. */
157
158 /* 2) If the linked list pool POOL is corrupted by a higher */
159 /* level routine, a diagnosis of the problem will be */
160 /* made by a routine called by this one. */
161
162 /* $ Particulars */
163
164 /* This routine serves as a utility for managing the bookkeeping */
165 /* needed when using a local buffering scheme which removes */
166 /* the last used item when the local buffer becomes full. */
167
168 /* It is primarily a programming utility. Unless you are dealing */
169 /* with a problem very similar to the one just described, you */
170 /* probably shouldn't be using this routine. */
171
172 /* The example below illustrates the intended use of this */
173 /* routine. */
174
175 /* $ Examples */
176
177 /* Consider the following programming situation. */
178
179 /* Suppose that a routine is being written that will */
180 /* access large amounts of data stored in the SPICE */
181 /* kernel pool. Kernel pool access requires overhead that */
182 /* may be prohibitive under some circumstances. Buffering */
183 /* data locally and only fetching data from the kernel pool */
184 /* when it has not been buffered locally, may substantially */
185 /* improve the performance of the routine being written. */
186
187 /* However, since FORTRAN does not allow dynamic memory allocation */
188 /* the local data storage must be set at compile time. As */
189 /* a result the local data buffer might become full during */
190 /* an execution of your program. If data for an item needs */
191 /* to be fetched from the kernel pool once the buffer has become */
192 /* full, you must either repeatedly call the kernel pool to fetch */
193 /* the new data or overwrite some of the data in your local buffer. */
194
195 /* This routine helps with the decisions of which items to */
196 /* overwrite. In addition it always moves the last requested */
197 /* item to the head of the index used for searching the buffered */
198 /* ID's. In this way if the same item is needed many times */
199 /* in succession, there will be very little overhead associated */
200 /* with finding the item. Thus the routine spends its time */
201 /* in computing the desired quantities, not in looking up the */
202 /* parameters needed for the computation. */
203
204 /* Below is a fragment of code that illustrates how this routine */
205 /* should be used. In the situation outlined above. We'll suppose */
206 /* that we are fetching MDLSIZ double precision numbers from the */
207 /* kernel pool that are associated with the item */
208
209 /* 'BODYid_MAGMODEL' */
210
211 /* And that we are computing something with this model data. */
212
213
214 /* INTEGER MDLSIZ */
215 /* PARAMETER ( MDLSIZ = xxxxxx ) */
216
217 /* We'll create room to buffer this data for 8 bodies. */
218
219
220 /* INTEGER PSIZE */
221 /* PARAMETER ( PSIZE = 8 ) */
222
223
224 /* The ID's we shall be using are 1-dimensional. They are body */
225 /* ID's for planets or and their satellites. */
226
227 /* INTEGER IDSZ */
228 /* PARAMETER ( IDSZ = 1 ) */
229
230 /* INTEGER AT */
231 /* INTEGER DIM */
232 /* INTEGER LIST ( IDSZ, PSIZE ) */
233 /* INTEGER POOL ( 2, LBPOOL:PSIZE ) */
234
235 /* DOUBLE PRECISION MAGMDL ( MDLSIZ, PSIZE ) */
236 /* DOUBLE PRECISION MODEL ( MDLSIZ ) */
237
238 /* LOGICAL FIRST */
239 /* LOGICAL PRESNT */
240
241 /* SAVE */
242
243 /* DATA FIRST / .TRUE. / */
244
245
246 /* The block below handles initializing the linked list pool. */
247
248 /* IF ( FIRST ) THEN */
249
250 /* FIRST = .FALSE. */
251
252 /* CALL LNKINI ( PSIZE, POOL ) */
253
254 /* END IF */
255
256 /* See if the data associated with ID has already been */
257 /* buffered. */
258
259 /* CALL LOCATI ( ID, IDSZ, LIST, POOL, AT, PRESNT ) */
260
261 /* IF ( .NOT. PRESNT ) THEN */
262
263 /* The data has not yet been buffered, look it up. Normally */
264 /* you might want to check to see if the data exists and */
265 /* handle things appropriately if it doesn't but this is just */
266 /* to give you the idea... */
267
268 /* CALL BODVCD ( ID, 'MAGMODEL', 3, DIM, MAGMDL ( 1, AT ) ) */
269
270 /* END IF */
271
272 /* Put the model data into the array MODEL for ease of */
273 /* reading the rest of the code. */
274
275 /* CALL MOVED ( MAGMDL(1,AT), MDLSIZ, MODEL ) */
276
277
278 /* Now do whatever processing is needed .... */
279
280 /* There are a few things to note about the code fragment above. */
281 /* First the handling of the buffering of data was very easy. */
282 /* Second, if this routine is called again using the same ID, */
283 /* the buffer will already contain the needed model. Moreover */
284 /* the routine LOCATI will return very quickly because the */
285 /* ID will already be at the head of the list indexed by POOL. */
286
287 /* You can also easily add an entry point to this routine that */
288 /* will force it to look up data from the kernel pool on the */
289 /* next call. All that needs to be done is re-initialize the */
290 /* linked list pool. */
291
292 /* ENTRY DOLOOK */
293
294 /* CALL LNKINI ( PSIZE, POOL ) */
295
296 /* $ Restrictions */
297
298 /* None. */
299
300 /* $ Author_and_Institution */
301
302 /* N.J. Bachman (JPL) */
303 /* W.L. Taber (JPL) */
304
305 /* $ Literature_References */
306
307 /* None. */
308
309 /* $ Version */
310
311 /* - SPICELIB Version 1.0.1, 24-OCT-2005 (NJB) */
312
313 /* Header update: changed reference to BODVAR to reference */
314 /* to BODVCD. */
315
316 /* - SPICELIB Version 1.0.0, 9-APR-1997 (WLT) */
317
318
319 /* -& */
320 /* $ Index_Entries */
321
322 /* Locate an item in a linked list indexed list of items */
323 /* Remove least recently used item buffering */
324
325 /* -& */
326
327 /* Spicelib functions */
328
329
330 /* Linked list parameters */
331
332
333 /* Local Variables. */
334
335 /* Parameter adjustments */
336 list_dim1 = *idsz;
337 list_offset = list_dim1 + 1;
338
339 /* Function Body */
340 chkin_("LOCATI", (ftnlen)6);
341
342 /* We begin by looking through the list of items at our disposal. */
343 /* One way or the other we will need the number of free nodes */
344 /* in the linked list. */
345
346 nfree = lnknfn_(pool);
347 psize = lnksiz_(pool);
348 if (nfree == psize) {
349
350 /* There's nothing in the list so far. Allocate a */
351 /* node and begin a list. */
352
353 lnkan_(pool, at);
354 i__1 = *idsz;
355 for (i__ = 1; i__ <= i__1; ++i__) {
356 list[i__ + *at * list_dim1 - list_offset] = id[i__ - 1];
357 }
358 *presnt = FALSE_;
359 chkout_("LOCATI", (ftnlen)6);
360 return 0;
361 }
362 if (*at <= 0 || *at > psize) {
363 setmsg_("The input value for the head of the ID address linked list "
364 "is out of bounds. It should be between 0 and #. The value su"
365 "pplied was #.", (ftnlen)132);
366 errint_("#", &psize, (ftnlen)1);
367 errint_("#", at, (ftnlen)1);
368 sigerr_("SPICE(ADDRESSOUTOFBOUNDS)", (ftnlen)25);
369 chkout_("LOCATI", (ftnlen)6);
370 return 0;
371 }
372
373 /* If we are still here then there is actually something in */
374 /* the list. We begin at start and traverse the list. */
375 /* Since we are unlikely to ever have large ID's (their purpose */
376 /* after all is to be a label for something more complex) we */
377 /* will handle the cases where IDSZ is 1 or 2 as special */
378 /* cases since the tests for equality are a lot easier. */
379
380 same = FALSE_;
381 head = *at;
382 if (*idsz == 1) {
383 same = id[0] == list[*at * list_dim1 + 1 - list_offset];
384 more = *at > 0 && ! same;
385 while(more) {
386 *at = pool[(*at << 1) + 10];
387 if (*at > 0) {
388 same = id[0] == list[*at * list_dim1 + 1 - list_offset];
389 more = ! same;
390 } else {
391 more = FALSE_;
392 }
393 }
394 } else if (*idsz == 2) {
395 same = id[0] == list[*at * list_dim1 + 1 - list_offset] && id[1] ==
396 list[*at * list_dim1 + 2 - list_offset];
397 more = *at > 0 && ! same;
398 while(more) {
399 *at = pool[(*at << 1) + 10];
400 if (*at > 0) {
401 if (id[0] == list[*at * list_dim1 + 1 - list_offset]) {
402 same = id[1] == list[*at * list_dim1 + 2 - list_offset];
403 more = ! same;
404 }
405 } else {
406 more = FALSE_;
407 }
408 }
409 } else {
410 i__ = 1;
411 same = TRUE_;
412 while(same && i__ < *idsz) {
413 same = same && id[i__ - 1] == list[i__ + *at * list_dim1 -
414 list_offset];
415 ++i__;
416 }
417 more = *at > 0 && ! same;
418 while(more) {
419 *at = pool[(*at << 1) + 10];
420 if (*at > 0) {
421 i__ = 1;
422 same = TRUE_;
423 while(same && i__ < *idsz) {
424 same = same && id[i__ - 1] == list[i__ + *at * list_dim1
425 - list_offset];
426 ++i__;
427 }
428 more = ! same;
429 } else {
430 more = FALSE_;
431 }
432 }
433 }
434
435 /* The hunting is over either we found it or we need to */
436 /* allocate space to put this ID into storage. */
437
438 if (same) {
439 *presnt = TRUE_;
440 last = pool[(*at << 1) + 11];
441
442 /* If AT is not already at the head of the list, we */
443 /* move this node to the front of the list. */
444
445 if (last > 0) {
446 lnkxsl_(at, at, pool);
447 lnkilb_(at, &head, pool);
448 }
449 chkout_("LOCATI", (ftnlen)6);
450 return 0;
451 }
452
453 /* If we got to this point, we traversed the entire linked */
454 /* list and did not find a matching ID. AT is negative */
455 /* and -AT points to the head of the list. */
456
457 *presnt = FALSE_;
458
459 /* We'll put it in the list. First see if there are any free nodes. */
460
461 if (nfree > 0) {
462
463 /* Allocate a free node and put our ID at the NEW address. */
464
465 lnkan_(pool, &new__);
466 i__1 = *idsz;
467 for (i__ = 1; i__ <= i__1; ++i__) {
468 list[i__ + new__ * list_dim1 - list_offset] = id[i__ - 1];
469 }
470
471 /* Put the new node at the head of the linked list. */
472
473 lnkilb_(&new__, &head, pool);
474 *at = new__;
475 } else {
476
477 /* The last item in the list is pointed to as being the */
478 /* previous item to the head of the list. But we have to */
479 /* change the sign to get a legitimate address. Overwrite */
480 /* the ID information in this last slot of the list. */
481
482 last = -pool[(head << 1) + 11];
483 i__1 = *idsz;
484 for (i__ = 1; i__ <= i__1; ++i__) {
485 list[i__ + last * list_dim1 - list_offset] = id[i__ - 1];
486 }
487
488 /* Extract the last item as a sublist and insert it before */
489 /* the current head of the list. */
490
491 lnkxsl_(&last, &last, pool);
492 lnkilb_(&last, &head, pool);
493 *at = last;
494 }
495 chkout_("LOCATI", (ftnlen)6);
496 return 0;
497 } /* locati_ */
498
499