/* $Procedure DASADC ( DAS, add data, character ) */
/* Subroutine */ int dasadc_(integer *handle, integer *n, integer *bpos,
integer *epos, char *data, ftnlen data_len)
{
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer free;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer ncomc, lastc, recno, ncomr, nmove, rcpos;
extern /* Subroutine */ int dasa2l_(integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
extern logical failed_(void);
integer clbase;
extern /* Subroutine */ int dascud_(integer *, integer *, integer *),
dashfs_(integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
char record[1024];
integer lastla[3];
extern /* Subroutine */ int dasurc_(integer *, integer *, integer *,
integer *, char *, ftnlen), daswrc_(integer *, integer *, char *,
ftnlen);
integer lastrc[3], clsize, nmoved;
extern /* Subroutine */ int sigerr_(char *, ftnlen);
integer numchr;
extern /* Subroutine */ int chkout_(char *, ftnlen);
integer lastwd[3], nresvc;
extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen);
integer wordno;
extern logical return_(void);
integer nresvr, nwritn, chr, elt;
/* $ Abstract */
/* Add character data to a DAS file. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAS */
/* $ Keywords */
/* ARRAY */
/* ASSIGNMENT */
/* DAS */
/* FILES */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I DAS file handle. */
/* N I Number of characters to add to file. */
/* BPOS, */
/* EPOS I Begin and end positions of substrings. */
/* DATA I Array of character strings. */
/* $ Detailed_Input */
/* HANDLE is a file handle of a DAS file opened for writing. */
/* N is the number of characters, in the specified set */
/* of substrings, to add to the specified DAS file. */
/* BPOS, */
/* EPOS are begin and end character positions that define */
/* a set of substrings in the input array. This */
/* routine writes characters from the specified set */
/* of substrings to the specified DAS file. */
/* DATA is an array of character strings, some portion of */
/* whose contents are to be added to the specified */
/* DAS file. Specifically, the first N characters of */
/* the substrings */
/* DATA(I) (BPOS:EPOS), I = 1, ... */
/* are appended to the character data in the file. */
/* The order of characters in the input substrings */
/* is considered to increase from left to right */
/* within each element of DATA, and to increase */
/* with the indices of the elements of DATA. */
/* $ Detailed_Output */
/* None. See $Particulars for a description of the effect of this */
/* routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input file handle is invalid, the error will be */
/* diagnosed by routines called by this routine. */
/* 2) If EPOS or BPOS are outside of the range */
/* [ 1, LEN( DATA(1) ) ] */
/* or if EPOS < BPOS, the error SPICE(BADSUBSTRINGBOUNDS) will */
/* be signalled. */
/* 3) If the input count N is less than 1, no data will be */
/* added to the specified DAS file. */
/* 4) If an I/O error occurs during the data addition attempted */
/* by this routine, the error will be diagnosed by routines */
/* called by this routine. */
/* 5) If N is greater than the number of characters in the */
/* specified set of input substrings, the results of calling */
/* this routine are unpredictable. This routine cannot */
/* detect this error. */
/* $ Files */
/* See the description of the argument HANDLE in $Detailed_Input. */
/* $ Particulars */
/* This routine adds character data to a DAS file by `appending' it */
/* after any character data already in the file. The sense in which */
/* the data is `appended' is that the data will occupy a range of */
/* logical addresses for character data that immediately follow the */
/* last logical address of a character that is occupied at the time */
/* this routine is called. The diagram below illustrates this */
/* addition: */
/* +-------------------------+ */
/* | (already in use) | Character logical address 1 */
/* +-------------------------+ */
/* . */
/* . */
/* . */
/* +-------------------------+ Last character logical address */
/* | (already in use) | in use before call to DASADC */
/* +-------------------------+ */
/* | DATA(1) (BPOS:BPOS) | First added character */
/* +-------------------------+ */
/* | DATA(1) (BPOS+1:BPOS+1) | */
/* +-------------------------+ */
/* . */
/* . */
/* . */
/* +-------------------------+ */
/* | DATA(1) (EPOS:EPOS) | */
/* +-------------------------+ */
/* | DATA(2) (BPOS:BPOS) | */
/* +-------------------------+ */
/* . */
/* . */
/* . */
/* +-------------------------+ */
/* | DATA(R) (C:C) | Nth added character---here R is */
/* +-------------------------+ */
/* INT ( (N+L-1)/L ) */
/* where L = EPOS - BPOS + 1, and */
/* C is */
/* N - (R-1)*L */
/* The logical organization of the characters in the DAS file is */
/* independent of the order of addition to the file or physical */
/* location of any data of integer or double precision type. */
/* The actual physical write operations that add the input array */
/* DATA to the indicated DAS file may not take place before this */
/* routine returns, since the DAS system buffers data that is */
/* written as well as data that is read. In any case, the data */
/* will be flushed to the file at the time the file is closed, if */
/* not earlier. A physical write of all buffered records can be */
/* forced by calling the SPICELIB routine DASWUR ( DAS, write */
/* updated records ). */
/* In order to update character logical addresses that already */
/* contain data, the SPICELIB routine DASUDC (DAS, update data, */
/* character) should be used. */
/* $ Examples */
/* 1) Create the new DAS file TEST.DAS and add 120 characters to it. */
/* Close the file, then re-open it and read the data back out. */
/* PROGRAM TEST_ADD */
/* CHARACTER*(80) LINES ( 3 ) */
/* CHARACTER*(4) TYPE */
/* INTEGER HANDLE */
/* INTEGER I */
/* DATA LINES / 'Here is the first line.', */
/* . 'Here is the second line.', */
/* . 'Here is the third line.' / */
/* C */
/* C Open a new DAS file. Use the file name as */
/* C the internal file name. */
/* C */
/* TYPE = 'TEST' */
/* CALL DASONW ( 'TEST.DAS', TYPE, 'TEST.DAS', HANDLE ) */
/* C */
/* C Add the contents of the array LINES to the file. */
/* C Since the lines are short, just use the first 40 */
/* C characters of each one. */
/* C */
/* CALL DASADC ( HANDLE, 120, 1, 40, LINES ) */
/* C */
/* C Close the file. */
/* C */
/* CALL DASCLS ( HANDLE ) */
/* C */
/* C Now verify the addition of data by opening the */
/* C file for read access and retrieving the data. */
/* C */
/* CALL DASOPR ( 'TEST.DAS', HANDLE ) */
/* DO I = 1, 3 */
/* LINES(I) = ' ' */
/* END DO */
/* CALL DASRDC ( HANDLE, 1, 120, 1, 40, LINES ) */
/* C */
/* C Dump the data to the screen. We should see the */
/* C sequence */
/* C */
/* C Here is the first line. */
/* C Here is the second line. */
/* C Here is the third line. */
/* C */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Data from TEST.DAS: ' */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) LINES */
/* END */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.1 19-DEC-1995 (NJB) */
/* Corrected title of permuted index entry section. */
/* - SPICELIB Version 1.1.0 12-MAY-1994 (KRG) (NJB) */
/* Test of FAILED() added to loop termination condition. */
/* Removed references to specific DAS file open routines in the */
/* $ Detailed_Input section of the header. This was done in order */
/* to minimize documentation changes if the DAS open routines ever */
/* change. */
/* Modified the $ Examples section to demonstrate the new ID word */
/* format which includes a file type and to include a call to the */
/* new routine DASONW, open new, which makes use of the file */
/* type. Also, a variable for the type of the file to be created */
/* was added. */
/* - SPICELIB Version 1.0.0, 11-NOV-1992 (NJB) (WLT) */
/* -& */
/* $ Index_Entries */
/* add character data to a DAS file */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 12-MAY-1994 (KRG) (NJB) */
/* Test of FAILED() added to loop termination condition. Without */
/* this test, an infinite loop could result if DASA2L, DASURC or */
/* DASWRC signaled an error inside the loop. */
/* Removed references to specific DAS file open routines in the */
/* $ Detailed_Input section of the header. This was done in order */
/* to minimize documentation changes if the DAS open routines ever */
/* change. */
/* Modified the $ Examples section to demonstrate the new ID word */
/* format which includes a file type and to include a call to the */
/* new routine DASONW, open new, which makes use of the file */
/* type. Also, a variable for the type of the file to be created */
/* was added. */
/* - SPICELIB Version 1.0.0, 11-NOV-1992 (NJB) (WLT) */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("DASADC", (ftnlen)6);
}
/* Make sure BPOS and EPOS are OK; stop here if not. */
if (*bpos < 1 || *epos < 1 || *bpos > i_len(data, data_len) || *epos >
i_len(data, data_len)) {
setmsg_("Substring bounds must be in range [1,#]. Actual range [BPOS"
",EPOS] was [#,#].", (ftnlen)76);
i__1 = i_len(data, data_len);
errint_("#", &i__1, (ftnlen)1);
errint_("#", bpos, (ftnlen)1);
errint_("#", epos, (ftnlen)1);
sigerr_("SPICE(BADSUBSTRINGBOUNDS)", (ftnlen)25);
chkout_("DASADC", (ftnlen)6);
return 0;
} else if (*epos < *bpos) {
setmsg_("Substring upper bound must not be less than lower bound. A"
"ctual range [BPOS,EPOS] was [#,#].", (ftnlen)93);
errint_("#", bpos, (ftnlen)1);
errint_("#", epos, (ftnlen)1);
sigerr_("SPICE(BADSUBSTRINGBOUNDS)", (ftnlen)25);
chkout_("DASADC", (ftnlen)6);
return 0;
}
/* Get the file summary for this DAS. */
dashfs_(handle, &nresvr, &nresvc, &ncomr, &ncomc, &free, lastla, lastrc,
lastwd);
lastc = lastla[0];
/* We will keep track of the location that we wish to write to */
/* with the variables RECNO and WORDNO. RECNO will be the record */
/* number of the record we'll write to; WORDNO will be the number */
/* preceding the word index, within record number RECNO, that we'll */
/* write to. For example, if we're about to write to the first */
/* character in record 10, RECNO will be 10 and WORDNO will be 0. Of */
/* course, when WORDNO reaches NWC, we'll have to find a free record */
/* before writing anything. */
/* Prepare the variables RECNO and WORDNO: use the physical location */
/* of the last character address, if there are any character data in */
/* the file. Otherwise, RECNO becomes the first record available for */
/* character data. */
if (lastc >= 1) {
dasa2l_(handle, &c__1, &lastc, &clbase, &clsize, &recno, &wordno);
} else {
recno = free;
wordno = 0;
}
/* Set the number of character words already written. Keep */
/* writing to the file until this number equals the number of */
/* elements in DATA. */
/* Note that if N is non-positive, the loop doesn't get */
/* exercised. */
/* Also initialize the array element index and position of the */
/* character to be moved next. */
nwritn = 0;
elt = 1;
chr = *bpos;
while(nwritn < *n && ! failed_()) {
/* Write as much data as we can (or need to) into the current */
/* record. We assume that RECNO, WORDNO, and NWRITN have */
/* been set correctly at this point. */
/* Find out how many words to write into the current record. */
/* There may be no space left in the current record. */
/* Computing MIN */
i__1 = *n - nwritn, i__2 = 1024 - wordno;
numchr = min(i__1,i__2);
if (numchr > 0) {
/* Write NUMCHR words into the current record. If the record */
/* is new, write the entire record. Otherwise, just update */
/* the part we're interested in. */
/* In either case, we'll first fill in characters WORDNO+1 */
/* through WORDNO + NUMCHR of the string RECORD. */
/* So far, we haven't moved any characters. */
nmoved = 0;
rcpos = wordno;
while(nmoved < numchr) {
/* Find out how many characters in the current array */
/* element we should move. */
if (chr > *epos) {
++elt;
chr = *bpos;
}
/* Computing MIN */
i__1 = numchr - nmoved, i__2 = *epos - chr + 1;
nmove = min(i__1,i__2);
i__1 = rcpos;
s_copy(record + i__1, data + ((elt - 1) * data_len + (chr - 1)
), rcpos + nmove - i__1, data_len - (chr - 1));
nmoved += nmove;
rcpos += nmove;
chr += nmove;
}
/* Now we can write or update the file with RECORD. */
if (wordno == 0) {
/* The record has not yet been written, so write out the */
/* entire record. */
daswrc_(handle, &recno, record, (ftnlen)1024);
} else {
/* Update elements WORDNO+1 through WORDNO+NUMCHR. */
i__1 = wordno;
i__2 = wordno + 1;
i__3 = wordno + numchr;
dasurc_(handle, &recno, &i__2, &i__3, record + i__1, wordno +
numchr - i__1);
}
nwritn += numchr;
wordno += numchr;
} else {
/* It's time to start on a new record. If the record we */
/* just finished writing to (or just attempted writing to, */
/* if it was full) was FREE or a higher-numbered record, */
/* then we are writing to a contiguous set of data records: */
/* the next record to write to is the immediate successor */
/* of the last one. Otherwise, FREE is the next record */
/* to write to. */
/* We intentionally leave FREE at the value it had before */
/* we starting adding data to the file. */
if (recno >= free) {
++recno;
} else {
recno = free;
}
wordno = 0;
}
}
/* Update the DAS file directories to reflect the addition of N */
/* character words. DASCUD will also update the file summary */
/* accordingly. */
dascud_(handle, &c__1, n);
chkout_("DASADC", (ftnlen)6);
return 0;
} /* dasadc_ */
/* $Procedure DASSDR ( DAS, segregate data records ) */
/* Subroutine */ int dassdr_(integer *handle)
{
/* Initialized data */
static integer next[3] = { 2,3,1 };
static integer prev[3] = { 3,1,2 };
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
integer base;
char crec[1024];
doublereal drec[128];
integer free, irec[256], lrec, dest;
logical more;
integer unit, type__, i__, j, n;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer ncomc;
extern /* Subroutine */ int maxai_(integer *, integer *, integer *,
integer *);
char savec[1024];
doublereal saved[128];
integer recno, savei[256];
extern integer sumai_(integer *, integer *);
integer ncomr, total, lword, count[4], ltype, start;
extern logical failed_(void);
extern /* Subroutine */ int dasadi_(integer *, integer *, integer *),
cleari_(integer *, integer *);
integer drbase;
extern /* Subroutine */ int dasioc_(char *, integer *, integer *, char *,
ftnlen, ftnlen), dasiod_(char *, integer *, integer *, doublereal
*, ftnlen), dasllc_(integer *), dasrdi_(integer *, integer *,
integer *, integer *), dashfs_(integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *),
dasudi_(integer *, integer *, integer *, integer *);
integer minadr, maxadr, scrhan, lastla[3];
extern /* Subroutine */ int dassih_(integer *, char *, ftnlen), dashlu_(
integer *, integer *), daswbr_(integer *), dasrri_(integer *,
integer *, integer *, integer *, integer *);
integer offset;
extern /* Subroutine */ int dasioi_(char *, integer *, integer *, integer
*, ftnlen);
integer lastrc[3];
extern /* Subroutine */ int dasops_(integer *), dasufs_(integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *), chkout_(char *, ftnlen);
integer lastwd[3], nresvc;
extern logical return_(void);
integer nresvr, savtyp, prvtyp, loc, pos;
/* $ Abstract */
/* Segregate the data records in a DAS file into clusters, using */
/* one cluster per data type present in the file. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAS */
/* $ Keywords */
/* DAS */
/* FILES */
/* ORDER */
/* SORT */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I DAS file handle. */
/* $ Detailed_Input */
/* HANDLE is a file handle of a DAS file opened for writing. */
/* $ Detailed_Output */
/* None. See $Particulars for a description of the effect of this */
/* routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input file handle is invalid, the error will be */
/* diagnosed by routines called by this routine. */
/* 2) If a Fortran read attempted by this routine fails, the */
/* error will be diagnosed by routines called by this routine. */
/* The state of the DAS file undergoing re-ordering will be */
/* indeterminate. */
/* 3) If a Fortran write attempted by this routine fails, the */
/* error will be diagnosed by routines called by this routine. */
/* The state of the DAS file undergoing re-ordering will be */
/* indeterminate. */
/* 4) If any other I/O error occurs during the re-arrangement of */
/* the records in the indicated DAS file, the error will be */
/* diagnosed by routines called by this routine. */
/* $ Files */
/* See the description of the argument HANDLE in $Detailed_Input. */
/* $ Particulars */
/* Normally, there should be no need for routines outside of */
/* SPICELIB to call this routine. */
/* The effect of this routine is to re-arrange the data records */
/* in a DAS file so that the file contains a single cluster for */
/* each data type present in the file: in the general case, there */
/* will be a single cluster of each of the integer, double */
/* precision, and character data types. */
/* The relative order of data records of a given type is not */
/* affected by this re-ordering. After the re-ordering, the DAS */
/* file contains a single directory record that has one descriptor */
/* for each cluster. After that point, the order in the file of the */
/* sets of data records of the various data types will be: */
/* +-------+ */
/* | CHAR | */
/* +-------+ */
/* | DP | */
/* +-------+ */
/* | INT | */
/* +-------+ */
/* Files that contain multiple directory records will have all but */
/* the first directory record moved to the end of the file when the */
/* re-ordering is complete. These records are not visible to the */
/* DAS system and will be overwritten if data is subsequently added */
/* to the DAS file. */
/* The purpose of segregating a DAS file's data records into three */
/* clusters is to make read access more efficient: when a DAS file */
/* contains a single directory with at most three cluster type */
/* descriptors, mapping logical to physical addresses can be done */
/* in constant time. */
/* $ Examples */
/* 1) Segregate data records in a DAS file designated by */
/* HANDLE: */
/* CALL DASSDR ( HANDLE ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 2.0.1 19-DEC-1995 (NJB) */
/* Corrected title of permuted index entry section. */
/* - EKLIB Version 2.0.0, 17-NOV-1993 (KRG) */
/* Added test of FAILED after each DAS call, or sequence of calls, */
/* which returns immediately if FAILED is true. This fixes a bug */
/* where DASOPS signals an error and then DASSDR has a */
/* segmentation fault. */
/* Removed references to specific DAS file open routines in the */
/* $ Detailed_Input section of the header. This was done in order */
/* to minimize documentation changes if the DAS open routines ever */
/* change. */
/* - EKLIB Version 1.2.0, 07-OCT-1993 (NJB) (HAN) (MJS) */
/* Bug fix: call to CLEARD replaced with call to */
/* CLEARI. */
/* - EKLIB Version 1.1.0, 08-JUL-1993 (NJB) (MJS) */
/* Bug fix: extraneous commas removed from argument lists */
/* in calls to DASADI. */
/* - SPICELIB Version 1.0.0, 11-NOV-1992 (NJB) (WLT) */
/* -& */
/* $ Index_Entries */
/* segregate the data records in a DAS file */
/* -& */
/* $ Revisions */
/* - EKLIB Version 2.0.0, 17-NOV-1993 (KRG) */
/* Added test of failed after each DAS call, or sequence of calls, */
/* which returns immediately if FAILED is true. This fixes a bug */
/* where DASOPS signals an error and then DASSDR has a */
/* segmentation fault. */
/* Removed references to specific DAS file open routines in the */
/* $ Detailed_Input section of the header. This was done in order */
/* to minimize documentation changes if the DAS open routines ever */
/* change. */
/* - EKLIB Version 1.2.0, 07-OCT-1993 (NJB) (HAN) (MJS) */
/* Bug fix: call to CLEARD replaced with call to */
/* CLEARI. */
/* - EKLIB Version 1.1.0, 08-JUL-1993 (NJB) */
/* Bug fix: extraneous commas removed from argument lists */
/* in calls to DASADI. This bug had no visible effect on */
/* VAX and Sun systems, but generated a compile error under */
/* Lahey Fortran. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Data type parameters */
/* Directory pointer locations (backward and forward): */
/* Directory address range location base */
/* Location of first type descriptor */
/* Local variables */
/* Saved variables */
/* NEXT and PREV map the DAS data type codes to their */
/* successors and predecessors, respectively. */
/* Initial values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("DASSDR", (ftnlen)6);
}
/* Before starting, make sure that this DAS file is open for */
/* writing. */
dassih_(handle, "WRITE", (ftnlen)5);
/* Get the logical unit for this file. */
dashlu_(handle, &unit);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* Write out any buffered records that belong to the file. */
daswbr_(handle);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* We're going to re-order the physical records in the DAS file, */
/* starting with the first record after the first directory. */
/* The other directory records are moved to the end of the file */
/* as a result of the re-ordering. */
/* The re-ordering algorithm is based on that used in the REORDx */
/* routines. To use this algorithm, we'll build an order vector */
/* for the records to be ordered; we'll construct this order vector */
/* in a scratch DAS file. First, we'll traverse the directories */
/* to build up a sort of inverse order vector that tells us the */
/* final destination and data type of each data record; from this */
/* inverse vector we can easily build a true order vector. The */
/* cycles of the true order vector can be traversed without */
/* repetitive searching, and with a minimum of assignment of the */
/* contents of data records to temporary variables. */
/* Allocate a scratch DAS file to keep our vectors in. */
dasops_(&scrhan);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* Now build up our `inverse order vector'. This array is an */
/* inverse order vector only in loose sense: it actually consists */
/* of an integer array that contains a sequence of pairs of integers, */
/* the first of which indicates a data type, and the second of which */
/* is an ordinal number. There is one pair for each data record in */
/* the file. The ordinal number gives the ordinal position of the */
/* record described by the number pair, relative to the other records */
/* of the same type. Directory records are considered to have type */
/* `directory', which is represented by the code DIR. */
/* We also must maintain a count of records of each type. */
cleari_(&c__4, count);
/* Get the file summary for the DAS file to be segregated. */
dashfs_(handle, &nresvr, &nresvc, &ncomr, &ncomc, &free, lastla, lastrc,
lastwd);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* Find the record and word positions LREC and LWORD of the last */
/* descriptor in the file, and also find the type of the descriptor */
/* LTYPE. */
maxai_(lastrc, &c__3, &lrec, &loc);
lword = 0;
for (i__ = 1; i__ <= 3; ++i__) {
if (lastrc[(i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("lastrc",
i__1, "dassdr_", (ftnlen)451)] == lrec && lastwd[(i__2 = i__
- 1) < 3 && 0 <= i__2 ? i__2 : s_rnge("lastwd", i__2, "dassd"
"r_", (ftnlen)451)] > lword) {
lword = lastwd[(i__1 = i__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
"lastwd", i__1, "dassdr_", (ftnlen)454)];
ltype = i__;
}
}
/* The first directory starts after the last comment record. */
recno = nresvr + ncomr + 2;
while(recno <= lrec && recno > 0) {
/* Read the directory record. */
dasrri_(handle, &recno, &c__1, &c__256, irec);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* Increment the directory count. */
++count[3];
/* Add the data type (`directory') and count (1) of the current */
/* record to the inverse order vector. */
dasadi_(&scrhan, &c__1, &c__4);
dasadi_(&scrhan, &c__1, &count[3]);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* Set up our `finite state machine' that tells us the data */
/* types of the records described by the last read directory. */
type__ = irec[8];
prvtyp = prev[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
"prev", i__1, "dassdr_", (ftnlen)498)];
/* Now traverse the directory and update the inverse order */
/* vector based on the descriptors we find. */
more = TRUE_;
i__ = 10;
while(more) {
/* Obtain the count for the current descriptor. */
n = (i__2 = irec[(i__1 = i__ - 1) < 256 && 0 <= i__1 ? i__1 :
s_rnge("irec", i__1, "dassdr_", (ftnlen)512)], abs(i__2));
/* Update our inverse order vector to describe the positions */
/* of the N records described by the current descriptor. */
i__1 = n;
for (j = 1; j <= i__1; ++j) {
dasadi_(&scrhan, &c__1, &type__);
i__3 = count[(i__2 = type__ - 1) < 4 && 0 <= i__2 ? i__2 :
s_rnge("count", i__2, "dassdr_", (ftnlen)521)] + j;
dasadi_(&scrhan, &c__1, &i__3);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
}
/* Adjust the count of records of data type TYPE. */
count[(i__1 = type__ - 1) < 4 && 0 <= i__1 ? i__1 : s_rnge("count"
, i__1, "dassdr_", (ftnlen)533)] = count[(i__2 = type__ -
1) < 4 && 0 <= i__2 ? i__2 : s_rnge("count", i__2, "dass"
"dr_", (ftnlen)533)] + n;
/* Find the next type. */
++i__;
if (i__ > 256 || recno == lrec && i__ > lword) {
more = FALSE_;
} else {
if (irec[(i__1 = i__ - 1) < 256 && 0 <= i__1 ? i__1 : s_rnge(
"irec", i__1, "dassdr_", (ftnlen)547)] > 0) {
type__ = next[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1
: s_rnge("next", i__1, "dassdr_", (ftnlen)548)];
} else if (irec[(i__1 = i__ - 1) < 256 && 0 <= i__1 ? i__1 :
s_rnge("irec", i__1, "dassdr_", (ftnlen)550)] < 0) {
type__ = prev[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1
: s_rnge("prev", i__1, "dassdr_", (ftnlen)551)];
} else {
more = FALSE_;
}
}
}
/* The forward pointer in this directory tells us where the */
/* next directory record is. When there are no more directory */
/* records, this pointer will be zero. */
recno = irec[1];
}
/* At this point, the inverse order vector is set up. The array */
/* COUNT contains counts of the number of records of each type we've */
/* seen. Set TOTAL to the total number of records that we've going */
/* to permute. */
total = sumai_(count, &c__4);
/* The next step is to build a true order vector. Let BASE be */
/* the base address for the order vector; this address is the */
/* last logical address of the inverse order vector. */
base = total << 1;
/* We'll store the actual order vector in locations BASE + 1 */
/* through BASE + TOTAL. In addition, we'll build a parallel array */
/* that contains, for each element of the order vector, the type of */
/* data corresponding to that element. This type vector will */
/* reside in locations BASE + TOTAL + 1 through BASE + 2*TOTAL. */
/* Before setting the values of the order vector and its parallel */
/* type vector, we'll allocate space in the scratch DAS file by */
/* zeroing out the locations we plan to use. After this, locations */
/* BASE+1 through BASE + 2*TOTAL can be written to in random access */
/* fashion using DASUDI. */
i__1 = total << 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dasadi_(&scrhan, &c__1, &c__0);
}
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* We note that the way to construct the inverse of a permutation */
/* SIGMA in a single loop is suggested by the relation */
/* -1 */
/* SIGMA ( SIGMA(I) ) = I */
/* We'll use this method. In our case, our order vector plays */
/* the role of */
/* -1 */
/* SIGMA */
/* and the `inverse order vector' plays the role of SIGMA. We'll */
/* exclude the first directory from the order vector, since it's */
/* an exception: we wish to reserve this record. Since the first */
/* element of the order vector (logically) contains the index 1, we */
/* can ignore it. */
i__1 = total;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = (i__ << 1) - 1;
i__3 = (i__ << 1) - 1;
dasrdi_(&scrhan, &i__2, &i__3, &type__);
i__2 = i__ << 1;
i__3 = i__ << 1;
dasrdi_(&scrhan, &i__2, &i__3, &dest);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* Set DEST to the destination location, measured as an offset */
/* from the last comment record, of the Ith record by adding */
/* on the count of the predecessors of the block of records of */
/* TYPE. */
for (j = 1; j <= 3; ++j) {
if (type__ > j) {
dest += count[(i__2 = j - 1) < 4 && 0 <= i__2 ? i__2 : s_rnge(
"count", i__2, "dassdr_", (ftnlen)648)];
}
}
/* The destination offset of each record should be incremented to */
/* allow room for the first directory record. However, we don't */
/* need to do this for directory records; they'll already have */
/* this offset accounted for. */
if (type__ != 4) {
++dest;
}
/* The value of element DEST of the order vector is I. */
/* Write this value to location BASE + DEST. */
i__2 = base + dest;
i__3 = base + dest;
dasudi_(&scrhan, &i__2, &i__3, &i__);
/* We want the ith element of the order vector to give us the */
/* number of the record to move to position i (offset from the */
/* last comment record), but we want the corresponding element */
/* of the type array to give us the type of the record currently */
/* occupying position i. */
i__2 = base + i__ + total;
i__3 = base + i__ + total;
dasudi_(&scrhan, &i__2, &i__3, &type__);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
}
/* Ok, here's what we've got in the scratch file that's still of */
/* interest: */
/* -- In integer logical addresses BASE + 1 : BASE + TOTAL, */
/* we have an order vector. The Ith element of this */
/* vector indicates the record that should be moved to */
/* location DRBASE + I in the DAS file we're re-ordering, */
/* where DRBASE is the base address of the data records */
/* (the first directory record follows the record having this */
/* index). */
/* -- In integer logical addresses BASE + TOTAL + 1 : BASE + */
/* 2*TOTAL, we have data type indicators for the records to */
/* be re-ordered. The type for the Ith record in the file, */
/* counted from the last comment record, is located in logical */
/* address BASE + TOTAL + I. */
drbase = nresvr + ncomr + 1;
/* As we traverse the order vector, we flip the sign of elements */
/* we've accessed, so that we can tell when we encounter an element */
/* of a cycle that we've already traversed. */
/* Traverse the order vector. The variable START indicates the */
/* first element to look at. Ignore the first element; it's a */
/* singleton cycle. */
start = 2;
while(start < total) {
/* Traverse the current cycle of the order vector. */
/* We `make a hole' in the file by saving the record in position */
/* START, then we traverse the cycle in reverse order, filling in */
/* the hole at the ith position with the record whose number is */
/* the ith element of the order vector. At the end, we deposit */
/* the saved record into the `hole' left behind by the last */
/* record we moved. */
/* We're going to read and write records to and from the DAS file */
/* directly, rather than going through the buffering system. */
/* This will allow us to avoid any untoward interactions between */
/* the buffers for different data types. */
i__1 = base + total + start;
i__2 = base + total + start;
dasrdi_(&scrhan, &i__1, &i__2, &savtyp);
i__1 = base + start;
i__2 = base + start;
dasrdi_(&scrhan, &i__1, &i__2, &offset);
/* Save the record at the location DRBASE + START. */
if (savtyp == 1) {
i__1 = drbase + start;
dasioc_("READ", &unit, &i__1, savec, (ftnlen)4, (ftnlen)1024);
} else if (savtyp == 2) {
i__1 = drbase + start;
dasiod_("READ", &unit, &i__1, saved, (ftnlen)4);
} else {
i__1 = drbase + start;
dasioi_("READ", &unit, &i__1, savei, (ftnlen)4);
}
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* Let I be the index of the record that we are going to move */
/* data into next. I is an offset from the last comment record. */
i__ = start;
while(offset != start) {
/* Mark the order vector element by writing its negative */
/* back to the location it came from. */
i__1 = base + i__;
i__2 = base + i__;
i__3 = -offset;
dasudi_(&scrhan, &i__1, &i__2, &i__3);
/* Move the record at location */
/* DRBASE + OFFSET */
/* to location */
/* DRBASE + I */
/* There is no need to do anything about the corresponding */
/* elements of the type vector; we won't need them again. */
/* The read and write operations, as well as the temporary */
/* record required to perform the move, are dependent on the */
/* data type of the record to be moved. */
i__1 = base + total + offset;
i__2 = base + total + offset;
dasrdi_(&scrhan, &i__1, &i__2, &type__);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* Only pick records up if we're going to put them down in */
/* a location other than their original one. */
if (i__ != offset) {
if (type__ == 1) {
i__1 = drbase + offset;
dasioc_("READ", &unit, &i__1, crec, (ftnlen)4, (ftnlen)
1024);
i__1 = drbase + i__;
dasioc_("WRITE", &unit, &i__1, crec, (ftnlen)5, (ftnlen)
1024);
} else if (type__ == 2) {
i__1 = drbase + offset;
dasiod_("READ", &unit, &i__1, drec, (ftnlen)4);
i__1 = drbase + i__;
dasiod_("WRITE", &unit, &i__1, drec, (ftnlen)5);
} else {
i__1 = drbase + offset;
dasioi_("READ", &unit, &i__1, irec, (ftnlen)4);
i__1 = drbase + i__;
dasioi_("WRITE", &unit, &i__1, irec, (ftnlen)5);
}
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
}
/* OFFSET is the index of the next order vector element to */
/* look at. */
i__ = offset;
i__1 = base + i__;
i__2 = base + i__;
dasrdi_(&scrhan, &i__1, &i__2, &offset);
i__1 = base + i__ + total;
i__2 = base + i__ + total;
dasrdi_(&scrhan, &i__1, &i__2, &type__);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
}
/* The last value of I is the location in the cycle that element */
/* START followed. Therefore, the saved record corresponding */
/* to index START should be written to this location. */
if (savtyp == 1) {
i__1 = drbase + i__;
dasioc_("WRITE", &unit, &i__1, savec, (ftnlen)5, (ftnlen)1024);
} else if (savtyp == 2) {
i__1 = drbase + i__;
dasiod_("WRITE", &unit, &i__1, saved, (ftnlen)5);
} else {
i__1 = drbase + i__;
dasioi_("WRITE", &unit, &i__1, savei, (ftnlen)5);
}
/* Mark the order vector element by writing its negative */
/* back to the location it came from. */
i__1 = base + i__;
i__2 = base + i__;
i__3 = -start;
dasudi_(&scrhan, &i__1, &i__2, &i__3);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
/* Update START so that it points to the first element of a cycle */
/* of the order vector that has not yet been traversed. This will */
/* be the first positive element of the order vector in a location */
/* indexed higher than the current value of START. Note that */
/* this way of updating START guarantees that we don't have to */
/* backtrack to find an element in the next cycle. */
offset = -1;
while(offset < 0 && start < total) {
++start;
i__1 = base + start;
i__2 = base + start;
dasrdi_(&scrhan, &i__1, &i__2, &offset);
if (failed_()) {
chkout_("DASSDR", (ftnlen)6);
return 0;
}
}
/* At this point, START is the index of an element in the order */
/* vector that belongs to a cycle where no routine has gone */
/* before, or else START is the last index in the order vector, */
/* in which case we're done. */
}
/* At this point, the records in the DAS are organized as follows: */
/* +----------------------------------+ */
/* | File record | ( 1 ) */
/* +----------------------------------+ */
/* | Reserved records | ( 0 or more ) */
/* | | */
/* +----------------------------------+ */
/* | Comment records | ( 0 or more ) */
/* | | */
/* | | */
/* +----------------------------------+ */
/* | First directory record | ( 1 ) */
/* +----------------------------------+ */
/* | Character data records | ( 0 or more ) */
/* | | */
/* +----------------------------------+ */
/* | Double precision data records | ( 0 or more ) */
/* | | */
/* +----------------------------------+ */
/* | Integer data records | ( 0 or more ) */
/* | | */
/* +----------------------------------+ */
/* | Additional directory records | ( 0 or more ) */
/* | | */
/* +----------------------------------+ */
/* Not all of the indicated components must be present; only the */
/* file record and first directory record will exist in all cases. */
/* The `additional directory records' at the end of the file serve */
/* no purpose; if more data is appended to the file, they will be */
/* overwritten. */
/* The last step in preparing the file is to fill in the first */
/* directory record with the correct information, and to update */
/* the file summary. */
recno = drbase + 1;
cleari_(&c__256, irec);
/* Set the logical address ranges in the directory record, for each */
/* data type. */
for (type__ = 1; type__ <= 3; ++type__) {
maxadr = lastla[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
"lastla", i__1, "dassdr_", (ftnlen)957)];
if (maxadr > 0) {
minadr = 1;
} else {
minadr = 0;
}
irec[(i__1 = type__ << 1) < 256 && 0 <= i__1 ? i__1 : s_rnge("irec",
i__1, "dassdr_", (ftnlen)965)] = minadr;
irec[(i__1 = (type__ << 1) + 1) < 256 && 0 <= i__1 ? i__1 : s_rnge(
"irec", i__1, "dassdr_", (ftnlen)966)] = maxadr;
}
/* Set the descriptors in the directory. Determine which type */
/* comes first: the order of priority is character, double */
/* precision, integer. */
pos = 9;
for (type__ = 1; type__ <= 3; ++type__) {
if (lastla[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("las"
"tla", i__1, "dassdr_", (ftnlen)979)] > 0) {
if (pos == 9) {
/* This is the first type for which any data is present. */
/* We must enter a type code at position BEGDSC in the */
/* directory, and we must enter a count at position */
/* BEGDSC+1. */
irec[8] = type__;
irec[9] = count[(i__1 = type__ - 1) < 4 && 0 <= i__1 ? i__1 :
s_rnge("count", i__1, "dassdr_", (ftnlen)989)];
lastrc[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
"lastrc", i__1, "dassdr_", (ftnlen)990)] = recno;
lastwd[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
"lastwd", i__1, "dassdr_", (ftnlen)991)] = 10;
pos += 2;
prvtyp = type__;
} else {
/* Place an appropriately signed count at location POS in */
/* the directory. */
if (type__ == next[(i__1 = prvtyp - 1) < 3 && 0 <= i__1 ?
i__1 : s_rnge("next", i__1, "dassdr_", (ftnlen)1000)])
{
irec[(i__1 = pos - 1) < 256 && 0 <= i__1 ? i__1 : s_rnge(
"irec", i__1, "dassdr_", (ftnlen)1001)] = count[(
i__2 = type__ - 1) < 4 && 0 <= i__2 ? i__2 :
s_rnge("count", i__2, "dassdr_", (ftnlen)1001)];
} else {
irec[(i__1 = pos - 1) < 256 && 0 <= i__1 ? i__1 : s_rnge(
"irec", i__1, "dassdr_", (ftnlen)1003)] = -count[(
i__2 = type__ - 1) < 4 && 0 <= i__2 ? i__2 :
s_rnge("count", i__2, "dassdr_", (ftnlen)1003)];
}
lastrc[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
"lastrc", i__1, "dassdr_", (ftnlen)1006)] = recno;
lastwd[(i__1 = type__ - 1) < 3 && 0 <= i__1 ? i__1 : s_rnge(
"lastwd", i__1, "dassdr_", (ftnlen)1007)] = pos;
++pos;
prvtyp = type__;
}
}
}
/* Since we've done away with all but the first directory, the first */
/* free record is decremented by 1 less than the directory count. */
free = free - count[3] + 1;
/* Write out the new directory record. Don't use the DAS buffered */
/* write mechanism; this could trash the file by dumping buffered */
/* records in the wrong places. */
dasioi_("WRITE", &unit, &recno, irec, (ftnlen)5);
/* Write out the updated file summary. */
dasufs_(handle, &nresvr, &nresvc, &ncomr, &ncomc, &free, lastla, lastrc,
lastwd);
/* Clean up the DAS data buffers: we don't want buffered scratch */
/* file records hanging around there. Then get rid of the scratch */
/* file. */
daswbr_(&scrhan);
dasllc_(&scrhan);
chkout_("DASSDR", (ftnlen)6);
return 0;
} /* dassdr_ */
/* $Procedure DASADD ( DAS, add data, double precision ) */
/* Subroutine */ int dasadd_(integer *handle, integer *n, doublereal *data)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer free;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer ncomc, recno, lastd;
extern /* Subroutine */ int moved_(doublereal *, integer *, doublereal *);
integer ncomr, numdp;
extern /* Subroutine */ int dasa2l_(integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
extern logical failed_(void);
integer clbase;
extern /* Subroutine */ int dascud_(integer *, integer *, integer *),
dashfs_(integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
doublereal record[128];
integer lastla[3];
extern /* Subroutine */ int dasurd_(integer *, integer *, integer *,
integer *, doublereal *), daswrd_(integer *, integer *,
doublereal *);
integer lastrc[3], clsize;
extern /* Subroutine */ int chkout_(char *, ftnlen);
integer lastwd[3], nresvc, wordno;
extern logical return_(void);
integer nresvr, nwritn;
/* $ Abstract */
/* Add an array of double precision numbers to a DAS file. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAS */
/* $ Keywords */
/* ARRAY */
/* ASSIGNMENT */
/* DAS */
/* FILES */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I DAS file handle. */
/* N I Number of d.p. numbers to add to DAS file. */
/* DATA I Array of d.p. numbers to add. */
/* $ Detailed_Input */
/* HANDLE is a file handle of a DAS file opened for writing. */
/* N is a the number of double precision `words' to */
/* add to the DAS file specified by HANDLE. */
/* DATA is an array of double precision numbers to be */
/* added to the specified DAS file. Elements */
/* 1 through N are appended to the double precision */
/* data in the file. */
/* $ Detailed_Output */
/* None. See $Particulars for a description of the effect of this */
/* routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input file handle is invalid, the error will be */
/* diagnosed by routines called by this routine. */
/* 2) If an I/O error occurs during the data addition attempted */
/* by this routine, the error will be diagnosed by routines */
/* called by this routine. */
/* 3) If the input count N is less than 1, no data will be */
/* added to the specified DAS file. */
/* $ Files */
/* See the description of the argument HANDLE in $Detailed_Input. */
/* $ Particulars */
/* This routine adds double precision data to a DAS file by */
/* `appending' it after any double precision data already in the */
/* file. The sense in which the data is `appended' is that the */
/* data will occupy a range of logical addresses for double precision */
/* data that immediately follow the last logical address of a double */
/* precision number that is occupied at the time this routine is */
/* called. The diagram below illustrates this addition: */
/* +-------------------------+ */
/* | (already in use) | D.p. logical address 1 */
/* +-------------------------+ */
/* . */
/* . */
/* . */
/* +-------------------------+ */
/* | (already in use) | Last d.p. logical address */
/* +-------------------------+ in use before call to DASADD */
/* | DATA(1) | */
/* +-------------------------+ */
/* . */
/* . */
/* . */
/* +-------------------------+ */
/* | DATA(N) | */
/* +-------------------------+ */
/* The logical organization of the double precision numbers in the */
/* DAS file is independent of the order of addition to the file or */
/* physical location of any data of integer or character type. */
/* The actual physical write operations that add the input array */
/* DATA to the indicated DAS file may not take place before this */
/* routine returns, since the DAS system buffers data that is */
/* written as well as data that is read. In any case, the data */
/* will be flushed to the file at the time the file is closed, if */
/* not earlier. A physical write of all buffered records can be */
/* forced by calling the SPICELIB routine DASWBR ( DAS, write */
/* buffered records ). */
/* In order to update double precision logical addresses that */
/* already contain data, the SPICELIB routine DASUDD */
/* ( DAS update data, double precision ) should be used. */
/* $ Examples */
/* 1) Create the new DAS file TEST.DAS and add 200 double */
/* precision numbers to it. Close the file, then re-open */
/* it and read the data back out. */
/* PROGRAM TEST_ADD */
/* CHARACTER*(4) TYPE */
/* DOUBLE PRECISION DATA ( 200 ) */
/* INTEGER HANDLE */
/* INTEGER I */
/* C */
/* C Open a new DAS file. Use the file name as */
/* C the internal file name. */
/* C */
/* TYPE = 'TEST' */
/* CALL DASONW ( 'TEST.DAS', TYPE, 'TEST.DAS', HANDLE ) */
/* C */
/* C Fill the array DATA with the double precision */
/* C numbers 1.D0 through 100.D0, and add this array */
/* C to the file. */
/* C */
/* DO I = 1, 100 */
/* DATA(I) = DBLE(I) */
/* END DO */
/* CALL DASADD ( HANDLE, 100, DATA ) */
/* C */
/* C Now append the array DATA to the file again. */
/* C */
/* CALL DASADD ( HANDLE, 100, DATA ) */
/* C */
/* C Close the file. */
/* C */
/* CALL DASCLS ( HANDLE ) */
/* C */
/* C Now verify the addition of data by opening the */
/* C file for read access and retrieving the data. */
/* C */
/* CALL DASRDD ( HANDLE, 1, 200, DATA ) */
/* C */
/* C Dump the data to the screen. We should see the */
/* C sequence 1, 2, ..., 100, 1, 2, ... , 100. The */
/* C numbers will be represented as double precision */
/* C numbers in the output. */
/* C */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) 'Data from TEST.DAS: ' */
/* WRITE (*,*) ' ' */
/* WRITE (*,*) DATA */
/* END */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.2.0 10-APR-2014 (NJB) */
/* Deleted declarations of unused parameters. */
/* Corrected header comments: routine that flushes */
/* written, buffered records is DASWBR, not DASWUR. */
/* - SPICELIB Version 1.1.1 19-DEC-1995 (NJB) */
/* Corrected title of permuted index entry section. */
/* - SPICELIB Version 1.1.0, 12-MAY-1994 (KRG) (NJB) */
/* Test of FAILED() added to loop termination condition. */
/* Removed references to specific DAS file open routines in the */
/* $ Detailed_Input section of the header. This was done in order */
/* to minimize documentation changes if the DAS open routines ever */
/* change. */
/* Modified the $ Examples section to demonstrate the new ID word */
/* format which includes a file type and to include a call to the */
/* new routine DASONW, open new, which makes use of the file */
/* type. Also, a variable for the type of the file to be created */
/* was added. */
/* - SPICELIB Version 1.0.0, 11-NOV-1992 (NJB) (WLT) */
/* -& */
/* $ Index_Entries */
/* add double precision data to a DAS file */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 12-MAY-1994 (KRG) (NJB) */
/* Test of FAILED() added to loop termination condition. Without */
/* this test, an infinite loop could result if DASA2L, DASURD or */
/* DASWRD signaled an error inside the loop. */
/* Removed references to specific DAS file open routines in the */
/* $ Detailed_Input section of the header. This was done in order */
/* to minimize documentation changes if the DAS open routines ever */
/* change. */
/* Modified the $ Examples section to demonstrate the new ID word */
/* format which includes a file type and to include a call to the */
/* new routine DASONW, open new, which makes use of the file */
/* type. Also, a variable for the type of the file to be created */
/* was added. */
/* - SPICELIB Version 1.0.0, 11-NOV-1992 (NJB) (WLT) */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("DASADD", (ftnlen)6);
}
/* Get the file summary for this DAS. */
dashfs_(handle, &nresvr, &nresvc, &ncomr, &ncomc, &free, lastla, lastrc,
lastwd);
lastd = lastla[1];
/* We will keep track of the location that we wish to write to */
/* with the variables RECNO and WORDNO. RECNO will be the record */
/* number of the record we'll write to; WORDNO will be the number */
/* preceding the word index, within record number RECNO, that we'll */
/* write to. For example, if we're about to write to the first */
/* double precision number in record 10, RECNO will be 10 and */
/* WORDNO will be 0. Of course, when WORDNO reaches NWD, we'll */
/* have to find a free record before writing anything. */
/* Prepare the variables RECNO and WORDNO: use the physical */
/* location of the last double precision address, if there are any */
/* double precision data in the file. Otherwise, RECNO becomes the */
/* first record available for double precision data. */
if (lastd >= 1) {
dasa2l_(handle, &c__2, &lastd, &clbase, &clsize, &recno, &wordno);
} else {
recno = free;
wordno = 0;
}
/* Set the number of double precision words already written. Keep */
/* writing to the file until this number equals the number of */
/* elements in DATA. */
/* Note that if N is non-positive, the loop doesn't get exercised. */
nwritn = 0;
while(nwritn < *n && ! failed_()) {
/* Write as much data as we can (or need to) into the current */
/* record. We assume that RECNO, WORDNO, and NWRITN have been */
/* set correctly at this point. */
/* Find out how many words to write into the current record. */
/* There may be no space left in the current record. */
/* Computing MIN */
i__1 = *n - nwritn, i__2 = 128 - wordno;
numdp = min(i__1,i__2);
if (numdp > 0) {
/* Write NUMDP words into the current record. If the record */
/* is new, write the entire record. Otherwise, just update */
/* the part we're interested in. */
if (wordno == 0) {
moved_(&data[nwritn], &numdp, record);
daswrd_(handle, &recno, record);
} else {
i__1 = wordno + 1;
i__2 = wordno + numdp;
dasurd_(handle, &recno, &i__1, &i__2, &data[nwritn]);
}
nwritn += numdp;
wordno += numdp;
} else {
/* It's time to start on a new record. If the record we */
/* just finished writing to (or just attempted writing to, */
/* if it was full) was FREE or a higher-numbered record, */
/* then we are writing to a contiguous set of data records: */
/* the next record to write to is the immediate successor */
/* of the last one. Otherwise, FREE is the next record */
/* to write to. */
/* We intentionally leave FREE at the value it had before */
/* we starting adding data to the file. */
if (recno >= free) {
++recno;
} else {
recno = free;
}
wordno = 0;
}
}
/* Update the DAS file directories to reflect the addition of N */
/* double precision words. DASCUD will also update the file summary */
/* accordingly. */
dascud_(handle, &c__2, n);
chkout_("DASADD", (ftnlen)6);
return 0;
} /* dasadd_ */
/* $Procedure DASWFR ( DAS write file record ) */
/* Subroutine */ int daswfr_(integer *handle, char *idword, char *ifname,
integer *nresvr, integer *nresvc, integer *ncomr, integer *ncomc,
ftnlen idword_len, ftnlen ifname_len)
{
/* Builtin functions */
integer s_rdue(cilist *), do_uio(integer *, char *, ftnlen), e_rdue(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wdue(cilist *), e_wdue(void);
/* Local variables */
integer free;
char tail[932];
integer unit;
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern logical failed_(void);
integer oldcch, locncc, oldcrc;
extern /* Subroutine */ int dashfs_(integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *);
char locifn[60];
integer oldrch;
extern /* Subroutine */ int dassih_(integer *, char *, ftnlen);
integer lastla[3];
char locidw[8];
integer locncr, locnvc, oldrrc;
char format[8];
integer lastrc[3];
extern /* Subroutine */ int dashlu_(integer *, integer *), errfnm_(char *,
integer *, ftnlen), chkout_(char *, ftnlen);
integer lastwd[3];
extern /* Subroutine */ int sigerr_(char *, ftnlen), dasufs_(integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *), setmsg_(char *, ftnlen);
integer iostat, locnvr;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
extern logical return_(void);
char ifn[60];
/* Fortran I/O blocks */
static cilist io___3 = { 1, 0, 1, 0, 1 };
static cilist io___13 = { 1, 0, 0, 0, 1 };
/* $ Abstract */
/* Update the contents of the file record of a specified DAS file. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAS */
/* $ Keywords */
/* DAS */
/* FILES */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I DAS file handle. */
/* IDWORD I ID word. */
/* IFNAME I DAS internal file name. */
/* NRESVR I Number of reserved records in file. */
/* NRESVC I Number of characters in use in reserved rec. area. */
/* NCOMR I Number of comment records in file. */
/* NCOMC I Number of characters in use in comment area. */
/* $ Detailed_Input */
/* HANDLE is a file handle for a DAS file open for writing. */
/* IDWORD is the `ID word' contained in the first eight */
/* characters of the file record. */
/* IFNAME is the internal file name of the DAS file. The */
/* maximum length of the internal file name is 60 */
/* characters. */
/* NRESVR is the number of reserved records in the DAS file */
/* specified by HANDLE. */
/* NRESVC is the number of characters in use in the reserved */
/* record area of the DAS file specified by HANDLE. */
/* NCOMR is the number of comment records in the DAS file */
/* specified by HANDLE. */
/* NCOMC is the number of characters in use in the comment area */
/* of the DAS file specified by HANDLE. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the handle passed to this routine is not the handle of an */
/* open DAS file, the error will be signaled by a routine called */
/* by this routine. */
/* 2) If the specified DAS file is not open for write access, the */
/* error will be diagnosed by a routine called by this routine. */
/* 3) If the attempt to read the file record fails, the error */
/* SPICE(DASREADFAIL) is signaled. */
/* 4) If the file write attempted by this routine fails, the error */
/* SPICE(DASFILEWRITEFAILED) is signaled. */
/* $ Files */
/* See the description of HANDLE under $Detailed_Input. */
/* $ Particulars */
/* This routine provides a convenient way of updating the internal */
/* file name of a DAS file. */
/* The `ID word' contained in the file record is a string of eight */
/* characters that identifies the file as a DAS file and optionally */
/* indicates a specific file format, for example, `EK'. */
/* $ Examples */
/* 1) Update the internal file name of an existing DAS file. */
/* C */
/* C Open the file for writing. */
/* C */
/* CALL DASOPW ( FNAME, HANDLE ) */
/* C */
/* C Retrieve the ID word and current reserved record */
/* C and comment area record and character counts. */
/* C */
/* CALL DASRFR ( HANDLE, */
/* . IDWORD, */
/* . IFNAME, */
/* . NRESVR, */
/* . NRESVC, */
/* . NCOMR, */
/* . NCOMC ) */
/* C */
/* C Set the internal file name and update the file */
/* C with it. */
/* C */
/* IFNAME = 'New internal file name' */
/* CALL DASWFR ( HANDLE, */
/* . IDWORD, */
/* . IFNAME, */
/* . NRESVR, */
/* . NRESVC, */
/* . NCOMR, */
/* . NCOMC ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* F.S. Turner (JPL) */
/* $ Version */
/* - SPICELIB Version 3.0.0, 11-DEC-2001 (FST) */
/* This routine was modified to accomodate the preservation */
/* of the FTP validation and binary file format strings that */
/* are not part of the DAS file record. */
/* - SPICELIB Version 2.0.0, 27-OCT-1993 (KRG) */
/* Removed references to specific DAS file open routines in the */
/* $ Detailed_Input section of the header. This was done in order */
/* to minimize documentation changes if these open routines ever */
/* change. */
/* Added a check of FAILED after the call to DASHLU which will */
/* check out and return if DASHLU fails. This is so that when in */
/* return mode of the error handling the READ following the call */
/* to DASHLU will not be executed. */
/* Reworded some of the descriptions contained in the */
/* $ Detailed_Output section of the header so that they were more */
/* clear. */
/* - SPICELIB Version 1.0.0, 24-NOV-1992 (NJB) (WLT) */
/* -& */
/* $ Index_Entries */
/* write DAS file record */
/* write DAS internal file name */
/* update DAS internal file name */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 3.0.0, 11-DEC-2001 (FST) */
/* In order to preserve the additional information that */
/* now resides in the file record, this routine reads */
/* the entire record into local buffers, including the */
/* TAILEN characters that follow the actual data content. */
/* The contents of the local buffers that correspond to */
/* information brought in from the call sequence of the */
/* routine are ignored when the record is rewritten. */
/* However, the ID word, the file format string, and the */
/* trailing TAILEN characters that contain the FTP validation */
/* string are rewritten along with the input values. */
/* This routine does not simply replace the FTP validation */
/* string with the components from ZZFTPSTR, since that */
/* would possibly validate a corrupt file created using a newer */
/* Toolkit. */
/* The string arguments passed into this routine are now */
/* copied to local buffers of the appropriate length. */
/* - SPICELIB Version 2.0.0, 27-OCT-1993 (KRG) */
/* Removed references to specific DAS file open routines in the */
/* $ Detailed_Input section of the header. This was done in order */
/* to minimize documentation changes if these open routines ever */
/* change. */
/* Added a check of FAILED after the call to DASHLU which will */
/* check out and return if DASHLU fails. This is so that when in */
/* return mode of the error handling the READ following the call */
/* to DASHLU will not be executed. */
/* Reworded some of the descriptions contained in the */
/* $ Detailed_Output section of the header so that they were more */
/* clear. */
/* - SPICELIB Version 1.0.0, 24-NOV-1992 (NJB) (WLT) */
/* -& */
/* SPICELIB functions */
/* Local Parameters */
/* The parameter TAILEN determines the tail length of a DAS file */
/* record. This is the number of bytes (characters) that */
/* occupy the portion of the file record that follows the */
/* integer holding the first free address. For environments */
/* with a 32 bit word length, 1 byte characters, and DAS */
/* record sizes of 1024 bytes, we have: */
/* 8 bytes - IDWORD */
/* 60 bytes - IFNAME */
/* 4 bytes - NRESVR (32 bit integer) */
/* 4 bytes - NRESVC (32 bit integer) */
/* 4 bytes - NCOMR (32 bit integer) */
/* + 4 bytes - NCOMC (32 bit integer) */
/* --------- */
/* 84 bytes - (All file records utilize this space.) */
/* So the size of the remaining portion (or tail) of the DAS */
/* file record for computing enviroments as described above */
/* would be: */
/* 1024 bytes - DAS record size */
/* - 8 bytes - DAS Binary File Format Word */
/* - 84 bytes - (from above) */
/* ------------ */
/* 932 bytes - DAS file record tail length */
/* Note: environments that do not have a 32 bit word length, */
/* 1 byte characters, and a DAS record size of 1024 bytes, will */
/* require the adjustment of this parameter. */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("DASWFR", (ftnlen)6);
}
/* Check to be sure that HANDLE is attached to a file that is open */
/* with write access. If the call fails, check out and return. */
dassih_(handle, "WRITE", (ftnlen)5);
/* Get the logical unit for this DAS file. */
dashlu_(handle, &unit);
if (failed_()) {
chkout_("DASWFR", (ftnlen)6);
return 0;
}
/* In order to maintain the integrity of the file ID word, the */
/* file FORMAT, and the FTP string if present, we need to */
/* read the entire file record into the appropriate sized local */
/* buffers. The values of the LOCxxx variables are simply */
/* ignored, since the caller passes new values in for updates. */
io___3.ciunit = unit;
iostat = s_rdue(&io___3);
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, locidw, (ftnlen)8);
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, locifn, (ftnlen)60);
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, (char *)&locnvr, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, (char *)&locnvc, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, (char *)&locncr, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, (char *)&locncc, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, format, (ftnlen)8);
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, tail, (ftnlen)932);
if (iostat != 0) {
goto L100001;
}
iostat = e_rdue();
L100001:
if (iostat != 0) {
setmsg_("Attempt to read the file record failed for file '#'. IOSTAT"
" = #", (ftnlen)63);
errfnm_("#", &unit, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DASREADFAIL)", (ftnlen)18);
chkout_("DASWFR", (ftnlen)6);
return 0;
}
/* Set the value of the internal file name and IDWORD before */
/* writing. This is to guarantee that their lengths are ok. */
s_copy(ifn, ifname, (ftnlen)60, ifname_len);
s_copy(locidw, idword, (ftnlen)8, idword_len);
io___13.ciunit = unit;
iostat = s_wdue(&io___13);
if (iostat != 0) {
goto L100002;
}
iostat = do_uio(&c__1, locidw, (ftnlen)8);
if (iostat != 0) {
goto L100002;
}
iostat = do_uio(&c__1, ifn, (ftnlen)60);
if (iostat != 0) {
goto L100002;
}
iostat = do_uio(&c__1, (char *)&(*nresvr), (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100002;
}
iostat = do_uio(&c__1, (char *)&(*nresvc), (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100002;
}
iostat = do_uio(&c__1, (char *)&(*ncomr), (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100002;
}
iostat = do_uio(&c__1, (char *)&(*ncomc), (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100002;
}
iostat = do_uio(&c__1, format, (ftnlen)8);
if (iostat != 0) {
goto L100002;
}
iostat = do_uio(&c__1, tail, (ftnlen)932);
if (iostat != 0) {
goto L100002;
}
iostat = e_wdue();
L100002:
if (iostat != 0) {
setmsg_("Could not write file record. File was #. IOSTAT was #.", (
ftnlen)56);
errfnm_("#", &unit, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DASFILEWRITEFAILED)", (ftnlen)25);
chkout_("DASWFR", (ftnlen)6);
return 0;
}
/* Update the file summary, in case the values of the reserved */
/* record or comment area counts have changed. */
dashfs_(handle, &oldrrc, &oldrch, &oldcrc, &oldcch, &free, lastla, lastrc,
lastwd);
dasufs_(handle, nresvr, nresvc, ncomr, ncomc, &free, lastla, lastrc,
lastwd);
chkout_("DASWFR", (ftnlen)6);
return 0;
} /* daswfr_ */
/* $Procedure DASA2L ( DAS, address to physical location ) */
/* Subroutine */ int dasa2l_(integer *handle, integer *type__, integer *
addrss, integer *clbase, integer *clsize, integer *recno, integer *
wordno)
{
/* Initialized data */
static integer next[3] = { 2,3,1 };
static integer prev[3] = { 3,1,2 };
static integer nw[3] = { 1024,128,256 };
static integer rngloc[3] = { 3,5,7 };
static logical first = TRUE_;
static integer nfiles = 0;
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Local variables */
static integer free, nrec, fidx;
static logical fast;
static integer unit, i__, range[2], tbhan[20];
extern /* Subroutine */ int chkin_(char *, ftnlen);
static integer ncomc, ncomr, ndirs;
static logical known;
static integer hiaddr;
extern /* Subroutine */ int dasham_(integer *, char *, ftnlen);
static integer tbbase[60] /* was [3][20] */;
static char access[10];
static integer dscloc, dirrec[256];
extern /* Subroutine */ int dashfs_(integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *);
static logical samfil;
static integer mxaddr;
extern integer isrchi_(integer *, integer *, integer *);
static integer tbmxad[60] /* was [3][20] */;
static logical tbfast[20];
static integer mxclrc;
extern /* Subroutine */ int dashlu_(integer *, integer *), errfnm_(char *,
integer *, ftnlen);
static integer lstrec[3];
extern /* Subroutine */ int sigerr_(char *, ftnlen);
static integer prvhan;
extern /* Subroutine */ int chkout_(char *, ftnlen);
static integer nresvc, tbsize[60] /* was [3][20] */, nxtrec;
extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen), dasrri_(integer *, integer *, integer *,
integer *, integer *);
static logical rdonly;
static integer lstwrd[3], nresvr, ntypes, curtyp, prvtyp;
/* $ Abstract */
/* Map a DAS address to a physical location in the DAS file */
/* it refers to. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAS */
/* $ Keywords */
/* DAS */
/* FILES */
/* TRANSFORMATION */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I DAS file handle. */
/* TYPE I Data type specifier. */
/* ADDRSS I DAS address of a word of data type TYPE. */
/* CLBASE, */
/* CLSIZE O Cluster base record number and size. */
/* RECNO, */
/* WORDNO O Record/word pair corresponding to ADDRSS. */
/* CHAR P Parameter indicating character data type. */
/* DP P Parameter indicating double precision data type. */
/* INT P Parameter indicating integer data type. */
/* $ Detailed_Input */
/* HANDLE is the file handle of an open DAS file. */
/* TYPE is a data type specifier. TYPE may be any of */
/* the parameters */
/* CHAR */
/* DP */
/* INT */
/* which indicate `character', `double precision', */
/* and `integer' respectively. */
/* ADDRSS is the address in a DAS of a word of data */
/* type TYPE. For each data type (double precision, */
/* integer, or character), addresses range */
/* from 1 to the maximum current value for that type, */
/* which is available from DAFRFR. */
/* $ Detailed_Output */
/* CLBASE, */
/* CLSIZE are, respectively, the base record number and */
/* size, in records, of the cluster containing the */
/* word corresponding to ADDRSS. The cluster spans */
/* records numbered CLBASE through CLBASE + */
/* CLSIZE - 1. */
/* RECNO, */
/* WORD are, respectively, the number of the physical */
/* record and the number of the word within the */
/* record that correspond to ADDRSS. Word numbers */
/* start at 1 and go up to NC, ND, or NI in */
/* character, double precision, or integer records */
/* respectively. */
/* $ Parameters */
/* CHAR, */
/* DP, */
/* INT are data type specifiers which indicate */
/* `character', `double precision', and `integer' */
/* respectively. These parameters are used in */
/* all DAS routines that require a data type */
/* specifier as input. */
/* $ Exceptions */
/* 1) If TYPE is not recognized, the error SPICE(DASINVALIDTYPE) */
/* will be signalled. */
/* 2) ADDRSS must be between 1 and LAST inclusive, where LAST */
/* is last address in the DAS for a word of the specified */
/* type. If ADDRSS is out of range, the error */
/* SPICE(DASNOSUCHADDRESS) will be signalled. */
/* 3) If this routine fails to find directory information for */
/* the input address, the error SPICE(NOSUCHRECORD) will be */
/* signalled. */
/* 4) If the input handle is invalid, the error will be diagnosed */
/* by routines called by this routine. */
/* If any of the above exceptions occur, the output arguments may */
/* contain bogus information. */
/* $ Files */
/* See the description of the argument HANDLE in $Detailed_Input. */
/* $ Particulars */
/* The DAS architecture allows a programmer to think of the data */
/* within a DAS file as three one-dimensional arrays: one of */
/* double precision numbers, one of integers, and one of characters. */
/* This model allows a programmer to ask the DAS system for the */
/* `nth double precision number (or integer, or character) in the */
/* file'. */
/* DAS files are Fortran direct access files, so to find the */
/* `nth double precision number', you must have the number of the */
/* record containing it and the `word number', or position, within */
/* the record of the double precision number. This routine finds */
/* the record/word number pair that specify the physical location */
/* in a DAS file corresponding to a DAS address. */
/* As opposed to DAFs, the mapping of addresses to physical locations */
/* for a DAS file depends on the organization of data in the file. */
/* Given a fixed set of DAS format parameters, the physical location */
/* of the nth double precision number can depend on how many integer */
/* and character records have been written prior to the record */
/* containing that double precision number. */
/* The cluster information output from this routine allows the */
/* caller to substantially reduce the number of directory reads */
/* required to read a from range of addresses that spans */
/* multiple physical records; the reading program only need call */
/* this routine once per cluster read, rather than once per */
/* physical record read. */
/* $ Examples */
/* 1) Use this routine to read integers from a range of */
/* addresses. This is done in the routine DASRDI. */
/* C */
/* C Decide how many integers to read. */
/* C */
/* NUMINT = LAST - FIRST + 1 */
/* NREAD = 0 */
/* C */
/* C Find out the physical location of the first */
/* C integer. If FIRST is invalid, DASA2L will take care */
/* C of the problem. */
/* C */
/* CALL DASA2L ( HANDLE, INT, FIRST, */
/* . CLBASE, CLSIZE, RECNO, WORDNO ) */
/* C */
/* C Read as much data from record RECNO as necessary. */
/* C */
/* N = MIN ( NUMINT, NWI - WORDNO + 1 ) */
/* CALL DASRRI ( HANDLE, RECNO, WORDNO, WORDNO + N-1, */
/* . DATA ) */
/* NREAD = N */
/* RECNO = RECNO + 1 */
/* C */
/* C Read from as many additional records as necessary. */
/* C */
/* DO WHILE ( NREAD .LT. NUMINT ) */
/* C */
/* C At this point, RECNO is the correct number of the */
/* C record to read from next. CLBASE is the number */
/* C of the first record of the cluster we're about */
/* C to read from. */
/* C */
/* IF ( RECNO .LT. ( CLBASE + CLSIZE ) ) THEN */
/* C */
/* C We can continue reading from the current */
/* C cluster. */
/* C */
/* N = MIN ( NUMINT - NREAD, NWI ) */
/* CALL DASRRI ( HANDLE, */
/* . RECNO, */
/* . 1, */
/* . N, */
/* . DATA ( NREAD + 1 ) ) */
/* NREAD = NREAD + N */
/* RECNO = RECNO + 1 */
/* ELSE */
/* C */
/* C We must find the next integer cluster to */
/* C read from. The first integer in this */
/* C cluster has address FIRST + NREAD. */
/* C */
/* CALL DASA2L ( HANDLE, */
/* . INT, */
/* . FIRST + NREAD, */
/* . CLBASE, */
/* . CLSIZE, */
/* . RECNO, */
/* . WORDNO ) */
/* END IF */
/* END DO */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.2.1 20-NOV-2001 (NJB) */
/* Comment fix: diagram showing directory record pointers */
/* incorrectly showed element 2 of the record as a backward */
/* pointer. The element is actually a forward pointer. */
/* - SPICELIB Version 1.2.0 03-JUL-1996 (NJB) */
/* Bug fix: calculation to determine whether file is segregated */
/* has been fixed. */
/* - SPICELIB Version 1.1.1 19-DEC-1995 (NJB) */
/* Corrected title of permuted index entry section. */
/* - SPICELIB Version 1.1.0, 03-NOV-1995 (NJB) */
/* Re-written to optimize address calculations for segregated, */
/* read-only files. */
/* - SPICELIB Version 1.0.1, 26-OCT-1993 (KRG) */
/* Fixed a typo in the $ Brief_I/O section of the header. */
/* Removed references to specific DAS file open routines in the */
/* $ Detailed_Input section of the header. This was done in order */
/* to minimize documentation changes if the DAS open routines ever */
/* change. */
/* - SPICELIB Version 1.0.0, 11-NOV-1992 (NJB) (WLT) */
/* -& */
/* $ Index_Entries */
/* map DAS logical address to physical location */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.2.0 03-JUL-1996 (NJB) */
/* Bug fix: calculation to determine whether file is segregated */
/* has been fixed. An incorrect variable name used in a bound */
/* calculation resulted in an incorrect determination of whether */
/* a file was segregated, and caused arithmetic overflow for */
/* files with large maximum addresses. */
/* In the previous version, the number of DAS words in a cluster */
/* was incorrectly calculated as the product of the maximum */
/* address of the cluster's data type and the number of words of */
/* that data type in a DAS record. The correct product involves */
/* the number of records in the cluster and the number of words of */
/* that data type in a DAS record. */
/* - SPICELIB Version 1.1.0, 03-NOV-1995 (NJB) */
/* Re-written to optimize address calculations for segregated, */
/* read-only files. */
/* - SPICELIB Version 1.0.1, 26-OCT-1993 (KRG) */
/* Fixed a typo in the $ Brief_I/O section of the header. */
/* Removed references to specific DAS file open routines in the */
/* $ Detailed_Input section of the header. This was done in order */
/* to minimize documentation changes if the DAS open routines ever */
/* change. */
/* - SPICELIB Version 1.0.0, 11-NOV-1992 (NJB) (WLT) */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Words per data record, for each data type: */
/* Directory pointer locations */
/* Directory address range locations */
/* Indices of lowest and highest addresses in a `range array': */
/* Location of first type descriptor */
/* Access word length */
/* File table size */
/* Local variables */
/* Saved variables */
/* Initial values */
/* NEXT and PREV map the DAS data type codes to their */
/* successors and predecessors, respectively. */
/* Discovery check-in is used in this routine. */
/* DAS files have the following general structure: */
/* +------------------------+ */
/* | file record | */
/* +------------------------+ */
/* | reserved records | */
/* | | */
/* +------------------------+ */
/* | comment records | */
/* | | */
/* | | */
/* | | */
/* +------------------------+ */
/* | first data directory | */
/* +------------------------+ */
/* | data records | */
/* | | */
/* | | */
/* | | */
/* | | */
/* +------------------------+ */
/* . */
/* . */
/* +------------------------+ */
/* | last data directory | */
/* +------------------------+ */
/* | data records | */
/* | | */
/* | | */
/* +------------------------+ */
/* Within each DAS data record, word numbers start at one and */
/* increase up to NWI, NWD, or NWC: the number of words in an */
/* integer, double precision, or character data record. */
/* +--------------------------------+ */
/* | | | ... | | */
/* +--------------------------------+ */
/* 1 2 NWD */
/* +--------------------------------+ */
/* | | | ... | | */
/* +--------------------------------+ */
/* 1 2 NWI */
/* +------------------------------------+ */
/* | | | ... | | */
/* +------------------------------------+ */
/* 1 2 NWC */
/* Directories are single records that describe the data */
/* types of data records that follow. The directories */
/* in a DAS file form a doubly linked list: each directory */
/* contains forward and backward pointers to the next and */
/* previous directories. */
/* Each directory also contains, for each data type, the lowest */
/* and highest logical address occurring in any of the records */
/* described by the directory. */
/* Following the pointers and address range information is */
/* a sequence of data type descriptors. These descriptors */
/* indicate the data type of data records following the */
/* directory record. Each descriptor gives the data type */
/* of a maximal set of contiguous data records, all having the */
/* same type. By `maximal set' we mean that no data records of */
/* the same type bound the set of records in question. */
/* Pictorially, the structure of a directory is as follows: */
/* +----------------------------------------------------+ */
/* | <pointers> | <address ranges> | <type descriptors> | */
/* +----------------------------------------------------+ */
/* where the <pointers> section looks like */
/* +-----------------------------------------+ */
/* | <backward pointer> | <forward pointer> | */
/* +-----------------------------------------+ */
/* the <address ranges> section looks like */
/* +-------------------------------------------+ */
/* | <char range> | <d.p. range> | <int range> | */
/* +-------------------------------------------+ */
/* and each range looks like one of: */
/* +------------------------------------------------+ */
/* | <lowest char address> | <highest char address> | */
/* +------------------------------------------------+ */
/* +------------------------------------------------+ */
/* | <lowest d.p. address> | <highest d.p. address> | */
/* +------------------------------------------------+ */
/* +------------------------------------------------+ */
/* | <lowest int address> | <highest int address> | */
/* +------------------------------------------------+ */
/* The type descriptors implement a run-length encoding */
/* scheme. The first element of the series of descriptors */
/* occupies two integers: it contains a type code and a count. */
/* The rest of the descriptors are just signed counts; the data */
/* types of the records they describe are deduced from the sign */
/* of the count and the data type of the previous descriptor. */
/* The method of finding the data type for a given descriptor */
/* in terms of its predecessor is as follows: if the sign of a */
/* descriptor is positive, the type of that descriptor is the */
/* successor of the type of the preceding descriptor in the */
/* sequence of types below. If the sign of a descriptor is */
/* negative, the type of the descriptor is the predecessor of the */
/* type of the preceding descriptor. */
/* C --> D --> I --> C */
/* For example, if the preceding type is `I', and a descriptor */
/* contains the number 16, the type of the descriptor is `C', */
/* whereas if the descriptor contained the number -800, the type */
/* of the descriptor would be `D'. */
/* Make sure the data type is valid. */
if (*type__ < 1 || *type__ > 3) {
chkin_("DASA2L", (ftnlen)6);
dashlu_(handle, &unit);
setmsg_("Invalid data type: #. File was #", (ftnlen)33);
errint_("#", type__, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(DASINVALIDTYPE)", (ftnlen)21);
chkout_("DASA2L", (ftnlen)6);
return 0;
}
/* Decide whether we're looking at the same file as we did on */
/* the last call. */
if (first) {
samfil = FALSE_;
fast = FALSE_;
prvhan = *handle;
first = FALSE_;
} else {
samfil = *handle == prvhan;
prvhan = *handle;
}
/* We have a special case if we're looking at a `fast' file */
/* that we saw on the last call. When we say a file is fast, */
/* we're implying that it's open for read access only and that it's */
/* segregated. In this case, we can do an address calculation */
/* without looking up any information from the file. */
if (samfil && fast) {
*clbase = tbbase[(i__1 = *type__ + fidx * 3 - 4) < 60 && 0 <= i__1 ?
i__1 : s_rnge("tbbase", i__1, "dasa2l_", (ftnlen)666)];
*clsize = tbsize[(i__1 = *type__ + fidx * 3 - 4) < 60 && 0 <= i__1 ?
i__1 : s_rnge("tbsize", i__1, "dasa2l_", (ftnlen)667)];
mxaddr = tbmxad[(i__1 = *type__ + fidx * 3 - 4) < 60 && 0 <= i__1 ?
i__1 : s_rnge("tbmxad", i__1, "dasa2l_", (ftnlen)668)];
hiaddr = *clsize * nw[(i__1 = *type__ - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("nw", i__1, "dasa2l_", (ftnlen)669)];
/* Make sure that ADDRSS points to an existing location. */
if (*addrss < 1 || *addrss > mxaddr) {
chkin_("DASA2L", (ftnlen)6);
dashlu_(handle, &unit);
setmsg_("ADDRSS was #; valid range for type # is # to #. File w"
"as #", (ftnlen)59);
errint_("#", addrss, (ftnlen)1);
errint_("#", type__, (ftnlen)1);
errint_("#", &c__1, (ftnlen)1);
errint_("#", &mxaddr, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(DASNOSUCHADDRESS)", (ftnlen)23);
chkout_("DASA2L", (ftnlen)6);
return 0;
}
} else {
/* If the current file is not the same one we looked at on the */
/* last call, find out whether the file is on record in our file */
/* table. Add the file to the table if necessary. Bump the */
/* oldest file in the table if there's no room. */
if (! samfil) {
fidx = isrchi_(handle, &nfiles, tbhan);
known = fidx > 0;
if (known) {
/* The file is in our list. */
fast = tbfast[(i__1 = fidx - 1) < 20 && 0 <= i__1 ? i__1 :
s_rnge("tbfast", i__1, "dasa2l_", (ftnlen)708)];
if (fast) {
/* This is a segregated, read-only file. Look up the */
/* saved information we'll need to calculate addresses. */
*clbase = tbbase[(i__1 = *type__ + fidx * 3 - 4) < 60 &&
0 <= i__1 ? i__1 : s_rnge("tbbase", i__1, "dasa2"
"l_", (ftnlen)715)];
*clsize = tbsize[(i__1 = *type__ + fidx * 3 - 4) < 60 &&
0 <= i__1 ? i__1 : s_rnge("tbsize", i__1, "dasa2"
"l_", (ftnlen)716)];
mxaddr = tbmxad[(i__1 = *type__ + fidx * 3 - 4) < 60 && 0
<= i__1 ? i__1 : s_rnge("tbmxad", i__1, "dasa2l_",
(ftnlen)717)];
hiaddr = *clsize * nw[(i__1 = *type__ - 1) < 3 && 0 <=
i__1 ? i__1 : s_rnge("nw", i__1, "dasa2l_", (
ftnlen)718)];
/* Make sure that ADDRSS points to an existing location. */
if (*addrss < 1 || *addrss > mxaddr) {
chkin_("DASA2L", (ftnlen)6);
dashlu_(handle, &unit);
setmsg_("ADDRSS was #; valid range for type # is # "
"to #. File was #", (ftnlen)60);
errint_("#", addrss, (ftnlen)1);
errint_("#", type__, (ftnlen)1);
errint_("#", &c__1, (ftnlen)1);
errint_("#", &mxaddr, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(DASNOSUCHADDRESS)", (ftnlen)23);
chkout_("DASA2L", (ftnlen)6);
return 0;
}
}
/* FAST is set. */
}
/* KNOWN is set. */
}
/* SAMFIL, FAST, and KNOWN are set. If the file is the same one */
/* we saw on the last call, the state variables FAST, and KNOWN */
/* retain their values from the previous call. */
/* FIDX is set at this point only if we're looking at a known */
/* file. */
/* Unless the file is recognized and known to be a fast file, we */
/* look up all metadata for the file. */
if (! (known && fast)) {
if (! known) {
/* This file is not in our list. If the list is not full, */
/* append the file to the list. If the list is full, */
/* replace the oldest (first) file with this one. */
if (nfiles < 20) {
++nfiles;
fidx = nfiles;
} else {
fidx = 1;
}
tbhan[(i__1 = fidx - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge(
"tbhan", i__1, "dasa2l_", (ftnlen)781)] = *handle;
/* Find out whether the file is open for read or write */
/* access. We consider the file to be `slow' until we find */
/* out otherwise. The contents of the arrays TBHIGH, */
/* TBBASE, TBSIZE, and TBMXAD are left undefined for slow */
/* files. */
dasham_(handle, access, (ftnlen)10);
rdonly = s_cmp(access, "READ", (ftnlen)10, (ftnlen)4) == 0;
fast = FALSE_;
tbfast[(i__1 = fidx - 1) < 20 && 0 <= i__1 ? i__1 : s_rnge(
"tbfast", i__1, "dasa2l_", (ftnlen)794)] = fast;
/* We'll set the flag KNOWN at the end of the outer IF */
/* block. */
} else {
/* We set RDONLY to .FALSE. for any known file that is */
/* not fast. It's actually possible for a read-only file */
/* to be unsegregated, but this is expected to be a rare */
/* case, one that's not worth complicating this routine */
/* further for. */
rdonly = FALSE_;
}
/* RDONLY is set. */
/* FIDX is now set whether or not the current file is known. */
/* Get the number of reserved records, comment records, and */
/* the current last address of the data type TYPE from the */
/* file summary. */
dashfs_(handle, &nresvr, &nresvc, &ncomr, &ncomc, &free, &tbmxad[(
i__1 = fidx * 3 - 3) < 60 && 0 <= i__1 ? i__1 : s_rnge(
"tbmxad", i__1, "dasa2l_", (ftnlen)821)], lstrec, lstwrd);
mxaddr = tbmxad[(i__1 = *type__ + fidx * 3 - 4) < 60 && 0 <= i__1
? i__1 : s_rnge("tbmxad", i__1, "dasa2l_", (ftnlen)831)];
/* Make sure that ADDRSS points to an existing location. */
if (*addrss < 1 || *addrss > mxaddr) {
chkin_("DASA2L", (ftnlen)6);
dashlu_(handle, &unit);
setmsg_("ADDRSS was #; valid range for type # is # to #. F"
"ile was #", (ftnlen)60);
errint_("#", addrss, (ftnlen)1);
errint_("#", type__, (ftnlen)1);
errint_("#", &c__1, (ftnlen)1);
errint_("#", &mxaddr, (ftnlen)1);
errfnm_("#", &unit, (ftnlen)1);
sigerr_("SPICE(DASNOSUCHADDRESS)", (ftnlen)23);
chkout_("DASA2L", (ftnlen)6);
return 0;
}
/* Find out which directory describes the cluster containing */
/* this word. To do this, we must traverse the directory */
/* list. The first directory record comes right after the */
/* last comment record. (Don't forget the file record when */
/* counting the predecessors of the directory record.) */
/* Note that we don't need to worry about not finding a */
/* directory record that contains the address we're looking */
/* for, since we've already checked that the address is in */
/* range. */
/* Keep track of the number of directory records we see. We'll */
/* use this later to determine whether we've got a segregated */
/* file. */
nrec = nresvr + ncomr + 2;
ndirs = 1;
i__3 = rngloc[(i__2 = *type__ - 1) < 3 && 0 <= i__2 ? i__2 :
s_rnge("rngloc", i__2, "dasa2l_", (ftnlen)872)] + 1;
dasrri_(handle, &nrec, &rngloc[(i__1 = *type__ - 1) < 3 && 0 <=
i__1 ? i__1 : s_rnge("rngloc", i__1, "dasa2l_", (ftnlen)
872)], &i__3, range);
while(range[1] < *addrss) {
/* The record number of the next directory is the forward */
/* pointer in the current directory record. Update NREC */
/* with this pointer. Get the address range for the */
/* specified type covered by this next directory record. */
dasrri_(handle, &nrec, &c__2, &c__2, &nxtrec);
nrec = nxtrec;
++ndirs;
i__3 = rngloc[(i__2 = *type__ - 1) < 3 && 0 <= i__2 ? i__2 :
s_rnge("rngloc", i__2, "dasa2l_", (ftnlen)891)] + 1;
dasrri_(handle, &nrec, &rngloc[(i__1 = *type__ - 1) < 3 && 0
<= i__1 ? i__1 : s_rnge("rngloc", i__1, "dasa2l_", (
ftnlen)891)], &i__3, range);
}
/* NREC is now the record number of the directory that contains */
/* the type descriptor for the address we're looking for. */
/* Our next task is to find the descriptor for the cluster */
/* containing the input address. To do this, we must examine */
/* the directory record in `left-to-right' order. As we do so, */
/* we'll keep track of the highest address of type TYPE */
/* occurring in the clusters whose descriptors we've seen. */
/* The variable HIADDR will contain this address. */
dasrri_(handle, &nrec, &c__1, &c__256, dirrec);
/* In the process of finding the physical location */
/* corresponding to ADDRSS, we'll find the record number of the */
/* base of the cluster containing ADDRSS. We'll start out by */
/* initializing this value with the number of the first data */
/* record of the next cluster. */
*clbase = nrec + 1;
/* We'll initialize HIADDR with the value preceding the lowest */
/* address of type TYPE described by the current directory. */
hiaddr = dirrec[(i__2 = rngloc[(i__1 = *type__ - 1) < 3 && 0 <=
i__1 ? i__1 : s_rnge("rngloc", i__1, "dasa2l_", (ftnlen)
925)] - 1) < 256 && 0 <= i__2 ? i__2 : s_rnge("dirrec",
i__2, "dasa2l_", (ftnlen)925)] - 1;
/* Initialize the number of records described by the last seen */
/* type descriptor. This number, when added to CLBASE, should */
/* yield the number of the first record of the current cluster; */
/* that's why it's initialized to 0. */
*clsize = 0;
/* Now find the descriptor for the cluster containing ADDRSS. */
/* Read descriptors until we get to the one that describes the */
/* record containing ADDRSS. Keep track of descriptor data */
/* types as we go. Also count the descriptors. */
/* At this point, HIADDR is less than ADDRSS, so the loop will */
/* always be executed at least once. */
prvtyp = prev[(i__1 = dirrec[8] - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("prev", i__1, "dasa2l_", (ftnlen)944)];
dscloc = 10;
while(hiaddr < *addrss) {
/* Update CLBASE so that it is the record number of the */
/* first record of the current cluster. */
*clbase += *clsize;
/* Find the type of the current descriptor. */
if (dirrec[(i__1 = dscloc - 1) < 256 && 0 <= i__1 ? i__1 :
s_rnge("dirrec", i__1, "dasa2l_", (ftnlen)957)] > 0) {
curtyp = next[(i__1 = prvtyp - 1) < 3 && 0 <= i__1 ? i__1
: s_rnge("next", i__1, "dasa2l_", (ftnlen)958)];
} else {
curtyp = prev[(i__1 = prvtyp - 1) < 3 && 0 <= i__1 ? i__1
: s_rnge("prev", i__1, "dasa2l_", (ftnlen)960)];
}
/* Forgetting to update PRVTYP is a Very Bad Thing (VBT). */
prvtyp = curtyp;
/* If the current descriptor is of the type we're interested */
/* in, update the highest address count. */
if (curtyp == *type__) {
hiaddr += nw[(i__1 = *type__ - 1) < 3 && 0 <= i__1 ? i__1
: s_rnge("nw", i__1, "dasa2l_", (ftnlen)973)] * (
i__3 = dirrec[(i__2 = dscloc - 1) < 256 && 0 <=
i__2 ? i__2 : s_rnge("dirrec", i__2, "dasa2l_", (
ftnlen)973)], abs(i__3));
}
/* Compute the number of records described by the current */
/* descriptor. Update the descriptor location. */
*clsize = (i__2 = dirrec[(i__1 = dscloc - 1) < 256 && 0 <=
i__1 ? i__1 : s_rnge("dirrec", i__1, "dasa2l_", (
ftnlen)980)], abs(i__2));
++dscloc;
}
/* If we have an unknown read-only file, see whether the file */
/* is segregated. If it is, we'll be able to compute */
/* addresses much faster for subsequent reads to this file. */
if (rdonly && ! known) {
if (ndirs == 1) {
/* If this file is segregated, there are at most three */
/* cluster descriptors, and each one points to a cluster */
/* containing all records of the corresponding data type. */
/* For each data type having a non-zero maximum address, */
/* the size of the corresponding cluster must be large */
/* enough to hold all addresses of that type. */
ntypes = 0;
for (i__ = 1; i__ <= 3; ++i__) {
if (tbmxad[(i__1 = i__ + fidx * 3 - 4) < 60 && 0 <=
i__1 ? i__1 : s_rnge("tbmxad", i__1, "dasa2l_"
, (ftnlen)1005)] > 0) {
++ntypes;
}
}
/* Now look at the first NTYPES cluster descriptors, */
/* collecting cluster bases and sizes as we go. */
mxclrc = nrec + 1;
prvtyp = prev[(i__1 = dirrec[8] - 1) < 3 && 0 <= i__1 ?
i__1 : s_rnge("prev", i__1, "dasa2l_", (ftnlen)
1016)];
dscloc = 10;
fast = TRUE_;
while(dscloc <= ntypes + 9 && fast) {
/* Find the type of the current descriptor. */
if (dirrec[(i__1 = dscloc - 1) < 256 && 0 <= i__1 ?
i__1 : s_rnge("dirrec", i__1, "dasa2l_", (
ftnlen)1025)] > 0) {
curtyp = next[(i__1 = prvtyp - 1) < 3 && 0 <=
i__1 ? i__1 : s_rnge("next", i__1, "dasa"
"2l_", (ftnlen)1026)];
} else {
curtyp = prev[(i__1 = prvtyp - 1) < 3 && 0 <=
i__1 ? i__1 : s_rnge("prev", i__1, "dasa"
"2l_", (ftnlen)1028)];
}
prvtyp = curtyp;
tbbase[(i__1 = curtyp + fidx * 3 - 4) < 60 && 0 <=
i__1 ? i__1 : s_rnge("tbbase", i__1, "dasa2l_"
, (ftnlen)1032)] = mxclrc;
tbsize[(i__1 = curtyp + fidx * 3 - 4) < 60 && 0 <=
i__1 ? i__1 : s_rnge("tbsize", i__1, "dasa2l_"
, (ftnlen)1033)] = (i__3 = dirrec[(i__2 =
dscloc - 1) < 256 && 0 <= i__2 ? i__2 :
s_rnge("dirrec", i__2, "dasa2l_", (ftnlen)
1033)], abs(i__3));
mxclrc += tbsize[(i__1 = curtyp + fidx * 3 - 4) < 60
&& 0 <= i__1 ? i__1 : s_rnge("tbsize", i__1,
"dasa2l_", (ftnlen)1034)];
fast = tbmxad[(i__1 = curtyp + fidx * 3 - 4) < 60 &&
0 <= i__1 ? i__1 : s_rnge("tbmxad", i__1,
"dasa2l_", (ftnlen)1037)] <= tbsize[(i__2 =
curtyp + fidx * 3 - 4) < 60 && 0 <= i__2 ?
i__2 : s_rnge("tbsize", i__2, "dasa2l_", (
ftnlen)1037)] * nw[(i__3 = curtyp - 1) < 3 &&
0 <= i__3 ? i__3 : s_rnge("nw", i__3, "dasa2"
"l_", (ftnlen)1037)];
++dscloc;
}
/* FAST is set. */
} else {
/* The file has more than one directory record. */
fast = FALSE_;
}
/* If the file was unknown, readonly, and had one directory */
/* record, we determined whether it was a fast file. */
} else {
/* The file was already known and wasn't fast, or is not */
/* readonly. */
fast = FALSE_;
}
/* FAST is set. */
}
/* This is the end of the `.NOT. ( KNOWN .AND. FAST )' case. */
/* At this point, we've set or looked up CLBASE, CLSIZE, MXADDR, */
/* and HIADDR. */
/* If the file was unknown, we set TBHAN, TBRDON, and TBFAST. */
/* If the file was unknown and turned out to be fast, we set */
/* TBBASE, TBSIZE, TBHIGH, and TBMXAD as well. */
/* At this point, it's safe to indicate that the file is known. */
known = TRUE_;
}
/* At this point, */
/* -- CLBASE is properly set: it is the record number of the */
/* first record of the cluster containing ADDRSS. */
/* -- CLSIZE is properly set: it is the size of the cluster */
/* containing ADDRSS. */
/* -- HIADDR is the last logical address in the cluster */
/* containing ADDRSS. */
/* Now we must find the physical record and word corresponding */
/* to ADDRSS. The structure of the cluster containing ADDRSS and */
/* HIADDR is shown below: */
/* +--------------------------------------+ */
/* | | Record # CLBASE */
/* +--------------------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------------------+ */
/* | |ADDRSS| | Record # RECNO */
/* +--------------------------------------+ */
/* . */
/* . */
/* . */
/* +--------------------------------------+ Record # */
/* | |HIADDR| */
/* +--------------------------------------+ CLBASE + CLSIZE - 1 */
*recno = *clbase + *clsize - 1 - (hiaddr - *addrss) / nw[(i__1 = *type__
- 1) < 3 && 0 <= i__1 ? i__1 : s_rnge("nw", i__1, "dasa2l_", (
ftnlen)1122)];
*wordno = *addrss - (*addrss - 1) / nw[(i__1 = *type__ - 1) < 3 && 0 <=
i__1 ? i__1 : s_rnge("nw", i__1, "dasa2l_", (ftnlen)1125)] * nw[(
i__2 = *type__ - 1) < 3 && 0 <= i__2 ? i__2 : s_rnge("nw", i__2,
"dasa2l_", (ftnlen)1125)];
return 0;
} /* dasa2l_ */