C
C = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 
C
C
C   C O D C O M P . F O R
C   = = = = = = = = = = =
C
C
C    SEEDIS UTILITIES TO CONVERT CODATA FILE TO DDX/DDF/NDX/DAT FILES
C
C
C   CODCOMP  -  CONTROL OPERATIONS
C   DCSETMF  -  SET UP KEYS FOR MULTIPLE FILES
C   DCCSWAP  -  MOVE CHARACTERS
C   DCCONV   -  CODATA TO DDF OPERATION
C   DCPOINT  -  SET UP LINE POINTERS FOR DATA INPUT
C   DCGLOBE  -  READ/WRITE GLOBALS
C   DCNXTDE  -  READ/WRITE NEXT DE SET
C   DCKEYER  -  SAVE DE NAME FOR POSSIBLE KEY USE
C   DCUSE    -  SET KEY FLAG
C   DCTYPER  -  GET DATA TYPE
C   DCOUT    -  WRITE NEW DDF 
C   DCNDSIZ  -  GET NDE, RESET
C   DCEQUAL  -  MOVE UP TO EQUAL SIGN
C   DCNXTTY  -  NEXT CODATA TYPE
C   DCDATA   -  CONTROL READ/COMPRESS OF DATA PORTION
C   DCKFIND  -  SAVE MULTI-FILE NDX KEYS
C   DCNXOUT  -  CLOSE OLD FILE, OPEN NEW FILE (MULTI-FILES ONLY)
C   DCNAMER  -  MATCH OLD/NEW MULTI-FILE KEYS
C   DCFSWAP  -  COPY SCRATCH FILE TO NDX FILE
C   DCHOLD   -  HOLD NEXT VALUE IN CASE OF REPEAT
C   DCKEY    -  PUT KEY INTO INDEX LINE
C   DCNDX    -  PUT RECORD NUMBER AND SIZE INTO INDEX LINE
C   DCNXDDF  -  WRITE DDF PORTION OF NDX FILE
C   DCRSIZE  -  DETERMINE OPTIMUM DIRECT RECORD SIZE
C   DCARGS   -  CHECK USER ARGUMENTS, SET FILE NAMES
C   DCUNIT   -  RAT TO FORTRAN UNIT, REOPEN INPUT (PER JOE, 4/8/82)
C
C = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
C
C
      SUBROUTINE CODCOMP ( INRAT,   OPER,   ACC,   DIR1,   DIR2,   
     _                     NFNDE,    FNDE,   VAXLN, IERR            )
C
C
C ----- CONVERT CODATA FILE TO DDF AND DDX FILES
C
C ----- ALSO COMPRESS DATA PORTION AND CREATE DAT AND NDX FILES
C
C   --- MULTIPLE NDX/DAT FILES MAY BE CREATED IF NFNDE > 0
C
C
C  INPUT IS --  INRAT --> UNIT NUMBER FOR INPUT
C                OPER --> 'C' CODATA INPUT, 'D' DDF INPUT
C                 ACC --> ACCESS MODE FOR DAT FILE, 'D' OR 'S'
C                DIR1 --> OUTPUT DDF/DDX DIRECTORY:FILE NAME
C                DIR2 --> OUTPUT DAT/NDX DIRECTORY:FILE NAME
C               NFNDE --> NUMBER OF DE'S TO USE IN FORMING DAT/NDX FILE
C                FNDE --> DE NAMES TO USE IN FORMING DAT/NDX FILE
C               VAXLN --> MAX NO. OF CHARACTERS IN FILE NAME (=9)
C
C                 IERR RETURNED AS ZERO IF ALL IS WELL
C
C
C
C
      CHARACTER*132 BUFFER
      CHARACTER*80  DDF, DDX, DAT, NDX
      CHARACTER*1   OP, ACCES
C
      LOGICAL*1  OPER, ACC, FNDE(21,1), DIR1(1), DIR2(1)
C
      INTEGER  INRAT, OUT, TTYLEN
      INTEGER  DCARGD, NFNDE, VAXLN
      INTEGER  DCARGS, DCCONV, DCDATA
C
      COMMON  /  DCFILES  /  DDF, DDX, DAT, NDX
      COMMON  /  DCUNITS  /  IN, OUT
      COMMON  /  DCBUFF   /  BUFFER
      COMMON  /  DCERROR  /  KERR
      COMMON  /  DCTYPE   /  OP
      COMMON  /  DCACCES  /  ACCES
      COMMON  /  DCKEYNX  /  KNX, KEYST, KEYLEN(20), KEYPOS(20)
C
C
C--> CHECK USER ARGUMENTS
C
      CALL DCUNIT ( INRAT, IN )
      IF ( DCARGS ( INRAT, OPER, ACC, DIR1, DIR2 ) .NE. 0 ) GO TO 10
C
C ---- CHECK AND STORE MULTI-FILE KEYS
C
      CALL DCSETMF ( NFNDE, FNDE, DIR2, IERR )
      IF ( IERR .NE. 0 ) RETURN
C
C ---- OPEN DDF IF NEW
C
      IF ( OP .EQ. 'C' ) THEN   
        CALL NXTUNIT ( OUT )
        KERR = 156
        OPEN ( UNIT=OUT, TYPE='NEW', NAME=DDF, ERR=10 )
        REWIND OUT
        L = TTYLEN ( DDF )
        WRITE(OUT,4) DDF(1:L)
    4   FORMAT('VAX = 'A/'MODE = COMPRESSED')
      ENDIF
C
C ---- GET POSITIONS FOR DE
C
      KNX = 1
      KEYST = 0
      IF ( DCCONV ( KERR ) .NE. 0 ) GO TO 10
C
C --- INDEX DDF
C
      IF ( OP .EQ. 'C' ) THEN
        CLOSE ( UNIT=OUT, DISP='KEEP' )
