SUBROUTINE COPYFIRST (IFILE, INDEX, AOUT, ISOK)
C
C  ** ROUTINE TO RETURN THE FIRST IN SEQUENCE FROM A FILE
C
C  INPUTS:
C    IFILE = FILE ID NUMBER
C    INDEX = WHICH SEQUENCE
C  OUTPUTS:
C    AOUT  = RETURNED DECOMPRESSED ATRIBUTES
C    ISOK  = 1 IF A FAILURE; 2 IF A SUCCESS
C
$INCLUDE:"COMCORE.FOR"
$INCLUDE:"COMFILE.FOR"
C
      DIMENSION AOUT(1)
C
      IPTRH = IHLIST(IFILE, INDEX)
      IPTRF = ICORE(IPTRH+1)
      IF (RCORE(IPTRF+2).EQ.HUGE(R)) THEN
        ISOK   = 1
      ELSE
        ISOK   = 2
        IPTRAN = ICORE(IPTRF+3)
        CALL DECOMP (IFILE, RCORE(IPTRAN), AOUT)
        ICLIST(IFILE)  = IPTRF
      ENDIF
C
      RETURN
      END
C
      SUBROUTINE COPYNEXT (IFILE, AOUT, ISOK)
C
C  ** ROUTINE TO RETURN THE NEXT IN SEQUENCE FROM A FILE
C
C  INPUTS:
C    IFILE = FILE ID NUMBER
C  OUTPUTS:
C    AOUT  = RETURNED DECOMPRESSED ATRIBUTES
C    ISOK  = 1 IF A FAILURE; 2 IF A SUCCESS
C
$INCLUDE:"COMCORE.FOR"
$INCLUDE:"COMFILE.FOR"
C
      DIMENSION AOUT(1)
C
      IPTRH = ICLIST(IFILE)
      IPTRF = ICORE(IPTRH+1)
      IF (RCORE(IPTRF+2).EQ.HUGE(R)) THEN
        ISOK   = 1
      ELSE
        ISOK   = 2
        IPTRAN = ICORE(IPTRF+3)
        CALL DECOMP (IFILE, RCORE(IPTRAN), AOUT)
        ICLIST(IFILE)  = IPTRF
      ENDIF
C
      RETURN
      END
C
      SUBROUTINE COPYLAST (IFILE, INDEX, AOUT, ISOK)
C
C  ** ROUTINE TO RETURN THE LIST IN SEQUENCE FROM A FILE
C
C  INPUTS:
C    IFILE = FILE ID NUMBER
C    INDEX = WHICH SEQUENCE
C  OUTPUTS:
C    AOUT  = RETURNED DECOMPRESSED ATRIBUTES
C    ISOK  = 1 IF A FAILURE; 2 IF A SUCCESS
C
$INCLUDE:"COMCORE.FOR"
$INCLUDE:"COMFILE.FOR"
C
      DIMENSION AOUT(1)
C
      IPTRL = ITLIST(IFILE, INDEX)
      IPTRP = ICORE(IPTRL)
      IF (RCORE(IPTRP+2).EQ.-(HUGE(R)/10.0)) THEN
        ISOK   = 1
      ELSE
        ISOK   = 2
        IPTRAN = ICORE(IPTRP+3)
        CALL DECOMP (IFILE, RCORE(IPTRAN), AOUT)
        ICLIST(IFILE)  = IPTRP
      ENDIF
C
      RETURN
      END
C
      SUBROUTINE COPYPREV (IFILE, AOUT, ISOK)
C
C  ** ROUTINE TO RETURN THE PREVIOUS IN SEQUENCE FROM A FILE
C
C  INPUTS:
C    IFILE = FILE ID NUMBER
C  OUTPUTS:
C    AOUT  = RETURNED DECOMPRESSED ATRIBUTES
C    ISOK  = 1 IF A FAILURE; 2 IF A SUCCESS
C
$INCLUDE:"COMCORE.FOR"
$INCLUDE:"COMFILE.FOR"
C
      DIMENSION AOUT(1)
