1 /* dafrrr.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 static integer c__128 = 128;
12
13 /* $Procedure DAFRRR ( DAF, remove reserved records ) */
dafrrr_(integer * handle,integer * resv)14 /* Subroutine */ int dafrrr_(integer *handle, integer *resv)
15 {
16 /* System generated locals */
17 integer i__1, i__2;
18
19 /* Builtin functions */
20 integer s_rnge(char *, integer, char *, integer);
21
22 /* Local variables */
23 char crec[1000];
24 doublereal drec[128];
25 integer decr, free, word, next;
26 extern /* Subroutine */ int dafgs_(doublereal *), chkin_(char *, ftnlen),
27 dafps_(integer *, integer *, doublereal *, integer *, doublereal *
28 );
29 integer bward;
30 extern /* Subroutine */ int dafus_(doublereal *, integer *, integer *,
31 doublereal *, integer *);
32 integer fward;
33 extern /* Subroutine */ int dafws_(doublereal *);
34 integer recno;
35 logical found;
36 doublereal dc[125];
37 integer ic[250];
38 extern /* Subroutine */ int daffna_(logical *);
39 integer nd;
40 extern logical failed_(void);
41 extern /* Subroutine */ int dafbfs_(integer *);
42 integer begblk, ni;
43 extern /* Subroutine */ int dafsih_(integer *, char *, ftnlen);
44 char ifname[60];
45 integer endblk;
46 extern /* Subroutine */ int dafrcr_(integer *, integer *, char *, ftnlen),
47 dafrdr_(integer *, integer *, integer *, integer *, doublereal *,
48 logical *), dafrfr_(integer *, integer *, integer *, char *,
49 integer *, integer *, integer *, ftnlen), dafarw_(integer *,
50 integer *, integer *), dafwcr_(integer *, integer *, char *,
51 ftnlen), dafwdr_(integer *, integer *, doublereal *), dafwfr_(
52 integer *, integer *, integer *, char *, integer *, integer *,
53 integer *, ftnlen);
54 integer remove;
55 extern /* Subroutine */ int chkout_(char *, ftnlen);
56 extern logical return_(void);
57 doublereal sum[125];
58
59 /* $ Abstract */
60
61 /* Remove a specified number of reserved records from a Double */
62 /* Precision Array File (DAF). */
63
64 /* $ Disclaimer */
65
66 /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
67 /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
68 /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
69 /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
70 /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
71 /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
72 /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
73 /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
74 /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
75 /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
76
77 /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
78 /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
79 /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
80 /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
81 /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
82 /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
83
84 /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
85 /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
86 /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
87 /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
88
89 /* $ Required_Reading */
90
91 /* DAF */
92
93 /* $ Keywords */
94
95 /* FILES */
96
97 /* $ Declarations */
98 /* $ Brief_I/O */
99
100 /* Variable I/O Description */
101 /* -------- --- -------------------------------------------------- */
102 /* HANDLE I DAF, opened for writing. */
103 /* RESV I Number of records to remove. */
104
105 /* $ Detailed_Input */
106
107 /* HANDLE is the handle associated with a DAF that has been */
108 /* opened with write access. */
109
110 /* RESV is the number of reserved records to be removed */
111 /* from the specified file. */
112
113 /* $ Detailed_Output */
114
115 /* None. */
116
117 /* $ Parameters */
118
119 /* None. */
120
121 /* $ Exceptions */
122
123 /* 1) If RESV is less than one, the file is not changed. */
124
125 /* 2) If RESV is greater than the number of reserved records in the */
126 /* file, all of the reserved records are removed. */
127
128 /* $ Files */
129
130 /* See argument HANDLE. */
131
132 /* $ Particulars */
133
134 /* Normally, the reserved records in an array file are reserved */
135 /* when the file is created. However, it may occasionally become */
136 /* desirable to remove reserved records---when their contents are */
137 /* significantly reduced, for example. */
138
139 /* The records nearest the end of the file are removed. Note */
140 /* that the physical size of the file is not reduced when reserved */
141 /* records are removed. */
142
143 /* $ Examples */
144
145 /* For the following call to DAFRRR, assume that HANDLE is the file */
146 /* handle for a DAF file that has been opened for write access, and */
147 /* that the DAF file already contains 12 reserved records (located in */
148 /* records 2-13 of the physical file). */
149
150 /* CALL DAFRRR ( HANDLE, 7 ) */
151
152 /* After this call to DAFRRR, the number of reserved records has been */
153 /* decreased by 7, leaving only the first five of the original */
154 /* reserved records, physical records 2-6. */
155
156 /* $ Restrictions */
157
158 /* 1) This routine will only remove reserve records from DAFs open */
159 /* for write. These files are implicitly of the native binary */
160 /* file format. */
161
162 /* $ Literature_References */
163
164 /* None. */
165
166 /* $ Author_and_Institution */
167
168 /* K.R. Gehringer (JPL) */
169 /* I.M. Underwood (JPL) */
170
171 /* $ Version */
172
173 /* - SPICELIB Version 1.2.0, 16-NOV-2001 (FST) */
174
175 /* Added a call to DAFSIH to prevent this routine from */
176 /* attempting to write to non-native binary file formats. */
177 /* This will provide a more useful error diagnostic with */
178 /* little impact on performance. */
179
180 /* - SPICELIB Version 1.1.0, 30-SEP-1993 (KRG) */
181
182 /* Detailed_Input and Examples section of the header were */
183 /* modified. */
184
185 /* Added calls to the FORTRAN intrinsic functions INT and */
186 /* DBLE in the code that updates the summary record. */
187
188 /* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
189
190 /* Comment section for permuted index source lines was added */
191 /* following the header. */
192
193 /* - SPICELIB Version 1.0.0, 18-JUL-1990 (IMU) */
194
195 /* -& */
196 /* $ Index_Entries */
197
198 /* remove daf reserved records */
199
200 /* -& */
201 /* $ Revisions */
202
203 /* - SPICELIB Version 1.1.0, 30-SEP-1993 (KRG) */
204
205 /* $ Detailed_Input section was modified. References to any */
206 /* specific routines by name as a method for opening a DAF file */
207 /* for write access were removed. The assumption is that a person */
208 /* using DAF files would already know something about opening and */
209 /* closing the files. */
210
211 /* $ Examples section was modified. References to any specific */
212 /* routines by name as a method for opening a DAF file for writing */
213 /* were removed, and the example was reworded in such a way that */
214 /* the use of the subroutine remained clear. */
215
216 /* Added calls to the INT intrinsic function to convert a DP */
217 /* number to an integer before assigning it to NEXT or ENDBLK, */
218 /* both of which are integer variables. Also added calls to INT */
219 /* in IF statements where comparisons were made between DP numbers */
220 /* and INTEGERs, when integral values were actually being */
221 /* compared. */
222
223 /* Added calls to the intrinsic function DBLE to convert an */
224 /* integer, REMOVE, into a DP number when doing some arithmetic. */
225
226 /* -& */
227
228 /* SPICELIB functions */
229
230
231 /* Local parameters */
232
233 /* IFNLEN is the length of a DAF internal file name. */
234
235
236 /* WPR is the maximum number of double precision */
237 /* numbers per record. WPR stands for words */
238 /* per record. */
239
240
241 /* MAXD, are the maximum number of double precision */
242 /* MAXI, numbers, integers, and characters, respectively, */
243 /* MAXC not including space reserved for control information. */
244
245
246 /* Local variables */
247
248
249 /* Standard SPICE error handling. */
250
251 if (return_()) {
252 return 0;
253 } else {
254 chkin_("DAFRRR", (ftnlen)6);
255 }
256
257 /* Before proceeding any further, check that the DAF associated */
258 /* with HANDLE is available for write access. */
259
260 dafsih_(handle, "WRITE", (ftnlen)5);
261 if (failed_()) {
262 chkout_("DAFRRR", (ftnlen)6);
263 return 0;
264 }
265
266 /* Get the contents of the file record. If it fails, then just check */
267 /* out and return, as an appropriate error message should have */
268 /* already been set. */
269
270 dafrfr_(handle, &nd, &ni, ifname, &fward, &bward, &free, (ftnlen)60);
271 if (failed_()) {
272 chkout_("DAFRRR", (ftnlen)6);
273 return 0;
274 }
275
276 /* Don't remove more than the current number of reserved records! */
277 /* If there are none, check out. */
278
279 /* Computing MIN */
280 i__1 = *resv, i__2 = fward - 2;
281 remove = min(i__1,i__2);
282 if (remove < 1) {
283 chkout_("DAFRRR", (ftnlen)6);
284 return 0;
285 }
286
287 /* Okay, here's the plan. We are just going to move records */
288 /* forward, starting with the first summary record in the file */
289 /* and ending with the last data record. */
290
291 /* After everything has been moved, the initial and final */
292 /* addresses of all the arrays have to be decremented by the */
293 /* same amount: the number of words per record (128) times */
294 /* the number of records removed. */
295
296 decr = remove << 7;
297
298 /* Records will be moved in `blocks', where each block contains */
299
300 /* -- a summary record */
301
302 /* -- a name record */
303
304 /* -- one or more data records */
305
306 /* Most blocks lie between one summary record and the next. */
307 /* The final block lies between the final summary record and */
308 /* whatever data record contains the first free address. */
309
310 /* BEGBLK is initially the first summary record location. */
311
312 begblk = fward;
313 while(begblk > 0 && ! failed_()) {
314
315 /* Move the summary record first. The location of the next */
316 /* summary record determines the end of this block, and the */
317 /* beginning of the next. */
318
319 /* Be sure to adjust the forward and backward pointers; */
320 /* otherwise, we won't be able to find the summaries again. */
321
322 recno = begblk;
323 dafrdr_(handle, &recno, &c__1, &c__128, drec, &found);
324 if ((integer) drec[0] > 0) {
325 endblk = (integer) drec[0] - 1;
326 next = (integer) drec[0];
327 } else {
328 dafarw_(&free, &endblk, &word);
329 next = 0;
330 }
331 if ((integer) drec[0] > 0) {
332 drec[0] -= (doublereal) remove;
333 }
334 if ((integer) drec[1] > 0) {
335 drec[1] -= (doublereal) remove;
336 }
337 i__1 = recno - remove;
338 dafwdr_(handle, &i__1, drec);
339
340 /* Then the name record. */
341
342 recno = begblk + 1;
343 dafrcr_(handle, &recno, crec, (ftnlen)1000);
344 i__1 = recno - remove;
345 dafwcr_(handle, &i__1, crec, (ftnlen)1000);
346
347 /* Finally, the data records. */
348
349 i__1 = endblk;
350 for (recno = begblk + 2; recno <= i__1; ++recno) {
351 dafrdr_(handle, &recno, &c__1, &c__128, drec, &found);
352 i__2 = recno - remove;
353 dafwdr_(handle, &i__2, drec);
354 }
355
356 /* Start the next block, if one exists. */
357
358 begblk = next;
359 }
360
361 /* Rewrite the file record, to reflect the new organization of */
362 /* the file. */
363
364 fward -= remove;
365 bward -= remove;
366 free -= decr;
367 dafwfr_(handle, &nd, &ni, ifname, &fward, &bward, &free, (ftnlen)60);
368
369 /* Get the summary for each array, decrement the addresses (stored */
370 /* in the final two integer components), and replace the summary. */
371
372 dafbfs_(handle);
373 daffna_(&found);
374 while(found && ! failed_()) {
375 dafgs_(sum);
376 dafus_(sum, &nd, &ni, dc, ic);
377 ic[(i__1 = ni - 2) < 250 && 0 <= i__1 ? i__1 : s_rnge("ic", i__1,
378 "dafrrr_", (ftnlen)393)] = ic[(i__2 = ni - 2) < 250 && 0 <=
379 i__2 ? i__2 : s_rnge("ic", i__2, "dafrrr_", (ftnlen)393)] -
380 decr;
381 ic[(i__1 = ni - 1) < 250 && 0 <= i__1 ? i__1 : s_rnge("ic", i__1,
382 "dafrrr_", (ftnlen)394)] = ic[(i__2 = ni - 1) < 250 && 0 <=
383 i__2 ? i__2 : s_rnge("ic", i__2, "dafrrr_", (ftnlen)394)] -
384 decr;
385 dafps_(&nd, &ni, dc, ic, sum);
386 dafws_(sum);
387 daffna_(&found);
388 }
389 chkout_("DAFRRR", (ftnlen)6);
390 return 0;
391 } /* dafrrr_ */
392
393