1 /* dassdr.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__4 = 4;
11 static integer c__3 = 3;
12 static integer c__1 = 1;
13 static integer c__256 = 256;
14 static integer c__0 = 0;
15
16 /* $Procedure DASSDR ( DAS, segregate data records ) */
dassdr_(integer * handle)17 /* Subroutine */ int dassdr_(integer *handle)
18 {
19 /* Initialized data */
20
21 static integer next[3] = { 2,3,1 };
22 static integer prev[3] = { 3,1,2 };
23
24 /* System generated locals */
25 integer i__1, i__2, i__3;
26
27 /* Builtin functions */
28 integer s_rnge(char *, integer, char *, integer);
29
30 /* Local variables */
31 integer base;
32 char crec[1024];
33 doublereal drec[128];
34 integer free, irec[256], lrec, dest;
35 logical more;
36 integer unit, type__, i__, j, n;
37 extern /* Subroutine */ int chkin_(char *, ftnlen);
38 integer ncomc;
39 extern /* Subroutine */ int maxai_(integer *, integer *, integer *,
40 integer *);
41 char savec[1024];
42 doublereal saved[128];
43 integer recno, savei[256];
44 extern integer sumai_(integer *, integer *);
45 integer ncomr, total, lword, count[4], ltype, start;
46 extern logical failed_(void);
47 extern /* Subroutine */ int dasadi_(integer *, integer *, integer *),
48 cleari_(integer *, integer *);
49 integer drbase;
50 extern /* Subroutine */ int dasioc_(char *, integer *, integer *, char *,
51 ftnlen, ftnlen), dasiod_(char *, integer *, integer *, doublereal
52 *, ftnlen), dasllc_(integer *), dasrdi_(integer *, integer *,
53 integer *, integer *), dashfs_(integer *, integer *, integer *,
54 integer *, integer *, integer *, integer *, integer *, integer *),
55 dasudi_(integer *, integer *, integer *, integer *);
56 integer minadr, maxadr, scrhan, lastla[3];
57 extern /* Subroutine */ int dassih_(integer *, char *, ftnlen), dashlu_(
58 integer *, integer *), daswbr_(integer *), dasrri_(integer *,
59 integer *, integer *, integer *, integer *);
60 integer offset;
61 extern /* Subroutine */ int dasioi_(char *, integer *, integer *, integer
62 *, ftnlen);
63 integer lastrc[3];
64 extern /* Subroutine */ int dasops_(integer *), dasufs_(integer *,
65 integer *, integer *, integer *, integer *, integer *, integer *,
66 integer *, integer *), chkout_(char *, ftnlen);
67 integer lastwd[3], nresvc;
68 extern logical return_(void);
69 integer nresvr, savtyp, prvtyp, loc, pos;
70
71 /* $ Abstract */
72
73 /* Segregate the data records in a DAS file into clusters, using */
74 /* one cluster per data type present in the file. */
75
76 /* $ Disclaimer */
77
78 /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
79 /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
80 /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
81 /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
82 /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
83 /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
84 /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
85 /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
86 /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
87 /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
88
89 /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
90 /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
91 /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
92 /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
93 /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
94 /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
95
96 /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
97 /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
98 /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
99 /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
100
101 /* $ Required_Reading */
102
103 /* DAS */
104
105 /* $ Keywords */
106
107 /* DAS */
108 /* FILES */
109 /* ORDER */
110 /* SORT */
111
112 /* $ Declarations */
113 /* $ Brief_I/O */
114
115 /* Variable I/O Description */
116 /* -------- --- -------------------------------------------------- */
117 /* HANDLE I DAS file handle. */
118
119 /* $ Detailed_Input */
120
121 /* HANDLE is a file handle of a DAS file opened for writing. */
122
123 /* $ Detailed_Output */
124
125 /* None. See $Particulars for a description of the effect of this */
126 /* routine. */
127
128 /* $ Parameters */
129
130 /* None. */
131
132 /* $ Exceptions */
133
134 /* 1) If the input file handle is invalid, the error will be */
135 /* diagnosed by routines called by this routine. */
136
137 /* 2) If a Fortran read attempted by this routine fails, the */
138 /* error will be diagnosed by routines called by this routine. */
139 /* The state of the DAS file undergoing re-ordering will be */
140 /* indeterminate. */
141
142 /* 3) If a Fortran write attempted by this routine fails, the */
143 /* error will be diagnosed by routines called by this routine. */
144 /* The state of the DAS file undergoing re-ordering will be */
145 /* indeterminate. */
146
147 /* 4) If any other I/O error occurs during the re-arrangement of */
148 /* the records in the indicated DAS file, the error will be */
149 /* diagnosed by routines called by this routine. */
150
151 /* $ Files */
152
153 /* See the description of the argument HANDLE in $Detailed_Input. */
154
155 /* $ Particulars */
156
157 /* Normally, there should be no need for routines outside of */
158 /* SPICELIB to call this routine. */
159
160 /* The effect of this routine is to re-arrange the data records */
161 /* in a DAS file so that the file contains a single cluster for */
162 /* each data type present in the file: in the general case, there */
163 /* will be a single cluster of each of the integer, double */
164 /* precision, and character data types. */
165
166 /* The relative order of data records of a given type is not */
167 /* affected by this re-ordering. After the re-ordering, the DAS */
168 /* file contains a single directory record that has one descriptor */
169 /* for each cluster. After that point, the order in the file of the */
170 /* sets of data records of the various data types will be: */
171
172 /* +-------+ */
173 /* | CHAR | */
174 /* +-------+ */
175 /* | DP | */
176 /* +-------+ */
177 /* | INT | */
178 /* +-------+ */
179
180 /* Files that contain multiple directory records will have all but */
181 /* the first directory record moved to the end of the file when the */
182 /* re-ordering is complete. These records are not visible to the */
183 /* DAS system and will be overwritten if data is subsequently added */
184 /* to the DAS file. */
185
186 /* The purpose of segregating a DAS file's data records into three */
187 /* clusters is to make read access more efficient: when a DAS file */
188 /* contains a single directory with at most three cluster type */
189 /* descriptors, mapping logical to physical addresses can be done */
190 /* in constant time. */
191
192 /* $ Examples */
193
194 /* 1) Segregate data records in a DAS file designated by */
195 /* HANDLE: */
196
197 /* CALL DASSDR ( HANDLE ) */
198
199 /* $ Restrictions */
200
201 /* None. */
202
203 /* $ Literature_References */
204
205 /* None. */
206
207 /* $ Author_and_Institution */
208
209 /* K.R. Gehringer (JPL) */
210 /* N.J. Bachman (JPL) */
211 /* W.L. Taber (JPL) */
212
213 /* $ Version */
214
215 /* - SPICELIB Version 2.0.1 19-DEC-1995 (NJB) */
216
217 /* Corrected title of permuted index entry section. */
218
219 /* - EKLIB Version 2.0.0, 17-NOV-1993 (KRG) */
220
221 /* Added test of FAILED after each DAS call, or sequence of calls, */
222 /* which returns immediately if FAILED is true. This fixes a bug */
223 /* where DASOPS signals an error and then DASSDR has a */
224 /* segmentation fault. */
225
226 /* Removed references to specific DAS file open routines in the */
227 /* $ Detailed_Input section of the header. This was done in order */
228 /* to minimize documentation changes if the DAS open routines ever */
229 /* change. */
230
231 /* - EKLIB Version 1.2.0, 07-OCT-1993 (NJB) (HAN) (MJS) */
232
233 /* Bug fix: call to CLEARD replaced with call to */
234 /* CLEARI. */
235
236 /* - EKLIB Version 1.1.0, 08-JUL-1993 (NJB) (MJS) */
237
238 /* Bug fix: extraneous commas removed from argument lists */
239 /* in calls to DASADI. */
240
241 /* - SPICELIB Version 1.0.0, 11-NOV-1992 (NJB) (WLT) */
242
243 /* -& */
244 /* $ Index_Entries */
245
246 /* segregate the data records in a DAS file */
247
248 /* -& */
249 /* $ Revisions */
250
251 /* - EKLIB Version 2.0.0, 17-NOV-1993 (KRG) */
252
253 /* Added test of failed after each DAS call, or sequence of calls, */
254 /* which returns immediately if FAILED is true. This fixes a bug */
255 /* where DASOPS signals an error and then DASSDR has a */
256 /* segmentation fault. */
257
258 /* Removed references to specific DAS file open routines in the */
259 /* $ Detailed_Input section of the header. This was done in order */
260 /* to minimize documentation changes if the DAS open routines ever */
261 /* change. */
262
263 /* - EKLIB Version 1.2.0, 07-OCT-1993 (NJB) (HAN) (MJS) */
264
265 /* Bug fix: call to CLEARD replaced with call to */
266 /* CLEARI. */
267
268 /* - EKLIB Version 1.1.0, 08-JUL-1993 (NJB) */
269
270 /* Bug fix: extraneous commas removed from argument lists */
271 /* in calls to DASADI. This bug had no visible effect on */
272 /* VAX and Sun systems, but generated a compile error under */
273 /* Lahey Fortran. */
274
275 /* -& */
276
277 /* SPICELIB functions */
278
279
280 /* Local parameters */
281
282
283 /* Data type parameters */
284
285
286 /* Directory pointer locations (backward and forward): */
287
288
289 /* Directory address range location base */
290
291
292 /* Location of first type descriptor */
293
294
295 /* Local variables */
296
297
298 /* Saved variables */
299
300
301 /* NEXT and PREV map the DAS data type codes to their */
302 /* successors and predecessors, respectively. */
303
304
305 /* Initial values */
306
307
308 /* Standard SPICE error handling. */
309
310 if (return_()) {
311 return 0;
312 } else {
313 chkin_("DASSDR", (ftnlen)6);
314 }
315
316 /* Before starting, make sure that this DAS file is open for */
317 /* writing. */
318
319 dassih_(handle, "WRITE", (ftnlen)5);
320
321 /* Get the logical unit for this file. */
322
323 dashlu_(handle, &unit);
324 if (failed_()) {
325 chkout_("DASSDR", (ftnlen)6);
326 return 0;
327 }
328
329 /* Write out any buffered records that belong to the file. */
330
331 daswbr_(handle);
332 if (failed_()) {
333 chkout_("DASSDR", (ftnlen)6);
334 return 0;
335 }
336
337 /* We're going to re-order the physical records in the DAS file, */
338 /* starting with the first record after the first directory. */
339 /* The other directory records are moved to the end of the file */
340 /* as a result of the re-ordering. */
341
342 /* The re-ordering algorithm is based on that used in the REORDx */
343 /* routines. To use this algorithm, we'll build an order vector */
344 /* for the records to be ordered; we'll construct this order vector */
345 /* in a scratch DAS file. First, we'll traverse the directories */
346 /* to build up a sort of inverse order vector that tells us the */
347 /* final destination and data type of each data record; from this */
348 /* inverse vector we can easily build a true order vector. The */
349 /* cycles of the true order vector can be traversed without */
350 /* repetitive searching, and with a minimum of assignment of the */
351 /* contents of data records to temporary variables. */
352
353
354 /* Allocate a scratch DAS file to keep our vectors in. */
355
356 dasops_(&scrhan);
357 if (failed_()) {
358 chkout_("DASSDR", (ftnlen)6);
359 return 0;
360 }
361
362 /* Now build up our `inverse order vector'. This array is an */
363 /* inverse order vector only in loose sense: it actually consists */
364 /* of an integer array that contains a sequence of pairs of integers, */
365 /* the first of which indicates a data type, and the second of which */
366 /* is an ordinal number. There is one pair for each data record in */
367 /* the file. The ordinal number gives the ordinal position of the */
368 /* record described by the number pair, relative to the other records */
369 /* of the same type. Directory records are considered to have type */
370 /* `directory', which is represented by the code DIR. */
371
372 /* We also must maintain a count of records of each type. */
373
374 cleari_(&c__4, count);
375
376 /* Get the file summary for the DAS file to be segregated. */
377
378 dashfs_(handle, &nresvr, &nresvc, &ncomr, &ncomc, &free, lastla, lastrc,
379 lastwd);
380 if (failed_()) {
381 chkout_("DASSDR", (ftnlen)6);
382 return 0;
383 }
384
385 /* Find the record and word positions LREC and LWORD of the last */
386 /* descriptor in the file, and also find the type of the descriptor */
387 /* LTYPE. */
388
389 maxai_(lastrc, &c__3, &lrec, &loc);
390 lword = 0;
391 for (i__ = 1; i__ <= 3; ++i__) {
392 if (lastrc[(i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("lastrc",
393 i__1, "dassdr_", (ftnlen)451)] == lrec && lastwd[(i__2 = i__
394 - 1) < 3 && 0 <= i__2 ? i__2 : s_rnge("lastwd", i__2, "dassd"
395 "r_", (ftnlen)451)] > lword) {
396 lword = lastwd[(i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
397 "lastwd", i__1, "dassdr_", (ftnlen)454)];
398 ltype = i__;
399 }
400 }
401
402 /* The first directory starts after the last comment record. */
403
404 recno = nresvr + ncomr + 2;
405 while(recno <= lrec && recno > 0) {
406
407 /* Read the directory record. */
408
409 dasrri_(handle, &recno, &c__1, &c__256, irec);
410 if (failed_()) {
411 chkout_("DASSDR", (ftnlen)6);
412 return 0;
413 }
414
415 /* Increment the directory count. */
416
417 ++count[3];
418
419 /* Add the data type (`directory') and count (1) of the current */
420 /* record to the inverse order vector. */
421
422 dasadi_(&scrhan, &c__1, &c__4);
423 dasadi_(&scrhan, &c__1, &count[3]);
424 if (failed_()) {
425 chkout_("DASSDR", (ftnlen)6);
426 return 0;
427 }
428
429 /* Set up our `finite state machine' that tells us the data */
430 /* types of the records described by the last read directory. */
431
432 type__ = irec[8];
433 prvtyp = prev[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
434 "prev", i__1, "dassdr_", (ftnlen)498)];
435
436 /* Now traverse the directory and update the inverse order */
437 /* vector based on the descriptors we find. */
438
439 more = TRUE_;
440 i__ = 10;
441 while(more) {
442
443 /* Obtain the count for the current descriptor. */
444
445 n = (i__2 = irec[(i__1 = i__ - 1) < 256 && 0 <= i__1 ? i__1 :
446 s_rnge("irec", i__1, "dassdr_", (ftnlen)512)], abs(i__2));
447
448 /* Update our inverse order vector to describe the positions */
449 /* of the N records described by the current descriptor. */
450
451 i__1 = n;
452 for (j = 1; j <= i__1; ++j) {
453 dasadi_(&scrhan, &c__1, &type__);
454 i__3 = count[(i__2 = type__ - 1) < 4 && 0 <= i__2 ? i__2 :
455 s_rnge("count", i__2, "dassdr_", (ftnlen)521)] + j;
456 dasadi_(&scrhan, &c__1, &i__3);
457 if (failed_()) {
458 chkout_("DASSDR", (ftnlen)6);
459 return 0;
460 }
461 }
462
463 /* Adjust the count of records of data type TYPE. */
464
465 count[(i__1 = type__ - 1) < 4 && 0 <= i__1 ? i__1 : s_rnge("count"
466 , i__1, "dassdr_", (ftnlen)533)] = count[(i__2 = type__ -
467 1) < 4 && 0 <= i__2 ? i__2 : s_rnge("count", i__2, "dass"
468 "dr_", (ftnlen)533)] + n;
469
470 /* Find the next type. */
471
472 ++i__;
473 if (i__ > 256 || recno == lrec && i__ > lword) {
474 more = FALSE_;
475 } else {
476 if (irec[(i__1 = i__ - 1) < 256 && 0 <= i__1 ? i__1 : s_rnge(
477 "irec", i__1, "dassdr_", (ftnlen)547)] > 0) {
478 type__ = next[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1
479 : s_rnge("next", i__1, "dassdr_", (ftnlen)548)];
480 } else if (irec[(i__1 = i__ - 1) < 256 && 0 <= i__1 ? i__1 :
481 s_rnge("irec", i__1, "dassdr_", (ftnlen)550)] < 0) {
482 type__ = prev[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1
483 : s_rnge("prev", i__1, "dassdr_", (ftnlen)551)];
484 } else {
485 more = FALSE_;
486 }
487 }
488 }
489
490 /* The forward pointer in this directory tells us where the */
491 /* next directory record is. When there are no more directory */
492 /* records, this pointer will be zero. */
493
494 recno = irec[1];
495 }
496
497 /* At this point, the inverse order vector is set up. The array */
498 /* COUNT contains counts of the number of records of each type we've */
499 /* seen. Set TOTAL to the total number of records that we've going */
500 /* to permute. */
501
502 total = sumai_(count, &c__4);
503
504 /* The next step is to build a true order vector. Let BASE be */
505 /* the base address for the order vector; this address is the */
506 /* last logical address of the inverse order vector. */
507
508 base = total << 1;
509
510 /* We'll store the actual order vector in locations BASE + 1 */
511 /* through BASE + TOTAL. In addition, we'll build a parallel array */
512 /* that contains, for each element of the order vector, the type of */
513 /* data corresponding to that element. This type vector will */
514 /* reside in locations BASE + TOTAL + 1 through BASE + 2*TOTAL. */
515
516 /* Before setting the values of the order vector and its parallel */
517 /* type vector, we'll allocate space in the scratch DAS file by */
518 /* zeroing out the locations we plan to use. After this, locations */
519 /* BASE+1 through BASE + 2*TOTAL can be written to in random access */
520 /* fashion using DASUDI. */
521
522
523 i__1 = total << 1;
524 for (i__ = 1; i__ <= i__1; ++i__) {
525 dasadi_(&scrhan, &c__1, &c__0);
526 }
527 if (failed_()) {
528 chkout_("DASSDR", (ftnlen)6);
529 return 0;
530 }
531
532 /* We note that the way to construct the inverse of a permutation */
533 /* SIGMA in a single loop is suggested by the relation */
534
535 /* -1 */
536 /* SIGMA ( SIGMA(I) ) = I */
537
538 /* We'll use this method. In our case, our order vector plays */
539 /* the role of */
540
541 /* -1 */
542 /* SIGMA */
543
544 /* and the `inverse order vector' plays the role of SIGMA. We'll */
545 /* exclude the first directory from the order vector, since it's */
546 /* an exception: we wish to reserve this record. Since the first */
547 /* element of the order vector (logically) contains the index 1, we */
548 /* can ignore it. */
549
550
551 i__1 = total;
552 for (i__ = 2; i__ <= i__1; ++i__) {
553 i__2 = (i__ << 1) - 1;
554 i__3 = (i__ << 1) - 1;
555 dasrdi_(&scrhan, &i__2, &i__3, &type__);
556 i__2 = i__ << 1;
557 i__3 = i__ << 1;
558 dasrdi_(&scrhan, &i__2, &i__3, &dest);
559 if (failed_()) {
560 chkout_("DASSDR", (ftnlen)6);
561 return 0;
562 }
563
564 /* Set DEST to the destination location, measured as an offset */
565 /* from the last comment record, of the Ith record by adding */
566 /* on the count of the predecessors of the block of records of */
567 /* TYPE. */
568
569 for (j = 1; j <= 3; ++j) {
570 if (type__ > j) {
571 dest += count[(i__2 = j - 1) < 4 && 0 <= i__2 ? i__2 : s_rnge(
572 "count", i__2, "dassdr_", (ftnlen)648)];
573 }
574 }
575
576 /* The destination offset of each record should be incremented to */
577 /* allow room for the first directory record. However, we don't */
578 /* need to do this for directory records; they'll already have */
579 /* this offset accounted for. */
580
581 if (type__ != 4) {
582 ++dest;
583 }
584
585 /* The value of element DEST of the order vector is I. */
586 /* Write this value to location BASE + DEST. */
587
588 i__2 = base + dest;
589 i__3 = base + dest;
590 dasudi_(&scrhan, &i__2, &i__3, &i__);
591
592 /* We want the ith element of the order vector to give us the */
593 /* number of the record to move to position i (offset from the */
594 /* last comment record), but we want the corresponding element */
595 /* of the type array to give us the type of the record currently */
596 /* occupying position i. */
597
598 i__2 = base + i__ + total;
599 i__3 = base + i__ + total;
600 dasudi_(&scrhan, &i__2, &i__3, &type__);
601 if (failed_()) {
602 chkout_("DASSDR", (ftnlen)6);
603 return 0;
604 }
605 }
606
607 /* Ok, here's what we've got in the scratch file that's still of */
608 /* interest: */
609
610 /* -- In integer logical addresses BASE + 1 : BASE + TOTAL, */
611 /* we have an order vector. The Ith element of this */
612 /* vector indicates the record that should be moved to */
613 /* location DRBASE + I in the DAS file we're re-ordering, */
614 /* where DRBASE is the base address of the data records */
615 /* (the first directory record follows the record having this */
616 /* index). */
617
618
619 /* -- In integer logical addresses BASE + TOTAL + 1 : BASE + */
620 /* 2*TOTAL, we have data type indicators for the records to */
621 /* be re-ordered. The type for the Ith record in the file, */
622 /* counted from the last comment record, is located in logical */
623 /* address BASE + TOTAL + I. */
624
625
626 drbase = nresvr + ncomr + 1;
627
628 /* As we traverse the order vector, we flip the sign of elements */
629 /* we've accessed, so that we can tell when we encounter an element */
630 /* of a cycle that we've already traversed. */
631
632 /* Traverse the order vector. The variable START indicates the */
633 /* first element to look at. Ignore the first element; it's a */
634 /* singleton cycle. */
635
636
637 start = 2;
638 while(start < total) {
639
640 /* Traverse the current cycle of the order vector. */
641
642 /* We `make a hole' in the file by saving the record in position */
643 /* START, then we traverse the cycle in reverse order, filling in */
644 /* the hole at the ith position with the record whose number is */
645 /* the ith element of the order vector. At the end, we deposit */
646 /* the saved record into the `hole' left behind by the last */
647 /* record we moved. */
648
649 /* We're going to read and write records to and from the DAS file */
650 /* directly, rather than going through the buffering system. */
651 /* This will allow us to avoid any untoward interactions between */
652 /* the buffers for different data types. */
653
654 i__1 = base + total + start;
655 i__2 = base + total + start;
656 dasrdi_(&scrhan, &i__1, &i__2, &savtyp);
657 i__1 = base + start;
658 i__2 = base + start;
659 dasrdi_(&scrhan, &i__1, &i__2, &offset);
660
661 /* Save the record at the location DRBASE + START. */
662
663 if (savtyp == 1) {
664 i__1 = drbase + start;
665 dasioc_("READ", &unit, &i__1, savec, (ftnlen)4, (ftnlen)1024);
666 } else if (savtyp == 2) {
667 i__1 = drbase + start;
668 dasiod_("READ", &unit, &i__1, saved, (ftnlen)4);
669 } else {
670 i__1 = drbase + start;
671 dasioi_("READ", &unit, &i__1, savei, (ftnlen)4);
672 }
673 if (failed_()) {
674 chkout_("DASSDR", (ftnlen)6);
675 return 0;
676 }
677
678 /* Let I be the index of the record that we are going to move */
679 /* data into next. I is an offset from the last comment record. */
680
681 i__ = start;
682 while(offset != start) {
683
684 /* Mark the order vector element by writing its negative */
685 /* back to the location it came from. */
686
687 i__1 = base + i__;
688 i__2 = base + i__;
689 i__3 = -offset;
690 dasudi_(&scrhan, &i__1, &i__2, &i__3);
691
692 /* Move the record at location */
693
694 /* DRBASE + OFFSET */
695
696 /* to location */
697
698 /* DRBASE + I */
699
700 /* There is no need to do anything about the corresponding */
701 /* elements of the type vector; we won't need them again. */
702
703 /* The read and write operations, as well as the temporary */
704 /* record required to perform the move, are dependent on the */
705 /* data type of the record to be moved. */
706
707 i__1 = base + total + offset;
708 i__2 = base + total + offset;
709 dasrdi_(&scrhan, &i__1, &i__2, &type__);
710 if (failed_()) {
711 chkout_("DASSDR", (ftnlen)6);
712 return 0;
713 }
714
715 /* Only pick records up if we're going to put them down in */
716 /* a location other than their original one. */
717
718 if (i__ != offset) {
719 if (type__ == 1) {
720 i__1 = drbase + offset;
721 dasioc_("READ", &unit, &i__1, crec, (ftnlen)4, (ftnlen)
722 1024);
723 i__1 = drbase + i__;
724 dasioc_("WRITE", &unit, &i__1, crec, (ftnlen)5, (ftnlen)
725 1024);
726 } else if (type__ == 2) {
727 i__1 = drbase + offset;
728 dasiod_("READ", &unit, &i__1, drec, (ftnlen)4);
729 i__1 = drbase + i__;
730 dasiod_("WRITE", &unit, &i__1, drec, (ftnlen)5);
731 } else {
732 i__1 = drbase + offset;
733 dasioi_("READ", &unit, &i__1, irec, (ftnlen)4);
734 i__1 = drbase + i__;
735 dasioi_("WRITE", &unit, &i__1, irec, (ftnlen)5);
736 }
737 if (failed_()) {
738 chkout_("DASSDR", (ftnlen)6);
739 return 0;
740 }
741 }
742
743 /* OFFSET is the index of the next order vector element to */
744 /* look at. */
745
746 i__ = offset;
747 i__1 = base + i__;
748 i__2 = base + i__;
749 dasrdi_(&scrhan, &i__1, &i__2, &offset);
750 i__1 = base + i__ + total;
751 i__2 = base + i__ + total;
752 dasrdi_(&scrhan, &i__1, &i__2, &type__);
753 if (failed_()) {
754 chkout_("DASSDR", (ftnlen)6);
755 return 0;
756 }
757 }
758
759 /* The last value of I is the location in the cycle that element */
760 /* START followed. Therefore, the saved record corresponding */
761 /* to index START should be written to this location. */
762
763 if (savtyp == 1) {
764 i__1 = drbase + i__;
765 dasioc_("WRITE", &unit, &i__1, savec, (ftnlen)5, (ftnlen)1024);
766 } else if (savtyp == 2) {
767 i__1 = drbase + i__;
768 dasiod_("WRITE", &unit, &i__1, saved, (ftnlen)5);
769 } else {
770 i__1 = drbase + i__;
771 dasioi_("WRITE", &unit, &i__1, savei, (ftnlen)5);
772 }
773
774 /* Mark the order vector element by writing its negative */
775 /* back to the location it came from. */
776
777 i__1 = base + i__;
778 i__2 = base + i__;
779 i__3 = -start;
780 dasudi_(&scrhan, &i__1, &i__2, &i__3);
781 if (failed_()) {
782 chkout_("DASSDR", (ftnlen)6);
783 return 0;
784 }
785
786 /* Update START so that it points to the first element of a cycle */
787 /* of the order vector that has not yet been traversed. This will */
788 /* be the first positive element of the order vector in a location */
789 /* indexed higher than the current value of START. Note that */
790 /* this way of updating START guarantees that we don't have to */
791 /* backtrack to find an element in the next cycle. */
792
793 offset = -1;
794 while(offset < 0 && start < total) {
795 ++start;
796 i__1 = base + start;
797 i__2 = base + start;
798 dasrdi_(&scrhan, &i__1, &i__2, &offset);
799 if (failed_()) {
800 chkout_("DASSDR", (ftnlen)6);
801 return 0;
802 }
803 }
804
805 /* At this point, START is the index of an element in the order */
806 /* vector that belongs to a cycle where no routine has gone */
807 /* before, or else START is the last index in the order vector, */
808 /* in which case we're done. */
809
810 }
811
812 /* At this point, the records in the DAS are organized as follows: */
813
814 /* +----------------------------------+ */
815 /* | File record | ( 1 ) */
816 /* +----------------------------------+ */
817 /* | Reserved records | ( 0 or more ) */
818 /* | | */
819 /* +----------------------------------+ */
820 /* | Comment records | ( 0 or more ) */
821 /* | | */
822 /* | | */
823 /* +----------------------------------+ */
824 /* | First directory record | ( 1 ) */
825 /* +----------------------------------+ */
826 /* | Character data records | ( 0 or more ) */
827 /* | | */
828 /* +----------------------------------+ */
829 /* | Double precision data records | ( 0 or more ) */
830 /* | | */
831 /* +----------------------------------+ */
832 /* | Integer data records | ( 0 or more ) */
833 /* | | */
834 /* +----------------------------------+ */
835 /* | Additional directory records | ( 0 or more ) */
836 /* | | */
837 /* +----------------------------------+ */
838
839
840 /* Not all of the indicated components must be present; only the */
841 /* file record and first directory record will exist in all cases. */
842 /* The `additional directory records' at the end of the file serve */
843 /* no purpose; if more data is appended to the file, they will be */
844 /* overwritten. */
845
846 /* The last step in preparing the file is to fill in the first */
847 /* directory record with the correct information, and to update */
848 /* the file summary. */
849
850
851 recno = drbase + 1;
852 cleari_(&c__256, irec);
853
854 /* Set the logical address ranges in the directory record, for each */
855 /* data type. */
856
857 for (type__ = 1; type__ <= 3; ++type__) {
858 maxadr = lastla[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
859 "lastla", i__1, "dassdr_", (ftnlen)957)];
860 if (maxadr > 0) {
861 minadr = 1;
862 } else {
863 minadr = 0;
864 }
865 irec[(i__1 = type__ << 1) < 256 && 0 <= i__1 ? i__1 : s_rnge("irec",
866 i__1, "dassdr_", (ftnlen)965)] = minadr;
867 irec[(i__1 = (type__ << 1) + 1) < 256 && 0 <= i__1 ? i__1 : s_rnge(
868 "irec", i__1, "dassdr_", (ftnlen)966)] = maxadr;
869 }
870
871 /* Set the descriptors in the directory. Determine which type */
872 /* comes first: the order of priority is character, double */
873 /* precision, integer. */
874
875 pos = 9;
876 for (type__ = 1; type__ <= 3; ++type__) {
877 if (lastla[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("las"
878 "tla", i__1, "dassdr_", (ftnlen)979)] > 0) {
879 if (pos == 9) {
880
881 /* This is the first type for which any data is present. */
882 /* We must enter a type code at position BEGDSC in the */
883 /* directory, and we must enter a count at position */
884 /* BEGDSC+1. */
885
886 irec[8] = type__;
887 irec[9] = count[(i__1 = type__ - 1) < 4 && 0 <= i__1 ? i__1 :
888 s_rnge("count", i__1, "dassdr_", (ftnlen)989)];
889 lastrc[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
890 "lastrc", i__1, "dassdr_", (ftnlen)990)] = recno;
891 lastwd[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
892 "lastwd", i__1, "dassdr_", (ftnlen)991)] = 10;
893 pos += 2;
894 prvtyp = type__;
895 } else {
896
897 /* Place an appropriately signed count at location POS in */
898 /* the directory. */
899
900 if (type__ == next[(i__1 = prvtyp - 1) < 3 && 0 <= i__1 ?
901 i__1 : s_rnge("next", i__1, "dassdr_", (ftnlen)1000)])
902 {
903 irec[(i__1 = pos - 1) < 256 && 0 <= i__1 ? i__1 : s_rnge(
904 "irec", i__1, "dassdr_", (ftnlen)1001)] = count[(
905 i__2 = type__ - 1) < 4 && 0 <= i__2 ? i__2 :
906 s_rnge("count", i__2, "dassdr_", (ftnlen)1001)];
907 } else {
908 irec[(i__1 = pos - 1) < 256 && 0 <= i__1 ? i__1 : s_rnge(
909 "irec", i__1, "dassdr_", (ftnlen)1003)] = -count[(
910 i__2 = type__ - 1) < 4 && 0 <= i__2 ? i__2 :
911 s_rnge("count", i__2, "dassdr_", (ftnlen)1003)];
912 }
913 lastrc[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
914 "lastrc", i__1, "dassdr_", (ftnlen)1006)] = recno;
915 lastwd[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
916 "lastwd", i__1, "dassdr_", (ftnlen)1007)] = pos;
917 ++pos;
918 prvtyp = type__;
919 }
920 }
921 }
922
923 /* Since we've done away with all but the first directory, the first */
924 /* free record is decremented by 1 less than the directory count. */
925
926 free = free - count[3] + 1;
927
928 /* Write out the new directory record. Don't use the DAS buffered */
929 /* write mechanism; this could trash the file by dumping buffered */
930 /* records in the wrong places. */
931
932 dasioi_("WRITE", &unit, &recno, irec, (ftnlen)5);
933
934 /* Write out the updated file summary. */
935
936 dasufs_(handle, &nresvr, &nresvc, &ncomr, &ncomc, &free, lastla, lastrc,
937 lastwd);
938
939 /* Clean up the DAS data buffers: we don't want buffered scratch */
940 /* file records hanging around there. Then get rid of the scratch */
941 /* file. */
942
943 daswbr_(&scrhan);
944 dasllc_(&scrhan);
945 chkout_("DASSDR", (ftnlen)6);
946 return 0;
947 } /* dassdr_ */
948
949