C
      IPTRL = ICLIST(IFILE)
      IPTRP = ICORE(IPTRL)
      IF (RCORE(IPTRP+2).EQ.-(HUGE(R)/10.0)) THEN
        ISOK   = 1
      ELSE
        ISOK   = 2
        IPTRAN = ICORE(IPTRP+3)
        CALL DECOMP (IFILE, RCORE(IPTRAN), AOUT)
        ICLIST(IFILE)  = IPTRP
      ENDIF
C
      RETURN
      END
C
      SUBROUTINE COPYHEAD (IFILE, INDEX, AOUT, ISOK)
C 
C  ** ROUTINE TO COPY THE FIRST IN SEQUENCE IN AN ORDERING
C
C  INPUTS:
C    IFILE = FILE ID NUMBER
C    INDEX = WHICH SEQUENCE
C  OUTPUTS:
C    AOUT  = RETURNED DECOMPRESSED ATRIBUTES
C    ISOK  = 1 IF A FAILURE; 2 IF A SUCCESS 
C
$INCLUDE:"COMCORE.FOR"
$INCLUDE:"COMFILE.FOR"
C
      JINDEX = IPINDEX(IFILE) + INDEX - 1
      IF (INDICES(JINDEX,1).GT.0) THEN
        CALL COPYFIRST (IFILE, INDEX, AOUT, ISOK)
      ELSE
        CALL COPYLAST  (IFILE, INDEX, AOUT, ISOK)
      END IF
C
      RETURN
      END
C
      SUBROUTINE COPYSEQ (IFILE, INDEX, AOUT, ISOK)
C 
C  ** ROUTINE TO COPY THE NEXT IN SEQUENCE IN AN ORDERING
C
C  INPUTS:
C    IFILE = FILE ID NUMBER
C    INDEX = WHICH SEQUENCE
C  OUTPUTS:
C    AOUT  = RETURNED DECOMPRESSED ATRIBUTES
C    ISOK  = 1 IF A FAILURE; 2 IF A SUCCESS 
C
$INCLUDE:"COMCORE.FOR"
$INCLUDE:"COMFILE.FOR"
C
      JINDEX = IPINDEX(IFILE) + INDEX - 1
      IF (INDICES(JINDEX,1).GT.0) THEN
        CALL COPYNEXT (IFILE, AOUT, ISOK)
      ELSE
        CALL COPYPREV (IFILE, AOUT, ISOK)
      END IF
C
      RETURN
      END
C
      SUBROUTINE COPYKEY (IFILE, INDEX, AOUT, ISOK, RKEY)
C
C  ** ROUTINE TO RETURN THE ONE WITH A GIVEN VALUE FROM A FILE
C
C  INPUTS:
C    IFILE = FILE ID NUMBER
C    INDEX = WHICH SEQUENCE
C    RKEY  = VALUE TO FIND
C  OUTPUTS:
C    AOUT  = RETURNED DECOMPRESSED ATRIBUTES
C    ISOK  = 1 IF A FAILURE; 2 IF A SUCCESS
C
$INCLUDE:"COMCORE.FOR"
$INCLUDE:"COMFILE.FOR"
C
      DIMENSION AOUT(1)
C
C  ** FIND LOCATION IN INDEX AND IN THIS ORDERING
C
      CALL FINDFILE (IHINDEX(IFILE, INDEX), RKEY, IPSINDEX, IPLIST)
C
      IPTRAN = ICORE(IPLIST+3)
      CALL DECOMP (IFILE, RCORE(IPTRAN), AOUT)
      ICLIST(IFILE)  = IPLIST
C
      JINDEX = IPINDEX(IFILE) + INDEX - 1
      ISUB  = ABS(INDICES (JINDEX,1))
      VALUE = RCORE(IPTRAN-1+ISUB)
C
      IF (VALUE.EQ.RKEY) ISOK = 2
      IF (VALUE.NE.RKEY) ISOK = 1      
C
      RETURN
      END
C
      SUBROUTINE FINDFILE (ISINDEX, VALUE, IPSINDEX, IPLIST)