c following statement changed 3/29/84 dwm
c previous version was call ddfndx (ddf,ddx,ierr)
c                      if (ierr.ne.0) return
        CALL DDFNDX ( DDF, DDX , 1 )
      ENDIF
C
C --- COMPRESS
C
      IF ( DCDATA ( KERR ) .NE. 0 ) GO TO 10
C
      IERR = 0
      RETURN
C
C --- ERROR
C
   10 CONTINUE
      CALL IOERR ( 'CODCOMP' )
      IERR = KERR
C
      END
      SUBROUTINE DCSETMF ( NF, F, DIR, IERR )
C
C --- CHECK AND STORE NDX KEYS AND FILE NAME
C
      LOGICAL*1  DIR(1) , F(21,1)
C
      CHARACTER*20  ANDX
      CHARACTER*80  DIRX
C
      COMMON  /  DCAREA   /  NNDX, NPOINT(10), LDIRX
      COMMON  /  DCAREAN  /  ANDX(10) , DIRX
C
C
C
      IERR = 0
      NNDX = 0
      IF ( NF .LE. 0 ) RETURN    !  NO MULTI-FILES
C
      DO 2 J=1,NF
C
        NNDX = NNDX + 1
        CALL DCCSWAP ( %REF(ANDX(NNDX)) , F(1,J), L )
        IF ( L .LE. 0 ) THEN
          IERR = 25
          RETURN
        ENDIF
C
    2 CONTINUE
C
C -- FILE NAME PREFIX
C
      CALL DCCSWAP ( %REF(DIRX), DIR, L )
      LDIRX = L
      IF ( L .LE. 0 ) IERR=26
      RETURN
C
      END
      SUBROUTINE DCCSWAP ( OUT, IN, LENGTH )
C
C -- MOVE CHARACTERS
C
      LOGICAL*1  IN(1), OUT(1)
