예제 #1
0
파일: dasadc.c 프로젝트: haisamido/GMAT
/* $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_ */
예제 #2
0
파일: dassdr.c 프로젝트: Dbelsa/coft
/* $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_ */
예제 #3
0
/* $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_ */
예제 #4
0
파일: daswfr.c 프로젝트: Dbelsa/coft
/* $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_ */
예제 #5
0
/* $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_ */