C
C  ROUTINE TO LOCATE A TRANSACTION IN A INDEX
C
C  INPUTS:
C    ISINDEX = START OF INDEX TO THIS ORDERING
C    VALUE   = KEY VALUE FOR TRANSACTION
C  OUTPUTS:
C    IPSINDEX = POINTER TO THE SMALLEST VALUE LARGER THAN KEY IN THE 2ND INDEX
C    IPLIST  = POINTER TO THE SMALLEST VALUE LARGER THAN KEY IN THE 1ST INDEX
C
$INCLUDE:"COMCORE.FOR"
$INCLUDE:"COMFILE.FOR"
C
C  BINARY SEARCH INDEX
C
      CALL FINDINDEX(ISINDEX, VALUE, IPSINDEX)
C
C
C  ** SEARCH FIRST LEVEL INDEX FOR ENTRY
C  ** UPDATE 2ND LEVEL INDEX AS NECESSARY
C
      ITRIG  = 0
      IPLIST = 0
      IPTR   = ICORE(IPSINDEX+MXENTRY)
C
      DO WHILE (IPLIST.EQ.0)
        IPBACK = ICORE(IPTR)
        IF (RCORE(IPBACK+2).LT.VALUE .AND.
     1      RCORE(IPTR  +2).GE.VALUE) THEN
          IPLIST = IPTR
        ELSE
C
          ITRIG = ITRIG + 1
          IF (ITRIG.GT.NTRIG .AND. IPSINDEX.NE.ISINDEX) THEN
C
C ** UPDATE INDEX
C
            ITRIG                   = 0
            IPSINDEX                = IPSINDEX - 1
            RCORE(IPSINDEX)         = RCORE(IPTR+2)
            ICORE(IPSINDEX+MXENTRY) = IPTR
          ENDIF
C
C ** UPDATE POINTER
C
          IPTR = IPBACK
        ENDIF
      ENDDO
C
      RETURN
      END                        
C
      SUBROUTINE FINDINDEX (ISINDEX, VALUE, IPSINDEX)
C
C  ROUTINE TO LOCATE A TRANSACTION IN A THE SECOND LEVEL INDEX
C
C  INPUTS:
C    ISINDEX = START OF INDEX TO THIS ORDERING
C    VALUE   = KEY VALUE FOR TRANSACTION
C  OUTPUTS:
C    IPSINDEX = POINTER TO THE SMALLEST VALUE LARGER THAN KEY IN THE 2ND INDEX
C
$INCLUDE:"COMCORE.FOR"
$INCLUDE:"COMFILE.FOR"
C
C  BINARY SEARCH INDEX
C
      ISTART  = 0
      IEND    = MXENTRY-1
      IPSINDEX = 0
C
      DO WHILE (IPSINDEX.EQ.0)
        IOFF = (ISTART+IEND)/2
        IF (IOFF.EQ.MXENTRY) IOFF = MXENTRY - 1
C
        IF (RCORE(ISINDEX+IOFF).LT.VALUE .AND.
     1      RCORE(ISINDEX+IOFF+1).GE.VALUE) THEN
          IPSINDEX = ISINDEX+IOFF+1
        ELSE
C
          IF (RCORE(ISINDEX+IOFF).LT.VALUE) THEN
            ISTART = IOFF
          ELSE
            IEND   = IOFF
          ENDIF
C 
        ENDIF
      END DO
C
      RETURN
      END
C
      SUBROUTINE GETFILE (IFILE, INDEX, AOUT, ISOK)
C
C  ** ROUTINE TO RETURN THE CURRENT IN SEQUENCE FROM A FILE
C
C  INPUTS:
C    IFILE = FILE ID NUMBER
C    INDEX = WHICH SEQUENCE
C  OUTPUTS:
C    AOUT  = RETURNED DECOMPRESSED ATRIBUTES
C    ISOK  = 1 IF A FAILURE; 2 IF A SUCCESS
C
$INCLUDE:"COMCORE.FOR"
$INCLUDE:"COMFILE.FOR"
C
      DIMENSION AOUT(1)
C
C  ** UPDATE NUMBER IN FILE
C
      IN_FILE(IFILE) = IN_FILE(IFILE) - 1