C
C
      LENGTH = 0
      DO 1 J=1,81
        IF ( IN(J) .LT. "040 ) RETURN
        LENGTH = LENGTH + 1
        OUT(J) = IN(J)
    1 CONTINUE
C
      RETURN
      END
      INTEGER FUNCTION DCCONV ( KERR )
C
C --- READ INPUT CODATA FILE, CONVERT TO DDF FILE
C
C
      CHARACTER*20  DEKEY
      CHARACTER*1   KEYTYP, CTYPE
C
      INTEGER  OUTFILE, POS, STRT, LNTH, TYPE
      INTEGER  DCNXTDE, DCGLOBE
C
      COMMON  /  DCDENDX  /  POS, STRT(3000), LNTH(3000), TYPE(3000)
      COMMON  /  DCCARDL  /  KLEN, KLAS, KLIN, KNDE, KNAR
      COMMON  /  DCPOINT  /  LPO(400)
      COMMON  /  DCUNITS  /  INFILE, OUTFILE
      COMMON  /  DCKEYNX  /  KNX, KEYST, KEYLEN(20), KEYPOS(20)
      COMMON  /  DCKEYDE  /  DEKEY(20) , KEYTYP(20)
      COMMON  /  DCCTYPE  /  CTYPE(4)
      COMMON  /  DCAREA   /  NNDX, NPOINT(10)
C
      DATA POS  /  1  /
      DATA CTYPE  /  'I' , 'A' , 'D' , ' '  /
C
C
C
C --- DO THE GLOBALS FIRST
C
      DCCONV = -1
      IF ( DCGLOBE ( NDE ) .NE. 0 ) RETURN
C
C --- GET THE DES
C
    2 CONTINUE
      IGO = DCNXTDE ( IS, IL, IT, POS, NX )
      IF ( IGO .EQ. 0 ) RETURN
      STRT(POS) = IS
      IF ( NX .NE. 0 ) THEN  ! SET KEY INFO AND FLAG
        KEYLEN(KNX) = IL
        KEYTYP(KNX) = CTYPE(IT)
        KNX = KNX + 1
        KEYST = KEYST + IL
        IL = -IL
      ENDIF
      LNTH(POS) = IL
      TYPE(POS) = IT
      IF ( IGO .GT. 0 ) GO TO 2
C
    4 CONTINUE
      CLOSE ( UNIT=OUTFILE, DISP='KEEP' )
C
C --- ARE ALL MULTI-FILE KEYS FOUND?
C
      IF ( NNDX .NE. 0 ) THEN
        DO 6 J=1,NNDX
          IF ( NPOINT(J) .EQ. 0 ) THEN      ! MISSING
            KERR = 27
            RETURN
          ENDIF
    6   CONTINUE
      ENDIF
C
      KNDE = NDE
      KLAS = STRT(POS) + LNTH(POS) - 1
      KLIN = (KLAS+KLEN-1)/KLEN
      KNX = KNX - 1
C
      CALL DCPOINT
C
      DCCONV = 0
      RETURN
      END
      SUBROUTINE DCPOINT
C
C --- SET UP LINE POINTERS FOR DATA INPUT
C
      INTEGER  STRT, TYPE
C
      COMMON  /  DCPOINT  /  LPO(400)
      COMMON  /  DCDENDX  /  IPOS, STRT(3000),LNTH(3000),TYPE(3000)
      COMMON  /  DCCARDL  /  KLEN, KLAS, KLIN, KNDE, KNAR
C
C
      STRT(IPOS+1) = KLIN*KLEN + 1
      TYPE(IPOS+1) = 4
      IA = 1
      IB = IPOS+1
      LPO(1) = 1
C
      DO 10 L=1,KLIN
C
      NEXTK = L*KLEN
C
      DO 6 K=IA,IB
      LPO(L+1) = K
      IF ( STRT(K) .GT. NEXTK ) GO TO 8
    6 CONTINUE
C
    8 CONTINUE
      IA = K + 1
   10 CONTINUE
C
C -- NOW BIAS THE STARTING POSITIONS
C
      DO 20 L=1,KLIN
      M = (L-1)*KLEN
      IA = LPO(L)
      IB = LPO(L+1) - 1
      DO 16 I=IA,IB
      STRT(I) = STRT(I) - M
   16 CONTINUE
   20 CONTINUE
C
      RETURN
      END
      INTEGER FUNCTION DCGLOBE ( ND )
C
C --- READ/WRITE GLOBALS
C
      INTEGER IN, OUT, ND
      INTEGER  DCNXTTY, RDNXTLN, DCNDSIZ, DCEQUAL, DCTYPER
C
      CHARACTER*132  LINE
      CHARACTER*2   TYPE
      CHARACTER*1   OP
C
      COMMON  /  DCUNITS  /  IN , OUT
      COMMON  /  DCBUFF   /  LINE
      COMMON  /  DCDFTYP  /  ITDEF
      COMMON  /  DCCARDL  /  KLEN,KLAS,KLIN,KNDE, KNAR
      COMMON  /  DCTYPE   /   OP
      COMMON  /  DCERROR  /  KERR
C
      DCGLOBE = -1
C
    2 CONTINUE
      IF ( RDNXTLN ( IN, LINE, L )  .NE. 0 ) THEN
        KERR = 143
        RETURN
      ENDIF
      IF ( DCNXTTY ( LINE,L,TYPE )  .NE. 0 ) RETURN
C
      IF ( TYPE .EQ. 'DE' ) THEN
        CALL DCOUT ( 2 , LINE , L )
        DCGLOBE = 0
        RETURN
C
      ELSE IF ( TYPE .EQ. 'CA' ) THEN
        IF ( DCEQUAL ( LINE , L , KLEN , M ) .NE. 0 ) RETURN
        CALL DCOUT ( 1 , LINE , L )
        GO TO 2
C
      ELSE IF ( TYPE .EQ. 'AR' ) THEN
        IF ( DCEQUAL ( LINE , L , KNAR , M ) .NE. 0 ) RETURN
        CALL DCOUT ( 3 , LINE , L )
        GO TO 2
C
      ELSE IF ( TYPE .EQ. 'ND' ) THEN
        IF ( DCNDSIZ ( LINE,L, ND) .NE. 0 ) RETURN
        CALL DCOUT ( 1 , LINE , L )
        GO TO 2
C
      ELSE IF ( TYPE .EQ. 'TY' ) THEN
        IF ( DCTYPER ( LINE , L , ITDEF ) .NE. 0 ) RETURN
        CALL DCOUT ( 1 , LINE , L )
        GO TO 2
C
      ELSE
        CALL DCOUT ( 1 , LINE , L )
        GO TO 2
C
      ENDIF
C
      END
      INTEGER FUNCTION DCNXTDE ( IS, IL, IT, POS, NX )
C
C ---- READ/WRITE NEXT DE SET
C
      CHARACTER*132  LINE
      CHARACTER*20  DEKEY
      CHARACTER*2   TYPE
      CHARACTER*1   KEYTYP
C
      INTEGER  POS, TTYLEN, OUT, DCNXTTY
      INTEGER  RDNXTLN, DCEQUAL, DCTYPER
C
      COMMON  /  DCBUFF   /  LINE
      COMMON  /  DCUNITS  /  IN, OUT
      COMMON  /  DCDFTYP  /  ITDEF
      COMMON  /  DCKEYNX  /  KNX, KEYLEN
      COMMON  /  DCKEYDE  /  DEKEY(20) , KEYTYP(20)
      COMMON  /  DCERROR  /  KERR
C
C
      L = TTYLEN ( LINE )
      CALL DCOUT ( 1 , LINE , L )
      POS = POS + 1
      CALL DCOUT ( 4 , LINE , POS )
      CALL DCKEYER ( LINE, L, DEKEY(KNX) , POS )
C
      DCNXTDE = 0
      IT = ITDEF
      IS = 0
      IL = 0
      NX = 0
    6 CONTINUE
      IF ( RDNXTLN ( IN, LINE, L ) .NE. 0 ) THEN
        KERR = 43
        RETURN
      ENDIF
      IF ( DCNXTTY ( LINE,L,TYPE ) .NE. 0 ) RETURN
C
      IF ( TYPE .EQ. 'DE' ) THEN
        DCNXTDE = POS
        RETURN
C
      ELSE IF ( TYPE .EQ. 'EN' ) THEN
        CALL DCOUT ( 1 , LINE , L )
        DCNXTDE = -1
        RETURN
C
      ELSE IF ( TYPE .EQ. 'ST' ) THEN
        IF ( DCEQUAL ( LINE , L , IS , M ) .NE. 0 ) RETURN
        CALL DCOUT ( 1 , LINE , L )
        GO TO 6
C
      ELSE IF ( TYPE .EQ. 'LE' ) THEN
        IF ( DCEQUAL ( LINE , L , IL, M ) .NE. 0 ) RETURN
        CALL DCOUT ( 1 , LINE , L )
        GO TO 6
C
      ELSE IF ( TYPE .EQ. 'TY' ) THEN
        IF ( DCTYPER ( LINE, L, IT ) .NE. 0 ) RETURN
        CALL DCOUT ( 1 , LINE , L )
        GO TO 6
C
      ELSE IF ( TYPE .EQ. 'US' ) THEN
        CALL DCUSE ( LINE , L , NX )
        CALL DCOUT ( 1 , LINE , L )
        GO TO 6
C
      ELSE
        CALL DCOUT ( 1 , LINE , L )
        GO TO 6
C
      ENDIF
C
      END
      SUBROUTINE DCKEYER ( LINE, L, DEKEY , POS )
C
C --- STORE DE NAME FOR POSSIBLE KEY USE
C      AND SET POINTER ARRAY FOR MULTI-FILE KEYS
C
C
      CHARACTER*(*)  LINE, DEKEY
      CHARACTER*20   ANDX
      CHARACTER*80   DIRX
C
      INTEGER  TTYLEN, POS
C
      COMMON  /  DCAREA   /  NNDX, NPOINT(10), LDIRX
      COMMON  /  DCAREAN  /  ANDX(10), DIRX
C
      DATA  NPOINT  /  10*0  /
C
C
      J = INDEX ( LINE(1:L) , '=' )
C
    2 CONTINUE
      J = J + 1
      IF ( LINE(J:J) .EQ. ' ' ) GO TO 2
C
      DEKEY(1:20) = LINE(J:J+19)
C
      IF ( NNDX .EQ. 0 ) RETURN
C
      L = TTYLEN ( DEKEY )
C
      DO 4 K=1,NNDX
        IF ( DEKEY(1:L) .EQ. ANDX(K)(1:L) ) THEN
          NPOINT(K) = POS
          RETURN
        ENDIF
    4 CONTINUE
C
      RETURN
      END
      SUBROUTINE DCUSE ( LINE , L , NX )
C
C ---- SET NX = 1 IF  USE=K
C
      CHARACTER*(*)  LINE
      CHARACTER*1    USE
C
      J = INDEX ( LINE(1:L) , '=' )
C
    2 CONTINUE
      J = J + 1
      USE = LINE(J:J)
      IF ( USE .EQ. ' ' ) GO TO 2
C
      IF ( USE .EQ. 'K' ) NX = 1
      IF ( USE .EQ. 'k' ) NX = 1
C
      RETURN
      END
      INTEGER FUNCTION DCTYPER ( LINE , L , IT )
C
C --- GET THE DATA TYPE
C
      CHARACTER*(*)  LINE
      CHARACTER*1    TYP
C
      COMMON  /  DCERROR  /  KERR
C
C
      DCTYPER = 0
      J = INDEX ( LINE(1:L), '=' )
C
      KERR = 22
    2 CONTINUE
      J = J + 1
      TYP = LINE(J:J)
      IF ( TYP .EQ. ' ' ) GO TO 2
C
      IF ( TYP .EQ. 'I' ) IT = 1
      IF ( TYP .EQ. 'A' ) IT = 2
      IF ( TYP .EQ. 'D' ) IT = 3
      IF ( IT .EQ. 0 ) DCTYPER = -1
C
      RETURN
      END
      SUBROUTINE DCOUT ( N , LINE , L )
C
C --- OUTPUT NEW DDF IF OP IS CODATA
C
      CHARACTER*(*) LINE
      CHARACTER*1   OP
C
      INTEGER OUT
C
      COMMON  /  DCUNITS  /  IN , OUT
      COMMON  /  DCTYPE   /  OP
C
C
      IF ( OP .NE. 'C' ) RETURN
C
      IF ( N .EQ. 1 ) THEN
        WRITE(OUT,1) LINE(1:L)
C
      ELSE IF ( N .EQ. 2 ) THEN
        WRITE(OUT,2) 
C
      ELSE IF ( N .EQ. 3 ) THEN
        WRITE(OUT,3)
C
      ELSE IF ( N .EQ. 4 ) THEN
        WRITE(OUT,4) L
C
      ENDIF
C
      RETURN
C
    1 FORMAT(A)
    2 FORMAT('DE = BYTES.RECORD'/'  POS = 1'/'  TYPE = I')
    3 FORMAT('AREAS = 0')
    4 FORMAT('  POS = 'I4)
C
      END
      INTEGER FUNCTION DCNDSIZ ( LINE , L , NDE )
C
C --- GET NDE, BUMP BY 1
C
      CHARACTER*(*) LINE
      CHARACTER*20  LOOK
      CHARACTER*1   LEAD
C
      INTEGER DCEQUAL
C
      DATA LEAD  /  ' '  /
C
      DCNDSIZ = -1
      IF ( DCEQUAL ( LINE, L, ND, M ) .NE. 0 ) RETURN
C
      NDE = ND + 1
      K = INTOCH ( NDE , LOOK , 5 , LEAD )
       LINE(M:M+4) = LOOK(1:5)
       L = M+4
C
      DCNDSIZ = 0
      RETURN
      END
      INTEGER FUNCTION DCEQUAL ( LINE, L, VAL, JE )
C
C --- MOVE TO FIRST CHARACTER AFTER EQUAL SIGN
C
      CHARACTER*(*) LINE
C
      COMMON  /  DCERROR  /  KERR
C
      INTEGER  SIZE, TTYLEN, VAL, CHTOIN
C
C
      DCEQUAL = -1
      J = INDEX ( LINE , '=' )
      KERR = 23
      IF ( J .LE. 0 ) RETURN
C
    2 CONTINUE
      J = J + 1
      IF ( LINE(J:J) .EQ. ' ' ) GO TO 2
      SIZE = TTYLEN ( LINE(J:L) )
      KERR = 24
      IF ( CHTOIN ( LINE(J:L), SIZE, VAL ) .LT. 0 ) 
     - RETURN
      JE = J
      DCEQUAL = 0
      RETURN
C
      END
      INTEGER FUNCTION DCNXTTY ( LINE, LENGTH, TYPE )
C
C --- NEXT CODATA TYPE
C
      CHARACTER*(*) LINE, TYPE
C
      COMMON  /  DCERROR  /  KERR
C
C
      DCNXTTY = 0
C
      DO 4 J=1,LENGTH
      IF ( LINE(J:J) .EQ. ' ' ) GO TO 4
      TYPE(1:2) = LINE(J:J+1)
      RETURN
C
    4 CONTINUE
C
      DCNXTTY = -1
      KERR = 23
      RETURN
C
      END
      INTEGER FUNCTION DCDATA ( KK )
C
C --- READ DATA PORTION OF CODATA FILE AND COMPRESS
C
C --- USE POINTERS SET UP IN DDF CONVERSION
C
      CHARACTER*80  DDFFILE, DDXFILE, DATFILE, NDXFILE
      CHARACTER*132  BUFFER
      CHARACTER*1   KT, CTYPE, ACCES, NEXT
C
      INTEGER  TTYLEN, CMPOPEN, CMPOUT, DCHOLD
      INTEGER  UNITIN, UNITOUT, STRT, TYPE
      INTEGER  RDNXTLN
C
      LOGICAL*1  OUT(30000)
C
      COMMON  /  DCFILES  /  DDFFILE,DDXFILE,DATFILE,NDXFILE
      COMMON  /  DCUNITS  /  UNITIN, UNITOUT
      COMMON  /  DCPOINT  /  LPO(400)
      COMMON  /  DCDENDX  /  IPOS, STRT(3000), LNTH(3000), TYPE(3000)
      COMMON  /  DCCTYPE  /  CTYPE(4)
      COMMON  /  DCCARDL  /  KLEN, KLAS, KLIN, KNDE, KNAR
      COMMON  /  DCBUFF   /  BUFFER
      COMMON  /  DCERROR  /  KERR
      COMMON  /  DCACCES  /  ACCES
      COMMON  /  DCKEYS   /  KSTART
      COMMON  /  DCRECSZ  /  NRECSZ
      COMMON  /  DCAREA   /  NNDX, NPOINT(10)
C
C
C
      DCDATA = -1
C
      IF ( NNDX .EQ. 0 ) THEN            !  SINGLE FILE
C
C ---- OPEN NDX FILE AND WRITE DDF
C
      CALL DCNXDDF 
      IF ( KERR .NE. 0 ) RETURN
C
C .... OPEN DATFILE
C
      KERR = CMPOPEN ( DATFILE , ACCES , NRECSZ )  
      IF ( KERR .NE. 0 ) RETURN
C
      ELSE                         ! MULTIPLE FILES
        NDXFILE = 'ZZZZNDX.SCR'
        CALL DCNXDDF
        IF ( KERR .NE. 0 ) RETURN
        LAREA = 0
      ENDIF
C
C
C --- LOOP OVER AREAS
C
      DO 50 NA=1,KNAR
C
      CALL CMPSTRT ( OUT , N )
      KSTART = 0
C
C --- LOOP OVER DE
C --- LINES/DE
C
      DO 30 NL=1,KLIN
C
      IA = LPO(NL)
      IF ( STRT(IA) .EQ. 0 ) IA = 2
      IB = LPO(NL+1) - 1
C
C --- INPUT LINE
C
      IF ( RDNXTLN ( UNITIN, BUFFER, L ) .NE. 0 ) RETURN
C
      IF ( L .LE. 0 ) L=1
C
C --- ITEMS/LINE
C
      DO 20 I=IA,IB
C
      IS = STRT(I)
      IL = IABS(LNTH(I))
      IT = TYPE(I)
      KT = CTYPE(IT)
      NT = TYPE(I+1)
      NEXT = CTYPE(NT)
C
      IF ( NNDX .NE. 0 ) CALL DCKFIND ( BUFFER(IS:IS), IL, I )
C
      KERR = DCHOLD ( BUFFER(IS:IS), IL, KT, NEXT, OUT, N )
      IF ( KERR .NE. 0 ) RETURN
C
      IF ( LNTH(I) .LT. 0 ) CALL DCKEY ( BUFFER(IS:IS),IL )
   20 CONTINUE
C
   30 CONTINUE
C
      IF ( NNDX .NE. 0 ) THEN
        CALL DCNXOUT ( LAREA )
        IF ( KERR .NE. 0 ) RETURN
      ENDIF
C
      KERR = CMPOUT ( OUT , N , IREC )
      IF ( KERR .NE. 0 ) RETURN
      CALL DCNDX ( IREC , N )
C
   50 CONTINUE
C
      IF ( NNDX .NE. 0 ) THEN        ! CLOSE MULTIPLE FILE
        CALL DCFSWAP ( LAREA )
      ELSE
        CALL CMPCLOS
      ENDIF
C
      DCDATA = 0
C
      RETURN
C
      END
      SUBROUTINE DCKFIND ( BUF, L, INX )
C
C --- GET VALUE OF KEY IF INX=ONE OF THE POINTERS
C
      CHARACTER*(*)  BUF
      CHARACTER*20   ANDX
      CHARACTER*80   DIRX
C
      COMMON  /  DCAREA   /  NNDX, NPOINT(10), LDIRX
      COMMON  /  DCAREAN  /  ANDX(10), DIRX
      COMMON  /  DCAREAL  /  LNX(10)
C
C
      DO 2 J=1,NNDX
        IF ( NPOINT(J) .EQ. INX ) GO TO 4
    2 CONTINUE
      RETURN
C
C --- FOUND ONE
C
    4 CONTINUE
      ANDX(J) = BUF(1:L)//' '
      LNX(J) = L
      RETURN
C
      END
      SUBROUTINE DCNXOUT ( LAREA )
C
C --- MATCH OLD/NEW KEYS 
C
      CHARACTER*20  ANDX
      CHARACTER*80  DIRX
      CHARACTER*80  DDFF, DDXF, DATF, NDXF
      CHARACTER*1   ACCES
      CHARACTER*10  OLDF, NEWF
C
      INTEGER  CMPOPEN, DCFNAME
C
      COMMON  /  DCFILES  /  DDFF, DDXF, DATF, NDXF
      COMMON  /  DCRECSZ  /  NRECSZ
      COMMON  /  DCACCES  /  ACCES
      COMMON  /  DCERROR  /  KERR
      COMMON  /  DCMPFLG  /  KCMP
      COMMON  /  DCAREA   /  NNDX, NPOINT(10), LDIRX
      COMMON  /  DCAREAN  /  ANDX(10), DIRX
      COMMON  /  DCAREAL  /  LNX(10)
C
      DATA  OLDF, NEWF  /  '  '  , '  '  /
C
      DATA  KCMP  /  0  /
C
C
C
      CALL DCNAMER ( OLDF, NEWF, IGO )
      IF ( IGO .EQ. 0 ) THEN
        LAREA = LAREA + 1
        RETURN
      ENDIF
C
C --- CLOSE OLD FILES , OPEN NEW ONES
C
       IF ( KCMP .NE. 0 ) CALL DCFSWAP ( LAREA )
C
       NDXF = 'ZZZZNDX.SCR'
       CALL DCNXDDF
C
C -- NEW FILE NAME
C
      DATF = DIRX(1:LDIRX)//NEWF//' '
      KERR = DCFNAME ( %REF(DATF), %REF(DATF), LN )
      IF ( KERR .NE. 0 ) RETURN
      DATF = DATF(1:LN)//'.DAT'
      NDXF = DATF(1:LN)//'.NDX'
C
      KERR = CMPOPEN ( DATF, ACCES, NRECSZ )
      KCMP = 1
      OLDF = NEWF
      LAREA = 1
C
      RETURN
      END
      SUBROUTINE DCFSWAP ( LAREA )
C
C --- CLOSE 'DAT', OPEN 'NDX', COPY FROM 'SCR', CLOSE 'NDX'
C
      CHARACTER*80  LINE, DDFF, DDXF, DATF, NDXF
C
      INTEGER  TTYLEN
C
      COMMON  /  DCFILES  /  DDFF, DDXF, DATF, NDXF
      COMMON  /  DCXUNIT  /  NXUNIT
      COMMON  /  DCERROR  /   KERR
C
C
C
      CALL CMPCLOS
C
C --- COPY NDX
C
      CALL NXTUNIT ( NXU )
      OPEN ( UNIT=NXU, NAME=NDXF, TYPE='NEW', ERR=20 )
      REWIND NXU
      WRITE(NXUNIT,2) 
    2 FORMAT('ENDSCR')
      REWIND NXUNIT
C
    4 CONTINUE
      READ(NXUNIT,6) LINE
    6 FORMAT(A80)
C
      IF ( LINE(1:5) .EQ. 'AREAS' ) GO TO 10
      IF ( LINE(1:4) .EQ. 'VAX=' ) THEN        ! DAT NAME
        L = TTYLEN ( DATF ) 
        LINE = 'VAX='//DATF//' '
      ENDIF
      L = TTYLEN ( LINE )
      WRITE(NXU,8) LINE(1:L)
    8 FORMAT(A)
      GO TO 4
C
   10 CONTINUE
      WRITE(NXU,12) LAREA
   12 FORMAT('AREAS='I4)
C
   14 CONTINUE
      READ(NXUNIT,6) LINE
      IF ( LINE(1:6) .EQ. 'ENDSCR' ) GO TO 16
      L = TTYLEN(LINE)
      WRITE(NXU,8) LINE(1:L)
      GO TO 14
C
   16 CONTINUE
      CALL CLSUNIT ( NXUNIT, 'DELETE' )
      CALL CLSUNIT ( NXU   , ' '      )
C
      RETURN
C
   20 CONTINUE
      CALL IOERR ( 'DCFSWAP' )
      KERR = 176
      RETURN
C
      END
      SUBROUTINE DCNAMER ( OLD, NEW, IGO )
C
C --- MATCH NAMES, FLAG IF DIFFERENT
C
      CHARACTER*(*)  OLD, NEW
      CHARACTER*20   ANDX
      CHARACTER*80   DIRX
C
      COMMON  /  DCAREA   /  NNDX , NPOINT(10), LDIRX
      COMMON  /  DCAREAN  /  ANDX(10), DIRX
      COMMON  /  DCAREAL  /  LNX(10)
C
C
C -- CREATE NEW NAME
C
      IA = 1
      DO 4 N=1,NNDX
C
        L = LNX(N)
        IB = IA + L - 1
C
        DO 2 I=1,L 
          IF ( ANDX(N)(I:I) .EQ. ' ' ) ANDX(N)(I:I)='0'  ! LEADING ZEROES
    2   CONTINUE
C
        NEW(IA:IB) = ANDX(N)(1:L)
        IA = IB + 1
    4 CONTINUE
C
C -- MATCH
C
      IF ( OLD(1:IB) .EQ. NEW(1:IB) ) THEN
        IGO = 0
      ELSE
        IGO = IB
      ENDIF
C
      RETURN
      END
      INTEGER FUNCTION DCHOLD ( BUF, SIZE, TYPE, NEXT, OUT, N )
C
C --- DETERMINE TYPE AND CONVERT OR HOLD DEPENDING ON NEXT
C
      CHARACTER*(*)  BUF
      CHARACTER*1    TYPE, NEXT
C
      LOGICAL*1  OUT(1)
C
      INTEGER  CMPCH, CHTODP, CMPINTG, CMPDPR
      INTEGER  SIZE, IVAL(100)
C
      DOUBLE PRECISION  MAX, DVAL, DPR(100)
C
      DATA  MAX  /  4 000 000 000.  /
      DATA  K    /  0  /
C
C
C
      DCHOLD = 0
C
      IF ( TYPE .EQ. 'A' ) THEN       ! ASCII -- CONVERT
        DCHOLD = CMPCH ( BUF, SIZE, OUT, N )
        K = 0
        RETURN
C
      ELSE IF ( TYPE .EQ. 'D' ) THEN  ! D.P.REAL
        K = K + 1
        KERR = CHTODP ( BUF, SIZE, DPR(K) )
        IF ( KERR .EQ. -1 ) GO TO 10
        IF ( (NEXT.EQ.'D') .AND. (K.LT.100) ) RETURN
        DCHOLD = CMPDPR ( DPR, K, OUT, N )
        K = 0
        RETURN
C
      ELSE IF ( TYPE .EQ. 'I' ) THEN  ! INTEGER
        KERR = CHTODP ( BUF, SIZE, DVAL )
        IF ( KERR .EQ. -1 ) GO TO 10
C
        IF ( ABS(DVAL) .GT. MAX ) THEN    ! TOO BIG FOR INTEGER
          IF ( K .NE. 0 ) KERR=CMPINTG ( IVAL, K, OUT, N )
          DCHOLD = CMPDPR ( DVAL, 1, OUT, N )
          K = 0
          RETURN
        ELSE
          K = K + 1
          IVAL(K) = INT(DVAL)
          IF ( (NEXT.EQ.'I') .AND. (K.LT.100) ) RETURN
          DCHOLD = CMPINTG ( IVAL, K, OUT, N )
          K = 0
          RETURN
        ENDIF
      ENDIF
C
   10 CONTINUE
      DCHOLD = 24
      RETURN
C
      END
      SUBROUTINE DCKEY ( BUF , SIZE )
C
C --- PUT KEY INTO INDEX LINE
C
      CHARACTER*(*)  BUF
      CHARACTER*200  LINE
C
      INTEGER  SIZE
C
      COMMON  /  DCKEYS  /  KSTART
      COMMON  /  DCKLINE /  LINE
C
C
C
      IF ( KSTART .EQ. 0 ) CALL TTYBLNK ( LINE )
C
      IA = KSTART + 2
      IB = KSTART + SIZE + 1
C
      LINE(IA:IB) = BUF(1:SIZE)
C
      KSTART = IB
      RETURN
      END
      SUBROUTINE DCNDX ( IREC , NREC )
C
C --- PUT REC. NO. AND SIZE INTO KEY LINE AND WRITE
C
      CHARACTER*200  LINE
      CHARACTER*1    LEAD
C
      COMMON  /  DCKLINE  /  LINE
      COMMON  /  DCKEYS   /  KSTART
      COMMON  /  DCXUNIT  /  NXUNIT
C
      DATA  LEAD  /  ' '  /
C
C
C
      IA = KSTART+2
      IB = KSTART+8
      KERR = INTOCH ( NREC, LINE(IA:IA), 5, LEAD )
C
      IA = IB 
      IB = IB + 6
      KERR = INTOCH ( IREC, LINE(IA:IA) , 7 , LEAD)
C
      WRITE(NXUNIT,10) LINE(1:IB)
   10 FORMAT(A)
C
      RETURN
      END
      SUBROUTINE DCNXDDF 
C
C --- OPEN NDX FILE AND WRITE DDF
C
      CHARACTER*132 BUF
      CHARACTER*80  DDF, DDX, DAT, NDX
      CHARACTER*20  DEKEY
      CHARACTER*1   ACCES, CTYPE, KEYTYP, IT
C
      INTEGER  TTYLEN, DCRSIZE
C
      COMMON  /  DCFILES  /  DDF, DDX, DAT, NDX
      COMMON  /  DCXUNIT  /  NXUNIT
      COMMON  /  DCAREA   /  NNDX , NPOINT(11)
      COMMON  /  DCBUFF   /  BUF
      COMMON  /  DCCARDL  /  KLEN, KLAS, KLIN, KNDE, KNAR
      COMMON  /  DCACCES  /  ACCES
      COMMON  /  DCRECSZ  /  NRECSZ
      COMMON  /  DCKEYDE  /  DEKEY(20) , KEYTYP(20)
      COMMON  /  DCKEYNX  /  KNX, KST, KEYLEN(20), KEYPOS(20)
      COMMON  /  DCCTYPE  /  CTYPE(4)
      COMMON  /  DCERROR  /  KERR
C
C ===> USE DIRECT ACCESS SIZE OF 32 ( 128 BYTES ) FOR NOW
C
      DATA  NRECSZ /  32  /
C
C
      KERR = 0
      CALL NXTUNIT ( NXUNIT )
C
      IF ( NNDX .EQ. 0 ) THEN
        OPEN ( UNIT=NXUNIT, NAME=NDX, TYPE='NEW', ERR=20 )
      ELSE
        OPEN ( UNIT=NXUNIT, NAME=NDX, TYPE='SCRATCH', ERR=20 )
      ENDIF
C
      REWIND NXUNIT
C
      NRECSZ = DCRSIZE ( KLAS )
C
C
C --- NDX DDF
C
      L = TTYLEN ( DAT )
      WRITE(NXUNIT,1) DAT(1:L), ACCES(1:1), NRECSZ
    1 FORMAT('VAX='A/'ACCESS='A/'RECORDSIZE='I3)
C
      NDE = KNX + 2
      WRITE(NXUNIT,2) NDE, KNAR
    2 FORMAT('NDE='I2/'AREAS='I5/'CARDLENGTH= 70')
C
C --- DE KEYS
      IS = 2
C
      DO 5 K=1,KNX
      L = TTYLEN(DEKEY(K))
      IT = KEYTYP(K)
      IL = KEYLEN(K)
      WRITE(NXUNIT,4) DEKEY(K)(1:L), IS, IL, IT
    4 FORMAT('DE='A/'  USE=K'/'  START='I3/'  LENGTH='I2/'  TYPE='A)
      IS = IS + IL + 1
    5 CONTINUE
C
C --- ADD RECORD DE
C
      IL = 5
      WRITE(NXUNIT,6) 
    6 FORMAT('DE=RECORD.SIZE')
      WRITE(NXUNIT,7) IS,IL
    7 FORMAT('  USE=D'/'  START='I3/'  LENGTH='I1/'  TYPE=I')
C
      IS = IS + IL + 1
      IL = 7
      WRITE(NXUNIT,8)
    8 FORMAT('DE=RECORD.NUMBER')
      WRITE(NXUNIT,7) IS,IL
      WRITE(NXUNIT,9)
    9 FORMAT('END DDF')
      RETURN
C
   20 CONTINUE
      CALL IOERR ( 'DCNXDDF' )
      KERR = 176
      RETURN
C
      END
      INTEGER FUNCTION DCRSIZE ( LAST )
C
C --- DETERMINE OPTIMUM RECORD SIZE
C
      LOOK = LAST/32
C
      N = 8*(LOOK+1)
      IF ( N .GT. 512 ) N = 512
      IF ( N .LT.  32 ) N = 32
C
      DCRSIZE = N/4
C
      RETURN
      END
      INTEGER FUNCTION DCARGS ( UNIT,TYP, ACC, DIR, DIR2 )
C
C -- CHECK USER ARGS AND SET OUTPUT FILE NAMES
C
      LOGICAL*1  TYP, ACC, DIR(1), DIR2(1)
C
      CHARACTER*132 BUFFER
      CHARACTER*80  DDF, DDX, DAT, NDX
      CHARACTER*1   ACCES, TYPE
C
      INTEGER  UNIT, OUT, DCFNAME
C
C
      COMMON  /  DCFILES  /  DDF, DDX, DAT, NDX
      COMMON  /  DCUNITS  /  IN, OUT
      COMMON  /  DCBUFF   /  BUFF
      COMMON  /  DCACCES  /  ACCES
      COMMON  /  DCTYPE   /  TYPE
      COMMON  /  DCERROR  /  IERR
C
C
C
C
      IERR = 140
C
C --> TYPE - CODATA (C) OR DDX (X)
C
      IF ( (TYP .EQ. "130) .OR. (TYP .EQ. "170) ) THEN
        TYPE = 'D'
      ELSE
        TYPE = 'C'
      ENDIF
C
C --> DATA ACCESS, DIRECT (D) OR SEQUENTIAL (S)
C
      IF ( (ACC .EQ. "123) .OR. (ACC .EQ. "163) ) THEN
        ACCES = 'S'
      ELSE
        ACCES = 'D'
      ENDIF
C
C -- DIRECTORY/FILE NAME
C
      IERR = 151
      IF ( DCFNAME(DIR, %REF(BUFFER), L) .NE. 0 ) RETURN
C
      IF ( TYPE .EQ. 'C' ) THEN
        DDF = BUFFER(1:L)//'.DDF'
        DDX = BUFFER(1:L)//'.DDX'
      ENDIF
C
      IF ( DCFNAME(DIR2,%REF(NDX),LL) .EQ. 0 ) THEN
        IF ( LL .GT. 0 ) THEN
          BUFFER(1:LL) = NDX(1:LL)
          L = LL
        ENDIF
      ENDIF
C
      DAT = BUFFER(1:L)//'.DAT'
      NDX = BUFFER(1:L)//'.NDX'
C
      DCARGS = 0
C
      RETURN
      END
      INTEGER FUNCTION DCFNAME ( IN, OUT, LENGTH )
C
C --- CHECK FILE NAME UP TO BLANK, PERIOD OR EOS
C
      LOGICAL*1  IN(1), OUT(1)
      LOGICAL*1  SKIP, UP, LOW, EOS, PERIOD, LOOK, LBR, RBR
C
      DATA  UP,   LOW,  EOS,  LBR,  RBR,  PERIOD  /
     -     "172, "040, "000, "133, "135, "056     /
C
C
C
      DCFNAME = -1
      SKIP = PERIOD
C
      DO 4 J=1,80
      LOOK = IN(J)
      IF ( LOOK .EQ. EOS  ) GO TO 8
      IF ( LOOK .GT. UP   ) RETURN
      IF ( LOOK .LT. LOW  ) RETURN
      IF ( LOOK .EQ. LBR ) SKIP=LOW
      IF ( LOOK .EQ. RBR ) SKIP=PERIOD
      IF ( LOOK .EQ. LOW  ) GO TO 8
      IF ( LOOK .EQ. SKIP ) GO TO 8
      OUT(J) = IN(J)
    4 CONTINUE
      RETURN
C
    8 CONTINUE
      LENGTH = J - 1
      DCFNAME = 0
      RETURN
C
      END
      SUBROUTINE DCUNIT ( RATUNIT, FORUNIT )
C
C ..... RE-OPEN INPUT FOR FORTRAN READS
C         BY-PASSING RAT4 I/O  (JOE, 4/8/82)
C
      CHARACTER*80  NAME
C
      INTEGER   RATUNIT, FORUNIT, TTYLEN
      INTEGER   ACCESS, JUNK, FILNFO
C
C
      JUNK = FILNFO ( RATUNIT, %REF(NAME), ACCESS )
C
      CALL NXTUNIT ( FORUNIT )
      L = TTYLEN ( NAME )
      NAME(L+1:80) = ' '
      OPEN(UNIT=FORUNIT,NAME=NAME,TYPE='OLD',READONLY,ERR=10)
      REWIND FORUNIT
C
      RETURN
C
   10 CONTINUE
      CALL IOERR ( ' OPEN INPUT' )
      CALL EXIT
C
      END