C
      IPTRC = ICLIST(IFILE)
      IF (RCORE(IPTRC+2).EQ.HUGE(R)) THEN
        ISOK   = 1
      ELSE
        ISOK   = 2
        IPTRAN = ICORE(IPTRC+3)
        CALL DECOMP (IFILE, RCORE(IPTRAN), AOUT)
C
        JINDEX = IPINDEX(IFILE) + INDEX - 1
        ISUB  = ABS(INDICES (JINDEX,1))
        VALUE = RCORE(IPTRAN-1+ISUB)
C
C  ** FIND LOCATION IN INDEX AND IN THIS ORDERING
C
        CALL FINDINDEX (IHINDEX(IFILE, INDEX), VALUE, IPSINDEX)
C
C  ** CHANGE SECOND LEVEL INDEX ENTRY IF NECESSARY
C
        IPTRP = ICORE(IPTRC)
        IOFF  = 0
        DO WHILE (RCORE(IPSINDEX+IOFF).EQ.VALUE)
          IF (ICORE(IPSINDEX+MXENTRY+IOFF).EQ.IPTRC) THEN
            RCORE(IPSINDEX+IOFF)         = RCORE(IPTRP+2)
            ICORE(IPSINDEX+MXENTRY+IOFF) = IPTRP
          ENDIF
          IOFF = IOFF + 1
        END DO
C
C  ** REMOVE FIRST LEVEL INDEX
C
        IPTRN          = ICORE(IPTRC+1)
        ICORE(IPTRP+1) = IPTRN
        ICORE(IPTRN)   = IPTRP
        CALL FRCORE(4, IPTRC)
        ICLIST(IFILE)  = IPTRP
C
        DO 10 I = 1,NINDEX(IFILE)
          IF (I.NE.INDEX) THEN
            JINDEX = IPINDEX(IFILE) + I - 1
            ISUB  = ABS(INDICES (JINDEX,1))
            VALUE = RCORE(IPTRAN-1+ISUB)
C
C  ** FIND LOCATION IN INDEX AND IN THIS ORDERING
C
            CALL FINDFILE (IHINDEX(IFILE, I), VALUE, IPSINDEX, IPLIST)
            DO WHILE (ICORE(IPLIST+3).NE.IPTRAN)
              IF (VALUE.NE.RCORE(IPLIST+2)) THEN
                CALL WS_ERROR(105,'F')
              END IF
              IPLIST = ICORE(IPLIST+1)
            END DO
C
C  ** CHANGE SECOND LEVEL INDEX ENTRY IF NECESSARY
C
            IPTRP = ICORE(IPLIST)
            IOFF  = 0
            DO WHILE (RCORE(IPSINDEX+IOFF).EQ.VALUE)
              IF (ICORE(IPSINDEX+MXENTRY+IOFF).EQ.IPLIST) THEN
                RCORE(IPSINDEX+IOFF)         = RCORE(IPTRP+2)
                ICORE(IPSINDEX+MXENTRY+IOFF) = IPTRP 
              ENDIF
              IOFF = IOFF + 1
            END DO
C
C  ** REMOVE FIRST LEVEL INDEX
C
            IPTRN          = ICORE(IPLIST+1)
            ICORE(IPTRP+1) = IPTRN
            ICORE(IPTRN)   = IPTRP
            CALL FRCORE(4, IPLIST)
          ENDIF
   10   CONTINUE
C
C  ** REMOVE TRANSACTION FROM FILE
C
        CALL FRCORE (NATTRIB(IFILE), IPTRAN)
      ENDIF
C
      RETURN
      END
C
      SUBROUTINE PUTFILE(IFILE, AIN, ISOK, ISTIEP, ISTIES)
C
C  ** ROUTINE TO STORE A TRANSACTIONS IN A FILE
C
$INCLUDE:"COMCORE.FOR"
$INCLUDE:"COMFILE.FOR"
C
      DIMENSION AIN(1)
C
C  **  SET TIE SWITCHES
C
      ISTIEP = 0
      ISTIES = 1
C
C  ** UPDATE NUMBER IN FILE
C
      IN_FILE(IFILE) = IN_FILE(IFILE) + 1
C
C  ** ALLOCATE CORE FOR TRANSACTION AND COMPRESS THE ATTRIBUTES
C
      CALL ALCORE(NATTRIB(IFILE), IPTRAN, ISOK)
      IF (ISOK.EQ.2) THEN
        CALL COMPRESS (IFILE, AIN, RCORE(IPTRAN))
C
C  ** PUT IN EACH INDEX
C
        DO 10 INDEX = 1, NINDEX(IFILE) 
          JINDEX = IPINDEX(IFILE) + INDEX - 1
          ISUB  = ABS(INDICES (JINDEX,1))
          VALUE = RCORE(IPTRAN-1+ISUB)
C
C  ** FIND LOCATION IN INDEX AND IN THIS ORDERING
C
          CALL FINDFILE (IHINDEX(IFILE, INDEX), VALUE, IPSINDEX, IPLIST)
C
C  ** PUT IN FIRST LEVEL INDEX; INSERT BEFORE IPLIST
C
          CALL ALCORE(4, IPTLIST, ISOK1)
          IF (ISOK1.EQ. 1) THEN
            ISOK = 1
            RETURN
          ENDIF
C
C  ** IF THERE IS A TIE UPDATE IPLIST ACCORDING TO SECONDARY KEY
C
          JINDEX = IPINDEX(IFILE) + INDEX - 1
          IF (INDICES(JINDEX,2).NE.0) THEN
            RMULT  = SIGN (1, INDICES(JINDEX,2))
            ISUBS  = ABS  (INDICES(JINDEX,2))
            VALUES = RCORE(IPTRAN-1+ISUBS)
            ICONT  = 2
C
C  ** ALL TIED PRIMARY KEYS UNTIL PLACE FOUND
C
            DO WHILE (RCORE(IPLIST+2).EQ.VALUE .AND. ICONT.EQ.2)
              ISTIEP = ISTIEP + 1
              IPCOMP = ICORE(IPLIST+3)
              VALUEC = RCORE(IPCOMP-1+ISUBS)
C
              IF (VALUES*RMULT.GT.VALUEC*RMULT) THEN
                IPLIST = ICORE(IPLIST+1)
                ICONT  = 2
C
              ELSE
                ICONT  = 1
C
                IF (VALUES*RMULT.EQ.VALUEC*RMULT) THEN
                  ISTIES = 2
                ENDIF
              ENDIF
            END DO
C
C  ** COUNT REST OF PRIMARY KEY TIED
C
            IXLIST = ICORE(IPLIST+1)
            DO WHILE (RCORE(IXLIST+2).EQ.VALUE)
              ISTIEP = ISTIEP + 1
              IXLIST = ICORE(IXLIST+1)
            END DO
          ENDIF
C
C  ** SET UP FIRST LEVEL ENTRY
C
          ICORE(IPTLIST)    = ICORE(IPLIST)
          ICORE(IPTLIST+1)  = IPLIST
          RCORE(IPTLIST+2)  = VALUE
          ICORE(IPTLIST+3)  = IPTRAN
C
C  ** LINK INTO LIST
C
          IPTRP             = ICORE(IPLIST)
          ICORE(IPTRP+1)    = IPTLIST
C
          ICORE(IPLIST)     = IPTLIST
C
  10    CONTINUE               
C
      ENDIF  
C
      RETURN
      END
C
      SUBROUTINE STARTFILE
C
C  ROUTINE TO SET UP THE FILING SYSTEM
C
$INCLUDE:"COMFILE.FOR"
$INCLUDE:"COMCORE.FOR"
C
      NINDEX     =    0
      NTRIG      =   25
      MXENTRY    = 4096
      MXFILE     =  100
      DO 10 IFILE = 1, MXFILE
        IN_FILE(IFILE) =    0
   10 CONTINUE
C
      RETURN
      END
C
      SUBROUTINE DFKEY (IPKEY, IPTYPE, ISKEY, ISTYPE)
C
C     ROUTINE TO SET UP A KEY IN THE FILING SYSTEM
C
$INCLUDE:"COMFILE.FOR"
$INCLUDE:"COMCORE.FOR"
C
      CHARACTER * 1 IPTYPE, ISTYPE
C
      NTOTINDEX = NTOTINDEX + 1
      IFILE     = ICFILE
      ICINDEX   = ICINDEX + 1
C
C **  KEY DEFINITION DIRECTION AND WHICH ATTRIBUTE
C
      IF (IPTYPE.EQ.'U') THEN
        INDICES (NTOTINDEX,1) =  IPKEY
      ELSE
        INDICES (NTOTINDEX,1) = -IPKEY
      END IF
C
      IF (ISTYPE.EQ.'U') THEN
        INDICES (NTOTINDEX,2) =  ISKEY*SIGN(1, INDICES(NTOTINDEX,1))
      ELSE
        INDICES (NTOTINDEX,2) = -ISKEY*SIGN(1, INDICES(NTOTINDEX,1))
      END IF
C
C  FIRST AND LAST ENTRIES IN FILE
C
      CALL ALCORE(NATTRIB(IFILE), IPTR1,ISOK)
      CALL ALCORE(NATTRIB(IFILE), IPTRL,ISOK)
C
C  SPACE FOR SECOND LEVEL INDEX INDEX; SET ALL VALUES TO MOST NEGATIVE
C
      CALL ALCORE(MXENTRY*2, IHINDEX(IFILE, ICINDEX), ISOK)
      DO 20 J = 0, MXENTRY-2
         RCORE(IHINDEX(IFILE,ICINDEX)+J)   = -(HUGE(R)/10.0)
  20  CONTINUE
      RCORE(IHINDEX(IFILE,ICINDEX)+MXENTRY-1) = HUGE(R)
C
C  FIRST AND LAST ENTRIES IN FIRST LEVEL INDEX 
C
      CALL ALCORE(4, IPTR2, ISOK)
      CALL ALCORE(4, IPTR3, ISOK)
C
      ICORE(IPTR2)   = 0
      ICORE(IPTR2+1) = IPTR3
      RCORE(IPTR2+2) = -(HUGE(R)/10.0)
      ICORE(IPTR2+3) = IPTR1
C
      ICORE(IPTR3)   = IPTR2
      ICORE(IPTR3+1) = 0
      RCORE(IPTR3+2) = HUGE(R)
      ICORE(IPTR3+3) = IPTRL
C
      IHLIST(IFILE, ICINDEX) = IPTR2
      ITLIST(IFILE, ICINDEX) = IPTR3
C
C  POINTERS IN SECOND LEVEL INDEX
C
      DO 30 J= MXENTRY, MXENTRY+MXENTRY-2
        ICORE(IHINDEX(IFILE,ICINDEX)+J)                = IPTR2
  30  CONTINUE
      ICORE(IHINDEX(IFILE,ICINDEX)+MXENTRY+MXENTRY-1)  = IPTR3 
C
C  CURRENT IN THE FIRST LEVEL INDEX
C
        ICLIST(IFILE)  = IPTR3
C
  10  CONTINUE
C
      RETURN
      END
C
      FUNCTION NUM_FILE (IFILE)
C
C  ** ROUTINE TO RETURN THE NUMBER IN A FILE
C
$INCLUDE:"COMFILE.FOR"
C
      NUM_FILE = IN_FILE(IFILE)
C
      RETURN
      END
C
      SUBROUTINE DFFILE (IFILE, NKEYS, NATRIB)
C
C **  ROUTINE TO DEFINE A FILE
C
$INCLUDE:"COMFILE.FOR"
$INCLUDE:"COMCORE.FOR"
C
C **  INPUTS:
C       IFILE  = FILE ID NUMBER
C       NKEYS  = NUMBER OF INDICIES TO CREATE IN THIS FILE
C       NATRIB = NUMBER OF ATTRIBUTES OF A FILE ENTRY
C
      NINDEX(IFILE)  = NKEYS
      NATTRIB(IFILE) = NATRIB
      IPINDEX(IFILE) = NTOTINDEX + 1
      ICFILE         = IFILE
      ICINDEX        = 0
C
      RETURN
      END


      SUBROUTINE WR_STRUCT
$INCLUDE:"COMFILE.FOR"
$INCLUDE:"COMCORE.FOR"
C

C
      RETURN
      END