
      PROGRAM  UPDATE
C
C     Revision Author:   M. Steven Baker
C     Revision Date:     August 11, 1986
C
C     Revised for RM Fortan on PC
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>  COMPILER DEPENDENT
C---
C---          ENDER ERDEM          LAWRENCE BERKELEY LABORATORY  1981
C---
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /CARD/   CARD(80), JCARD, LINCNT, PRTFLG, ICH
     1               ,IFL(8)  , BKSPFL
      COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
     1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
      COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
     9              , WARNFL, SHOWFL
C---
      OPEN( UNIT=INPUT , FILE='INPUT.TMP' , STATUS='old' )
      OPEN( UNIT=OUTPUT, FILE='OUTPUT.'   , STATUS='UNKNOWN')
C    .                                    , ACCESS='APPEND' )
      OPEN( UNIT=OLDPL , FILE='OLDPL.TMP' , STATUS='UNKNOWN' )
      OPEN( UNIT=NEWPL , FILE='NEWPL.TMP' , STATUS='UNKNOWN' )
      OPEN( UNIT=COMPIL, FILE='COMPIL.TMP', STATUS='UNKNOWN' )
      OPEN( UNIT=EDTT  , FILE='EDTT.TMP'  , STATUS='UNKNOWN' )
C    .                                    , FORM='UNFORMATTED' )
      OPEN( UNIT=PL1TMP, FILE='PL1TMP.TMP', STATUS='UNKNOWN' )
C    .                 , buffercount=8    , dispose='delete' )
      OPEN( UNIT=PL2TMP, FILE='PL2TMP.TMP', STATUS='UNKNOWN' )
C    .                 , buffercount=8    , dispose='delete' )
      PLTMP = PL1TMP
C------ CK OLDPL
      REWIND  OLDPL
C>>>>>>>> *EOF* <<<<<<<<
      READ( OLDPL, 1001, END=200 )
1001  FORMAT( 20A4 )
        GOTO  300
C------ CREATION RUN .
200   WRITE(OUTPUT,1011)
1011  FORMAT(46H1U P D A T E   C R E A T I O N   L I S T I N G//)
       CALL  CREATE ( PLTMP, ERRCRT )
      GOTO  500
C------ UPDATE RUN .
300   WRITE(OUTPUT,1012)
1012  FORMAT(50H1U P D A T E   C O R R E C T I O N   L I S T I N G//)
      PLIN = OLDPL
       CALL  OPLRD
400    CALL  CORRD
      IF( ERRFLG .NE. 0 )  CALL  ERROR ( 99 )
       CALL  CORECT
C------ CK IF MORE *ID
500   WRITE(OUTPUT,1013)
1013  FORMAT( /,1X,90(1H-),// )
520   IF( ERRFLG .NE. 0 )  CALL  ERROR ( 99 )
          PLIN  = PLTMP
          PLTMP = PL1TMP
          IF( PLIN .EQ. PL1TMP )  PLTMP = PL2TMP
          ENDFILE  PLIN
          REWIND  PLTMP
          ENDFILE PLTMP
          REWIND  PLIN
          REWIND  PLTMP
          IF( RESEQF .EQ. 0 )  GOTO  570
               CALL  RESEQ
              RESEQF = 0
              GOTO  520
570       IF( BKSPFL .NE. 0 )  GOTO  400
       CALL  WNEWPL
      IF( ERRFLG .NE. 0 )  CALL  ERROR ( 99 )
      END
      SUBROUTINE  A1A4 ( I1, I4, N )
C---
C--- PACK 4*N WORDS OF A1 FORMAT IN I1 INTO N WORDS OF A4 FORMAT IN I4
C---
      DIMENSION  I1(80), I4(20)
      LOGICAL*1  L1(4), L4(4)
      EQUIVALENCE  ( ITEMP, L1(1) ),  ( JTEMP, L4(1) )
      J = 0
      DO  200  I = 1 , N
          DO  100  K = 1 , 4
          J = J + 1
          ITEMP = I1(J)
          L4(K) = L1(1)
 100      CONTINUE
      I4(I) = JTEMP
 200  CONTINUE
      RETURN
      END
      SUBROUTINE  A4A1 ( I4, I1, N )
      DIMENSION  I4(20), I1(80)
      LOGICAL*1  L4(4), L1(4)
      EQUIVALENCE ( IT, L4(1) ),  ( J1, L1(1) )
      DATA ISPACE/4H    /
      J = 0
      DO  2  I = 1 , N
      IT = I4(I)
          DO  1  K = 1 , 4
          J1 = ISPACE    
          L1(1) = L4(K)
          J = J + 1
          I1(J) = J1
1         CONTINUE
2     CONTINUE
      RETURN
      END
      BLOCK DATA
C---
C---
C---
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /CARD/   CARD(80), JCARD, LINCNT, PRTFLG, ICH
     1               ,IFL(8)  , BKSPFL
      COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
      COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
     1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
     2              , NCOMDK, NDECK , NIDENT
     3              , MMEM  , NMSTOR, NMFETC
     4              , MCORTB, NCORTB, MMODLS, NMODLS
     5              , LASTDK
      COMMON          SYMTB(7,400)  , DIRLST(5,2000)
     1              , CORTBL(5,1000), MODLST(2,1000)
     2              , MEM(20000)
      COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
     1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
      COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
     9              , WARNFL, SHOWFL
      COMMON /OPTBL/  OPTBL(5,11), NOPTBL, JOP, OPARG
C---
      DATA  MSYMTB /400/
      DATA  MDIRLS/2000/
     1    , MCORTB/1000/
     2    , MMODLS/1000/
     3    , MMEM  /20000/
C-
      DATA  LINCNT /0/, BKSPFL /0/
C-
      DATA  STAR, BLNK, COMA, PERD, SLAS
     1     /1H* , 1H  , 1H, , 1H. , 1H/ /
C-
      DATA  NCOMDK, NDECK, NIDENT, NDIRLS, NSYMTB /5*0/
C-
      DATA            INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
     1              , EDTT  , PL1TMP, PL2TMP
     2              / 1     , 6     , 2     , 3     , 4
     3              , 10    , 11    , 12    /
C-
      DATA  FULFLG/1/,RESEQF/0/,PRECOF/0/,NPLFLG/1/,ERRFLG/0/
     1    , WARNFL/0/
      DATA  SHOWFL/1/
C-
      DATA  NOPTBL/11/
      DATA  OPTBL /4HD   ,4HDELE,4HTE  , 9,-2,
     1             4HI   ,4HINSE,4HRT  ,10,-1,
     2             4HCA  ,4HCALL,4H    , 2, 1,
     3             4HCD  ,4HCOMD,4HECK , 4, 1,
     4             4HDK  ,4HDECK,4H    , 3, 1,
     5             4HID  ,4HIDEN,4HT   , 1, 1,
     6             4HAF  ,4HADDF,4HILE ,11, 2,
     7             4HPC  ,4HPREC,4HOMP , 7, 0,
     8             4HW   ,4HWEOF,4H    , 5, 0,
     9             4HPA  ,4HPART,4HIAL , 8, 0,
     1             4HS   ,4HSEQU,4HENCE, 6, 0/
C---
      END
      SUBROUTINE  CALINP ( DKFL, ISYM, ERR )
C---
C--- PROCESS *CA INPUT
C---
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
      COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
     1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
     2              , NCOMDK, NDECK , NIDENT
     3              , MMEM  , NMSTOR, NMFETC
     4              , MCORTB, NCORTB, MMODLS, NMODLS
     5              , LASTDK
      COMMON          SYMTB(7,400)  , DIRLST(5,2000)
     1              , CORTBL(5,1000), MODLST(2,1000)
     2              , MEM(20000)
      COMMON /OP/     IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
C---
      ERR = 0
      IF( DKFL .EQ. -1 )  GOTO  8009
      IF( ID1(2) .EQ. -1 )  GOTO  8800
      IF( ID1(1) .EQ. BLNK )  GOTO  8007
       CALL  SYMSRC ( ID1, ISYM )
      IF( ISYM .EQ. 0 )  GOTO  8010
      IF( SYMTB(3,ISYM) .NE. -1 )  GOTO  8011
9000      RETURN
C------ NAME MISSING
8007   CALL  ERROR ( 7 )
      GOTO  8800
C------ CAN*T CALL FROM A COMDECK
8009   CALL  ERROR ( 9 )
      GOTO  8800
C------ COMDECK NOT FOUND
8010   CALL  ERROR ( 10 )
      GOTO  8800
C------ CAN*T CALL A DECK
8011   CALL  ERROR ( 11 )
8800  ERR = 1
      ISYM = 0
      GOTO  9000
      END
      SUBROUTINE  CARDRD ( CREAT )
C
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>  COMPILER DEPENDENT
C-
C--- READ ONE LINE OF CORRECTION INPUT
C-
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /CARD/   CARD(80), JCARD, LINCNT, PRTFLG, ICH
     1               ,IFL(8)  , BKSPFL
      COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
      COMMON /CURRID/ IDFL
      COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
     9              , WARNFL, SHOWFL
      COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
     1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
      COMMON /OP/     IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
      COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
     1              , CARD4S(20)
          DIMENSION  REC(22)
              EQUIVALENCE  (DIRNUM, REC(1))
C---
      DATA  SHOW1/4H*/ */,  SHOW2/4HSHOW/,  SHOW3/4HNOSH/
C---
1001  FORMAT( 20A4 )
1002  FORMAT( 1X,I7,1H.,20A4 )
1015  FORMAT( 1X,2H//,I5,1H.,20A4 )
1016  FORMAT( 1X,2H..,I5,1H.,20A4 )
C---
      CALFLG = 0
      IF( BKSPFL .EQ. 0 )  GOTO  300
              DO  240  I = 1 , 20
240           CARD4(I) = CARD4S(I)
              GOTO  340
C>>>>>>>>> *EOF* <<<<<<<<<
300   READ( INPUT, 1001, END=700 ) CARD4
      LINCNT = LINCNT + 1
340    CALL  A4A1 ( CARD4(1), CARD(1), 1 )
          DO  302  I = 1 , 20
          I2 = 21 - I
          IF( CARD4(I2) .NE. BLNK )  GOTO  304
302       CONTINUE
304   CONTINUE
      OP = 0
      IF( CARD(1) .NE. STAR )  GOTO  600
          IF( CARD(2) .NE. SLAS )  GOTO  400
      IF( (CARD4(1).EQ.SHOW1) .AND. (CARD4(2).EQ.SHOW2) )
     9     SHOWFL = 1
      IF( (CARD4(1).EQ.SHOW1) .AND. (CARD4(2).EQ.SHOW3) )
     9     SHOWFL = 0
              WRITE( OUTPUT, 1016 )  LINCNT, (CARD4(I), I=1,I2)
              GOTO  300
400        CALL  A4A1 ( CARD4(2), CARD(5), 19 )
           CALL  OPGET
          IF( OP .EQ. 0 )  GOTO  600
          TYP = OP
          IF( (BKSPFL .NE. 0) .OR. (OP .EQ. 1) )  GOTO  900
              WRITE( OUTPUT, 1015 )  LINCNT, (CARD4(I), I=1,I2)
              GOTO  900
600   TYP = 1
      IF( CREAT .NE. 0 )  GOTO  900
          WRITE( OUTPUT, 1002 )  LINCNT, (CARD4(I), I=1,I2)
900   BKSPFL = 0
      RETURN
700   OP = 99
      GOTO  900
      END
      SUBROUTINE  COMPWT ( REC )
C---
C--- WRITE ONE LINE OF COMPILE FILE
C---
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
     1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
     2              , NCOMDK, NDECK , NIDENT
     3              , MMEM  , NMSTOR, NMFETC
     4              , MCORTB, NCORTB, MMODLS, NMODLS
     5              , LASTDK
      COMMON          SYMTB(7,400)  , DIRLST(5,2000)
     1              , CORTBL(5,1000), MODLST(2,1000)
     2              , MEM(20000)
      COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
     1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
      COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
     9              , WARNFL, SHOWFL
C---
      DIMENSION  REC(22), NM(2), LINE1(20), LINE2(20)
C---
      J = REC(1)
      NM(1) = SYMTB(1,J)
      NM(2) = SYMTB(2,J)
      IF(PRECOF .EQ. 0)  GOTO 10
      CALL PRECMP(REC(3),LINE1,LINE2,NL)
      IF( PRECOF .EQ. 0 )  GOTO  10
      IF( REC(2) .LT. 100 )  GOTO  20
      IF( REC(2) .LT.1000 )  GOTO  30
        WRITE(COMPIL,44) LINE1, NM, REC(2)
        IF(NL .EQ. 2)
     1  WRITE(COMPIL,44) LINE2, NM, REC(2)
      GOTO  900
30      WRITE(COMPIL,33) LINE1, NM, REC(2)
        IF(NL .EQ. 2)
     1  WRITE(COMPIL,33) LINE2, NM, REC(2)
      GOTO  900
20      WRITE(COMPIL,22) LINE1, NM, REC(2)
        IF(NL .EQ. 2)
     1  WRITE(COMPIL,22) LINE2, NM, REC(2)
      GOTO 900
   10 IF( REC(2) .LT. 100 )  GOTO  2
      IF( REC(2) .LT.1000 )  GOTO  3
        WRITE(COMPIL,44) (REC(I), I=3,22), NM, REC(2)
      GOTO  900
3       WRITE(COMPIL,33) (REC(I), I=3,22), NM, REC(2)
      GOTO  900
2       WRITE(COMPIL,22) (REC(I), I=3,22), NM, REC(2)
900   RETURN
22    FORMAT( 22A4,I2 )
33    FORMAT( 21A4,A3,I3 )
44    FORMAT( 21A4,A2,I4 )
      END
      SUBROUTINE  CORECT
C---
C--- CORRECT (PLIN) WITH (MEM) CREATING (PLTMP)
C---
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /CURRID/ IDFL
      COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
     1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
     2              , NCOMDK, NDECK , NIDENT
     3              , MMEM  , NMSTOR, NMFETC
     4              , MCORTB, NCORTB, MMODLS, NMODLS
     5              , LASTDK
      COMMON          SYMTB(7,400)  , DIRLST(5,2000)
     1              , CORTBL(5,1000), MODLST(2,1000)
     2              , MEM(20000)
      COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
     1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
      COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
     9              , WARNFL, SHOWFL
      COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
     1              , CARD4S(20)
          DIMENSION  REC(22)
              EQUIVALENCE  (DIRNUM, REC(1))
C---
      DIMENSION  SYMTB2(7,300), DIRLS2(5,500)
            EQUIVALENCE ( MEM(1), SYMTB2(1,1), DIRLS2(1,1) )
      DIMENSION  SEQ0(2)
            DATA SEQ0 / 0, 0 /
C---
      IF( SHOWFL .NE. 0 )  CALL  DIPRNT( -1 )
      KDIRLS = NDIRLS
      IDSEQ  = 0
       CALL  RDPLIN
      DO  10000  IDIRLS = 1 , NDIRLS
      IF( DIRLST(5,IDIRLS) .EQ. 0 )  GOTO  10000
        JDIRLS = IDIRLS
        IM = DIRLST(5,JDIRLS)
1200    IC = MODLST(1,IM)
        OP = CORTBL(1,IC)
        IF( SHOWFL .NE. 0 )  CALL  DIPRNT( 0 )
            IDF   = IDFL
            IF( OP .NE. 11 )  GOTO  1800
C...............*AF
                ISY = CORTBL(2,IC)
C....................LOOK THRU DIRLST TO FIND LAST LINE
1300             IF( SYMTB(6,ISY) .EQ. 0 )  GOTO  1310
                     ISY = SYMTB(6,ISY)
                     GOTO  1300
1310            I = SYMTB(5,ISY)
1320            IF( DIRLST(4,I) .LT. 0 )  GOTO  1330
                    I = DIRLST(4,I)
                    GOTO  1320
1330            CORTBL(2,IC) = DIRLST(1,I)
                CORTBL(3,IC) = DIRLST(3,I)
1800    CORFRM = IDSEQ + 1
         CALL  FIND ( CORTBL(2,IC) )
        IF( OP .EQ. 9 )  CALL  DELET ( CORTBL(2,IC+1) )
          IF( CORTBL(5,IC) .EQ. 0 )  GOTO  9000
            CORSEQ = SEQ
            N      = CORTBL(5,IC)
            NMFETC = CORTBL(4,IC)
              DO  2100  I = 1 , N
               CALL  WTPL ( PLTMP )
               CALL  MEMFET
              IF( TYP .LT. 3 )  GOTO  1900
                  AFSEQ = 0
                  IDF    = DIRNUM
                  SYMTB(6,ISY) = DIRNUM
                  ISY = DIRNUM
1900          DIRNUM = IDF
              TYP    = IABS ( TYP )
              IF( OP .EQ. 11 )  GOTO  1950
                  IDSEQ = IDSEQ + 1
                  SEQ   = IDSEQ
                GOTO  2000
1950              AFSEQ = AFSEQ + 1
                  SEQ   = AFSEQ
2000          IF( SHOWFL .NE. 0 )  CALL  DIPRNT( 2 )
2100          CONTINUE
            IF( OP .EQ. 11 )  GOTO  9000
C------ MODIFY DIRLST
            NEXT = DIRLST(4,JDIRLS)
            KDIRLS = KDIRLS + 1
            IF( KDIRLS + 1 .GT. MDIRLS )  CALL  ERROR ( 20 )
            DIRLST(1,KDIRLS) = IDF
            DIRLST(2,KDIRLS) = CORFRM
            DIRLST(3,KDIRLS) = IDSEQ
            DIRLST(4,KDIRLS) = NEXT
            DIRLST(5,KDIRLS) = 0
            OLDTO = DIRLST(3,JDIRLS)
            DIRLST(3,JDIRLS) = CORSEQ
            DIRLST(4,JDIRLS) = KDIRLS
            IF( OLDTO .EQ. CORSEQ )  GOTO  4000
              DIRLST(4,KDIRLS) = KDIRLS + 1
              KDIRLS = KDIRLS + 1
              DIRLST(1,KDIRLS) = DIRLST(1,JDIRLS)
              DIRLST(2,KDIRLS) = CORSEQ + 1
              DIRLST(3,KDIRLS) = OLDTO
              DIRLST(4,KDIRLS) = NEXT
              DIRLST(5,KDIRLS) = 0
4000        CONTINUE
C......... CHANGE JDIRLS
            JDIRLS = KDIRLS
9000    IM = MODLST(2,IM)
        IF( IM .NE. 0 )  GOTO  1200
10000 CONTINUE
C------ COPY REST OF PLIN TO PLTMP
       CALL  FIND ( SEQ0 )
C------ CORRECT SYMTB
      J = 0
      DO  30150  I = 1 , KSYMTB
      K = I
30110   J = J + 1
          DO  30120  JJ = 1 , 6
30120     SYMTB2(JJ,J) = SYMTB(JJ,K)
        SYMTB(7,K) = J
        IF( SYMTB2(6,J) .EQ. 0 )  GOTO  30150
          K = SYMTB2(6,J)
          SYMTB2(6,J) = 0
          GOTO  30110
30150 CONTINUE
        DO  30180  I = 1 , NSYMTB
          DO  30170  II = 1 , 6
30170     SYMTB(II,I) = SYMTB2(II,I)
30180   CONTINUE
      NCORTB = 0
      NMODLS = 0
C------ CORRECT DIRLST
      J = 0
      DO  30270  I = 1 , NSYMTB
      IF( (SYMTB(3,I) .EQ. 0) .OR. (SYMTB(4,I) .EQ. 0) ) GOTO 30270
      K = SYMTB(5,I)
      SYMTB(5,I) = J + 1
30220 J = J + 1
          DO  30230  JJ = 2 , 4
30230     DIRLS2(JJ,J) = DIRLST(JJ,K)
          DIRLS2(5,J)  = 0
      II = DIRLST(1,K)
      DIRLS2(1,J) = SYMTB(7,II)
      IF( DIRLS2(4,J) .LT. 0 )  GOTO  30260
          K = DIRLS2(4,J)
          DIRLS2(4,J) = J + 1
          GOTO  30220
30260 II = IABS( DIRLS2(4,J) )
      DIRLS2(4,J) = -SYMTB(7,II)
30270 CONTINUE
          DO  30290  I = 1 , KDIRLS
              DO 30280  II = 1 , 5
30280         DIRLST(II,I) = DIRLS2(II,I)
30290     CONTINUE
      NDIRLS = KDIRLS
      RETURN
      END
      SUBROUTINE  CORRD
C---
C------ READ AND PREPROCESS CORRECTION INPUT
C---
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /CARD/   CARD(80), JCARD, LINCNT, PRTFLG, ICH
     1               ,IFL(8)  , BKSPFL
      COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
      COMMON /COUNT/  COUNT
      COMMON /CURRDK/ IXSYM , IXDIR , NCDS
      COMMON /CURRID/ IDFL
      COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
     1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
     2              , NCOMDK, NDECK , NIDENT
     3              , MMEM  , NMSTOR, NMFETC
     4              , MCORTB, NCORTB, MMODLS, NMODLS
     5              , LASTDK
      COMMON          SYMTB(7,400)  , DIRLST(5,2000)
     1              , CORTBL(5,1000), MODLST(2,1000)
     2              , MEM(20000)
      COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
     1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
      COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
     9              , WARNFL, SHOWFL
      COMMON /OPTBL/  OPTBL(5,11), NOPTBL, JOP, OPARG
      COMMON /OP/     IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
      COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
     1              , CARD4S(20)
          DIMENSION  REC(22)
              EQUIVALENCE  (DIRNUM, REC(1))
C---
      DIMENSION   NOID(2)
            DATA  NOID/ 4H.NO., 4HID.  /
C---
      KSYMTB = NSYMTB
      NMSTOR = 0
      NCORTB = 0
      NMODLS = 0
      CORDK  = 0
      ICORTB = 0
      DIFL = 0
      IDFL = 0
      NCDS = 0
100    CALL  CARDRD ( 0 )
      IF( OP .NE. 0 )  GOTO  500
200       IF( DIFL .EQ. 0 )  CALL  ERROR ( 22 )
220       NCDS = NCDS + 1
C......... PUT IN MEM
           CALL  MEMSTO
          IF( IDFL .NE. 0 )  SYMTB(4,IDFL) = SYMTB(4,IDFL) + 1
          IF( ICORTB .NE. 0 )  CORTBL(5,ICORTB) = CORTBL(5,ICORTB)+1
          GOTO  100
500   IF( OP .EQ. 99 )  GOTO  90000
      IF( (OP.EQ.1) .OR. ((OP.GE.6).AND.(OP.LE.8)) )  GOTO  520
          IF( IDFL .NE. 0 )  GOTO  520
               CALL  ERROR ( 13 )
              BKSPFL = 1
                  DO  510  I = 1 , 20
510               CARD4S(I) = CARD4(I)
              NPLFLG = 0
              ID1(1) = NOID(1)
              ID1(2) = NOID(2)
              GOTO  1200
520   IF( (OP.NE.9) .AND. (OP.NE.10) .AND.
     1    (OP.NE.2) .AND. (OP.NE.5)  )  DIFL = 0
      CALL  OPGET2
      GOTO  ( 1000, 2000, 3000, 4000, 5000, 6000, 7000, 8000
     1       ,9000,10000,11000 ) , OP
C------ *ID
1000  IF( IDFL .EQ. 0 )  GOTO  1100
          BKSPFL = 1
          DO  1010  I = 1 , 20
1010      CARD4S(I) = CARD4(I)
          GOTO  90000
1100  WRITE( OUTPUT, 1015 ) LINCNT, CARD4
1015  FORMAT( 1X,2H//,I5,1H.,20A4 )
1200   CALL  SYMENT ( 0, SYMERR )
      IF( SYMERR .NE. 0 )  CALL  ERROR ( 99 )
      NIDENT = NIDENT + 1
      IDFL = ISYMTB
      KSYMTB = ISYMTB
C........... TEMPORARILY DELETE ID NAME FROM SYMBOL TABLE
      IDNAM1 = SYMTB(1,IDFL)
      SYMTB(1,IDFL) = 0
      GOTO  100
C------ *CA
2000   CALL  CALINP ( CORDK, ISYM, ERR )
      IF( ERR .NE. 0 )  GOTO  100
      CALFLG = ISYM
      GOTO  220
C------ *DK
3000  CONTINUE
C------ *CD
4000   CALL  ERROR ( 14 )
C------ *WEOF, *RESEQUENCE, *PRECOMPILE, *PARTIAL
5000  GOTO  200
6000  RESEQF = 1
          GOTO  100
7000  PRECOF = 1
          GOTO  100
8000  FULFLG = 0
      GOTO  100
C------ *D
9000  CONTINUE
C------ *I
10000 DIFL = 1
       CALL  SYMSRC ( ID1, ISY1 )
      IF( ISY1 .EQ. 0 )  GOTO  10818
      IF( ND1 .GT. IABS( SYMTB(4,ISY1) ) )  GOTO  10815
      IF( OP .NE. 9 )  GOTO  10200
        IF( ID2(1) .NE. BLNK )  GOTO  10100
          ISY2 = ISY1
          ND2  = ND1
          GOTO  10200
10100    CALL  SYMSRC ( ID2, ISY2 )
        IF( ISY2 .EQ. 0 )  GOTO  10818
        IF( ND2  .GT. IABS( SYMTB(4,ISY2) ) )  GOTO  10815
10200   NCORTB = NCORTB + 1
        IF( NCORTB .GT. MCORTB )  CALL  ERROR ( 16 )
        ICORTB = NCORTB
          CORTBL(1,NCORTB) = OP
          CORTBL(2,NCORTB) = ISY1
          CORTBL(3,NCORTB) = ND1
          CORTBL(4,NCORTB) = NMSTOR + 1
          CORTBL(5,NCORTB) = 0
        IF( OP .NE. 9 )  GOTO  10300
          NCORTB = NCORTB + 1
          IF( NCORTB .GT. MCORTB )  CALL  ERROR ( 16 )
            CORTBL(1,NCORTB) = 0
            CORTBL(2,NCORTB) = ISY2
            CORTBL(3,NCORTB) = ND2
            CORTBL(4,NCORTB) = 0
            CORTBL(5,NCORTB) = 0
10300 CONTINUE
        DO  10310  I = 1 , NDIRLS
        IF( ISY1 .NE. DIRLST(1,I) )  GOTO  10310
        IF( ND1  .LT. DIRLST(2,I) )  GOTO  10310
        IF( OP .EQ. 11 )  GOTO  10320
        IF( ND1  .LE. DIRLST(3,I) )  GOTO  10320
10310   CONTINUE
        GOTO  10815
10320 CONTINUE
C........... SET CORDK = DK TYPE WHERE CORR IS MADE
        DO  10330  II = I , NDIRLS
        IF( DIRLST(4,II) .LT. 0 )  GOTO  10340
10330   CONTINUE
        STOP
10340 IF( OP .NE. 11 )  GOTO  10350
          ISY1 = DIRLST(1,II)
          I    = II
          GOTO  10360
C------- PUT COMPILE FLAG IN SYMTB(4,II)
10350   II = IABS( DIRLST(4,II) )
        SYMTB(4,II) = - IABS( SYMTB(4,II) )
10360   CORDK = SYMTB(3,II)
      NMODLS = NMODLS + 1
      IF( NMODLS .GT. MMODLS )  CALL  ERROR ( 17 )
      MODLST(1,NMODLS) = ICORTB
      MODLST(2,NMODLS) = 0
      IF( DIRLST(5,I) .GT. 0 )  GOTO  10400
          DIRLST(5,I) = NMODLS
          GOTO  10700
C.......... PUT THIS CORRECTION IN SORTED ORDER IN MODLST( , )
10400 MSTART = DIRLST(5,I)
      M      = MSTART
      MOLD   = 0
10440 C = MODLST(1,M)
      IF( ND1 .LT. CORTBL(3,C) )  GOTO  10460
          IF( MODLST(2,M) .EQ. 0 )  GOTO  10450
              MOLD = M
              M    = MODLST(2,M)
              GOTO  10440
10450     MODLST(2,M) = NMODLS
          GOTO  10700
10460 IF( MOLD .NE. 0 )  GOTO  10470
          DIRLST(5,I) = NMODLS
          MODLST(2,NMODLS) = MSTART
          GOTO  10700
10470 MODLST(2,NMODLS) = M
      MODLST(2,MOLD)   = NMODLS
10700 CONTINUE
      GOTO  10900
10818  CALL  ERROR ( 18 )
      GOTO  10900
10815  CALL  ERROR ( 15 )
10900 IF( OP .EQ. 11 )  GOTO  11500
          GOTO  100
C------ *AF
11000 ND1 =999999
      IF( ID2(1) .EQ. BLNK )  GOTO  11300
           CALL  SYMSRC ( ID2, ISY1 )
          IF( ISY1 .EQ. 0 )  GOTO  11818
          GOTO  11400
11300 ISY1 = LASTDK
11400 GOTO  10200
11500  CALL  CREATE ( 0, ERRCRT )
      CORTBL(5,ICORTB) = COUNT
      IF( BKSPFL .NE. 0 )  GOTO  100
      GOTO  90000
11818  CALL  ERROR ( 18 )
      GOTO  11300
C........... RESTORE ID NAME IN SYMBOL TABLE
90000 IF( IDFL .NE. 0 )  SYMTB(1,IDFL) = IDNAM1
      RETURN
      END
      SUBROUTINE  CRAK2 ( IFLD, ER1FLG )
C---
C--- COLLECT A FIELD TERMINATED BY <.>,< >,<,> IGNORING LEADING BLANKS
C---
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /CARD/   CARD(80), JCARD, LINCNT, PRTFLG, ICH
     1               ,IFL(8)  , BKSPFL
      COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
C---
      DIMENSION  IFLD(2)
C---
      IFLD(1) = BLNK
      IFLD(2) = BLNK
      LEADFL = 1
      J      = 0
100   JCARD    = JCARD + 1
      IF( JCARD .GT. 80 )  GOTO 250
        ICH = CARD(JCARD)
        IF( ICH .NE. BLNK )  GOTO 200
          IF( LEADFL .EQ. 0 )  GOTO 300
            GOTO 100
200     LEADFL = 0
        IF((ICH.EQ.COMA).OR.(ICH.EQ.PERD)) GOTO 300
          J = J+1
          IF( J .LT. 9 )  IFL(J) = ICH
          GOTO  100
250   ICH = BLNK
300   IF( J .EQ. 0 )  GOTO  900
      IF( (J .GT. 8) .AND. (ER1FLG .NE. 0) )  GOTO  801
      IF( J .GE. 8 )  GOTO  700
        J1 = J+1
        DO 400  JJ = J1 , 8
400     IFL(JJ) = BLNK
700   CALL  A1A4 ( IFL, IFLD, 2 )
900   RETURN
C------ ERR. FIELD GT 8 CHARS
801       CALL  ERROR ( 1 )
         IFLD(2) = -1
          GOTO  900
      END
      SUBROUTINE  CREATE ( OUTFIL, ERRCRT )
C---
C--- CREATE TEMPORARY NEWPL FROM SOURCE INPUT
C---
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /CARD/   CARD(80), JCARD, LINCNT, PRTFLG, ICH
     1               ,IFL(8)  , BKSPFL
      COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
      COMMON /COUNT/  COUNT
      COMMON /CURRDK/ IXSYM , IXDIR , NCDS
      COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
     1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
     2              , NCOMDK, NDECK , NIDENT
     3              , MMEM  , NMSTOR, NMFETC
     4              , MCORTB, NCORTB, MMODLS, NMODLS
     5              , LASTDK
      COMMON          SYMTB(7,400)  , DIRLST(5,2000)
     1              , CORTBL(5,1000), MODLST(2,1000)
     2              , MEM(20000)
      COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
     1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
      COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
     9              , WARNFL, SHOWFL
      COMMON /OPTBL/  OPTBL(5,11), NOPTBL, JOP, OPARG
      COMMON /OP/     IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
      COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
     1              , CARD4S(20)
          DIMENSION  REC(22)
              EQUIVALENCE  (DIRNUM, REC(1))
C---
C------   PLTMP  = TEMP. NEWPL FILE
C------   LINCNT = INPUT LINE COUNT
C------   NCDS   = NUMBER OF CARDS IN ONE CD OR DK BLOCK
C------   DKFL   = --1 FOR CD, 1 FOR DK, 0 FOR UNDEF
C---
      CRTFIL = OUTFIL
      ERRCRT = 0
      NCDS   = 0
      DKFL   = 0
      IXSYM  = 0
      IXDIR  = 0
      COUNT  = 0
C-
100    CALL  CARDRD ( 1 )
      IF( OP .NE. 0 )  GOTO  500
          OP = 1
200       IF( DKFL .EQ. 0 )  CALL  ERROR ( 3 )
          NCDS = NCDS + 1
          TYP = OP
          DIRNUM = IXSYM
          SEQ = NCDS
           CALL  WTPL ( CRTFIL )
          COUNT = COUNT + 1
          IF(IXSYM .GT. 0)  SYMTB(4,IXSYM) = SYMTB(4,IXSYM)+1
          IF(IXDIR .GT. 0)  DIRLST(3,IXDIR) = DIRLST(3,IXDIR)+1
          GOTO  100
500   IF( OP .EQ. 99 )  GOTO  9000
      IF( (OUTFIL .EQ. 0) .AND. (OP .EQ. 11) )  GOTO  1000
      IF( OP .GT. 7 )  GOTO  8000
      IF( OP .NE. 1 )  CALL  OPGET2
      GOTO (1000, 2000, 3000, 3000, 5000, 6000, 7000) , OP
C------ *ID
1000  BKSPFL = 1
          DO  1010  I = 1 , 20
1010      CARD4S(I) = CARD4(I)
      GOTO  9000
C------ *CA
2000   CALL  CALINP ( DKFL, ISYM, ERR )
      IF( ERR .NE. 0 )  GOTO  100
      CALFLG = ISYM
      GOTO  200
C------ *DK, *CD
3000   CALL  DKCDIN ( DKFL )
      GOTO  200
C------ *WEOF, *RESEQUENCE, *PRECOMPILE
5000  GOTO  200
6000  RESEQF = 1
      GOTO  100
7000  PRECOF = 1
      GOTO  100
C------ BAD UPDATE COMMAND
8000   CALL  ERROR ( 8 )
      ERRCRT = 1
      GOTO  100
9000  RETURN
      END
      SUBROUTINE  DELET ( DNSQ )
C-
C--- WHILE INACTIVATING COPY PLIN TO PLTMP UNTIL DNSQ FOUND
C-
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
     1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
      COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
     9              , WARNFL, SHOWFL
      COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
     1              , CARD4S(20)
          DIMENSION  REC(22)
              EQUIVALENCE  (DIRNUM, REC(1))
C---
      DIMENSION  DNSQ(2)
C---
      DN = DNSQ(1)
      SQ = DNSQ(2)
100   TYP = -IABS ( TYP )
      IF( SHOWFL .NE. 0 )  CALL  DIPRNT( 1 )
      IF( SQ .NE. SEQ )  GOTO  200
      IF( DN .EQ. DIRNUM )  GOTO  900
200    CALL  WTPL ( PLTMP )
       CALL  RDPLIN
      GOTO  100
900   RETURN
      END
      SUBROUTINE  DIPRNT ( IDI )
C---
C--- PRINT DELETED AND INSERTED LINES
C---     IDI =-1 PRINT HEADING,  =0 PRINT SPACE
C---         =1  PRINT DELETED LINE, =2 PRINT INSERTED LINE
C---
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
      COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
     1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
     2              , NCOMDK, NDECK , NIDENT
     3              , MMEM  , NMSTOR, NMFETC
     4              , MCORTB, NCORTB, MMODLS, NMODLS
     5              , LASTDK
      COMMON          SYMTB(7,400)  , DIRLST(5,2000)
     1              , CORTBL(5,1000), MODLST(2,1000)
     2              , MEM(20000)
      COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
     1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
      COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
     1              , CARD4S(20)
          DIMENSION  REC(22)
              EQUIVALENCE  (DIRNUM, REC(1))
C---
      DIMENSION  DI(2)
          DATA  DI/2HD , 2H I/
C---
      IF( IDI .LE. 0 )  GOTO  500
          IF( IABS( TYP ) .GT. 2 )  GOTO  450
          IF( CALFLG .GT. 0 )  GOTO  400
                  DO  302  I = 1 , 20
                  I2 = 21 - I
                  IF( CARD4(I2) .NE. BLNK )  GOTO  304
302               CONTINUE
304               CONTINUE
              WRITE(OUTPUT,101)  DI(IDI), SYMTB(1,DIRNUM)
     .                         , SYMTB(2,DIRNUM), SEQ
     .                         , (CARD4(I), I=1,I2)
C ..101           FORMAT( 1X , A2, 3H ( , 2A4, I4,3H )  20A4 )     8-11-86
101           FORMAT( 1X , A2, 3H ( , 2A4, I4,3H ) , 20A4 )
              RETURN
400       WRITE(OUTPUT,102)  DI(IDI), SYMTB(1,DIRNUM), SYMTB(2,DIRNUM)
     .                     , SEQ, SYMTB(1,CALFLG), SYMTB(2,CALFLG)
102       FORMAT( 1X, A2, 3H ( , 2A4, I4,7H ) *CA , 2A4 )
          RETURN
450       IF( IABS( TYP ) .EQ. 3 )
     .      WRITE(OUTPUT,103)  DI(IDI), SYMTB(1,DIRNUM), SYMTB(2,DIRNUM)
     .                       , SEQ, SYMTB(1,DIRNUM), SYMTB(2,DIRNUM)
103         FORMAT( 1X, A2, 3H ( , 2A4, I4,9H ) *DECK , 2A4 )
          IF( IABS( TYP ) .EQ. 4 )
     .      WRITE(OUTPUT,104)  DI(IDI), SYMTB(1,DIRNUM), SYMTB(2,DIRNUM)
     .                       , SEQ, SYMTB(1,DIRNUM), SYMTB(2,DIRNUM)
104         FORMAT( 1X, A2, 3H ( , 2A4, I4,12H ) *COMDECK , 2A4 )
            RETURN
500   IF( IDI .NE. 0 )  GOTO  600
          WRITE(OUTPUT,105)
105       FORMAT( 1X )
          RETURN
600       WRITE(OUTPUT,106)
106       FORMAT( //, 28H U P D A T E   MODIFICATIONS  )
          RETURN
      END
      SUBROUTINE  DKCDIN ( DKFL )
C-
C--- PROCESS *DK, *CD INPUT
C-
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /CARD/   CARD(80), JCARD, LINCNT, PRTFLG, ICH
     1               ,IFL(8)  , BKSPFL
      COMMON /CURRDK/ IXSYM , IXDIR , NCDS
      COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
     1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
     2              , NCOMDK, NDECK , NIDENT
     3              , MMEM  , NMSTOR, NMFETC
     4              , MCORTB, NCORTB, MMODLS, NMODLS
     5              , LASTDK
      COMMON          SYMTB(7,400)  , DIRLST(5,2000)
     1              , CORTBL(5,1000), MODLST(2,1000)
     2              , MEM(20000)
      COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
     1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
      COMMON /OP/     IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
C---
      IF( OP .EQ. 4 )  GOTO  1000
C------ *DK
      DKFL = 1
      NDECK = NDECK + 1
      GOTO  1200
C------ *CD
1000  DKFL = -1
      NCOMDK = NCOMDK + 1
C------ *DK, *CD
1200  NCDS = 0
       CALL  SYMENT ( DKFL, SYMERR )
      IXSYM = ISYMTB
      NDIRLS = NDIRLS + 1
      IF( NDIRLS .GT. MDIRLS )  CALL  ERROR ( 20 )
      IXDIR  = NDIRLS
      SYMTB(4,IXSYM) = 0
      SYMTB(5,IXSYM) = NDIRLS
      DIRLST(1,IXDIR) = IXSYM
      DIRLST(2,IXDIR) = 1
      DIRLST(3,IXDIR) = 0
      DIRLST(4,NDIRLS) = -IXSYM
      DIRLST(5,NDIRLS) = 0
      RETURN
      END
      SUBROUTINE  ERROR ( I )
C
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> COMPILER DEPENDENT
C---
C--- PRINT ERROR MESSAGES
C---
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
     9              , WARNFL, SHOWFL
      DIMENSION  XXXXXX(4)
      DATA       IXXXXX/200000/
C---
      IF( I .EQ. 99 )  GOTO  8000
      GOTO ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15
     1     ,16, 17, 18, 19, 20, 21, 22, 23, 24, 25), I
1     WRITE(6,101)
101   FORMAT(13H -E R R O R--,30HFIELD LONGER THAN 8 CHARACTERS)
      GOTO  9000
2     WRITE(6,102)
102   FORMAT(13H -E R R O R--,16HBAD NUMBER FIELD)
      GOTO  9000
3     WRITE(6,103)
103   FORMAT(13H -E R R O R--,25H*DECK OR *COMDECK MISSING )
      GOTO  8000
4     WRITE(6,104)
104   FORMAT(13H -E R R O R--,28HPERIOD MISSING BEFORE NUMBER)
      GOTO  9000
5     WRITE(6,105)
105   FORMAT(13H -E R R O R--,17HNUMBER IS MISSING)
      GOTO  9000
6     WRITE(6,106)
106   FORMAT(13H -E R R O R--,18HNAME IS NOT UNIQUE)
      GOTO  9000
7     WRITE(6,107)
107   FORMAT(13H -E R R O R--,12HNAME MISSING)
      GOTO  9000
8     WRITE(6,108)
108   FORMAT(13H -E R R O R--,25HTHIS UPDATE DIRECTIVE NOT
     1           ,33H ALLOWED IN CREATION OR AFTER *AF)
      GOTO  9000
9     WRITE(6,109)
109   FORMAT(13H -E R R O R--,30HCAN*T CALL FROM WITHIN COMDECK)
      GOTO  9000
10    WRITE(6,110)
110   FORMAT(13H -E R R O R--,17HCOMDECK NOT FOUND)
      GOTO  9000
11    WRITE(6,111)
111   FORMAT(13H -E R R O R--,17HCAN*T CALL A DECK)
      GOTO  9000
12    WRITE(6,112)
112   FORMAT(13H -E R R O R--,23HCOMDECK BUFFER EXCEEDED /
     1                   ,13X,26HINCREASE // MEM(.), MMSTOR  )
      GOTO  8000
13    WRITE(6,113)
113   FORMAT(13H --WARNING---,14H*IDENT MISSING)
      GOTO  7000
14    WRITE(6,114)
114   FORMAT(13H -E R R O R--,26H*DK, *CD MUST BE AFTER *AF)
      GOTO  8000
15    WRITE(6,115)
115   FORMAT(13H -E R R O R--,16HNUMBER INCORRECT)
      GOTO  9000
16    WRITE(6,116)
116   FORMAT(13H -E R R O R--,28HCORRECTION CAPACITY EXCEEDED /
     1                   ,13X,31HINCREASE // CORTBL(5,.), MCORTB)
      GOTO  8000
17    WRITE(6,117)
117   FORMAT(13H -E R R O R--,28HCORRECTION CAPACITY EXCEEDED /
     1                   ,13X,31HINCREASE // MODLST(2,.), MMODLS)
      GOTO  8000
18    WRITE(6,118)
118   FORMAT(13H -E R R O R--,25HDECK OR COMDECK NOT FOUND)
      GOTO  9000
19    WRITE(6,119)
119   FORMAT(13H -E R R O R--,28HCORRECTION CAPACITY EXCEEDED /
     1                   ,13X,26HINCREASE // MEM(.), MMSTOR  )
      GOTO  8000
20    WRITE(6,120)
120   FORMAT(13H -E R R O R--,28HCORRECTION CAPACITY EXCEEDED /
     1                   ,13X,31HINCREASE // DIRLST(5,.), MDIRLS )
      GOTO  8000
21    WRITE(6,121)
121   FORMAT(13H -E R R O R--,28HOVERLAPPING CORRECTION FOUND )
      GOTO  8000
22    WRITE(6,122)
122   FORMAT(13H -E R R O R--,19H*D, *I, *AF MISSING)
      GOTO  9000
23    WRITE(6,123)
123   FORMAT(13H -E R R O R--,17HCOMDECK NOT FOUND)
      GOTO  9000
24    WRITE(6,124)
124   FORMAT(13H -E R R O R--)
      RETURN
25    WRITE(6,125)
125   FORMAT(13H -E R R O R--)
      RETURN
7000  WARNFL = 1
      RETURN
8000  WRITE( 6, 1003 )
1003  FORMAT( 18H ? *** ABORTED *** )
C>>>>>>>>> *ABORT* <<<<<<<<<<
C...  TYPE  1003                                                 8-11-86
      PRINT 1003
      I = XXXXXX(IXXXXX)
9000  ERRFLG = 1
      RETURN
      END
      SUBROUTINE  FIND ( DNSQ )
C-
C--- COPY PLIN TO PLTMP UNTIL DNSQ FOUND
C-
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
     1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
     2              , NCOMDK, NDECK , NIDENT
     3              , MMEM  , NMSTOR, NMFETC
     4              , MCORTB, NCORTB, MMODLS, NMODLS
     5              , LASTDK
      COMMON          SYMTB(7,400)  , DIRLST(5,2000)
     1              , CORTBL(5,1000), MODLST(2,1000)
     2              , MEM(20000)
      COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
     1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
      COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
     1              , CARD4S(20)
          DIMENSION  REC(22)
              EQUIVALENCE  (DIRNUM, REC(1))
C---
      DIMENSION  DNSQ(2)
C---
      DN = DNSQ(1)
      SQ = DNSQ(2)
      DIRNUX = DIRNUM
      SEQX   = SEQ
100   IF( SQ .NE. SEQ )  GOTO  200
      IF( DN .EQ. DIRNUM )  GOTO  900
200    CALL  WTPL ( PLTMP )
       CALL  RDPLIN
      IF( SEQ .NE. 0 )  GOTO  100
        IF( SQ .NE. 0 )  WRITE( OUTPUT, 101 )  SYMTB(1,DIRNUX),
     1                                         SYMTB(2,DIRNUX), SEQX
     2                                  ,  SYMTB(1,DN), SYMTB(2,DN), SQ
101     FORMAT( 28H ------------- NOW AT LINE= , 2A4, I4,
     1                22H    LOOKING FOR LINE= , 2A4, I4 )
        IF( SQ .NE. 0 )  CALL  ERROR ( 21 )
900   RETURN
      END
      FUNCTION ISRCH(KEY,KEYLST,NKEY,NDIM)
C
C              SEARCH KEYLST(NDIM,NKEY) FOR KEY(NDIM)
C
      DIMENSION KEY(1), KEYLST(1)
C
C              SET TOP AND BOTTOM OF RANGE
      ITOP   = NKEY
      IBOT   = 0
      ISRCH  = 0
C              PRINT 902, (KEY(I),I=1,4)
C              902 FORMAT(*  LOOKING FOR *4A4)
C              DIVIDE SEARCH RANGE IN TWO
    5 IHLF   = (ITOP+IBOT)/2
C              PRINT 901,ITOP,IBOT,IHLF
C              901 FORMAT(1H ,*ITOP = *I4*  IBOT = *I4*  IHLF = *I4)
C              PRINT 903, (KEYLST(I+(IHLF-1)*NDIM),I=1,4)
C              903 FORMAT(*  COMPARING WITH *4A4)
C              COMPARE KEY(I) WITH KEYLST(I,IHLF)
      DO 10 I=1,NDIM
      I1     = I + (IHLF-1)*NDIM
      IF( KEY(I) .GT. KEYLST(I1) )  GOTO 40
      IF( KEY(I) .LT. KEYLST(I1) )  GOTO 60
   10 CONTINUE
C              EQUAL.  SET ISRCH AND RETURN
      ISRCH  = IHLF
      GO TO 100
C              KEY IS IN TOP HALF.  CHECK FOR NOT FOUND
   40 CONTINUE
      IF (ITOP .EQ. IBOT)  GO TO 100
C              RESET IBOT AND KEEP GOING
      IBOT   = IHLF + 1
      GO TO 5
C              KEY IS IN BOTTOM HALF.  CHECK FOR NOT FOUND
   60 CONTINUE
      IF (ITOP .EQ. IBOT)  GO TO 100
C              RESET ITOP AND KEEP GOING
      ITOP   = IHLF
      GO TO 5
  100 CONTINUE
      RETURN
      END
      SUBROUTINE  MEMFET
C-
C--- FETCH A CARD FROM MEM TO REC ARRAY
C-
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
     1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
     2              , NCOMDK, NDECK , NIDENT
     3              , MMEM  , NMSTOR, NMFETC
     4              , MCORTB, NCORTB, MMODLS, NMODLS
     5              , LASTDK
      COMMON          SYMTB(7,400)  , DIRLST(5,2000)
     1              , CORTBL(5,1000), MODLST(2,1000)
     2              , MEM(20000)
      COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
     1              , CARD4S(20)
          DIMENSION  REC(22)
              EQUIVALENCE  (DIRNUM, REC(1))
C---
      CALFLG = 0
      TYP = MEM(NMFETC)
      IF( TYP .NE. 1 )  GOTO  330
          DO  320  I = 1 , 20
          IM = NMFETC + I
320       REC(I+2) = MEM(IM)
          NMFETC = NMFETC + 21
          GOTO  900
330   IF( TYP .NE. 2 )  GOTO  340
          CALFLG = MEM(NMFETC+1)
          NMFETC = NMFETC + 2
          GOTO  900
340     DIRNUM=MEM(NMFETC+1)
        NMFETC = NMFETC + 2
900   RETURN
      END
      SUBROUTINE  MEMSTO
C-
C--- STORE CORRECTION CARDS IN MEMORY
C-
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
     1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
     2              , NCOMDK, NDECK , NIDENT
     3              , MMEM  , NMSTOR, NMFETC
     4              , MCORTB, NCORTB, MMODLS, NMODLS
     5              , LASTDK
      COMMON          SYMTB(7,400)  , DIRLST(5,2000)
     1              , CORTBL(5,1000), MODLST(2,1000)
     2              , MEM(20000)
      COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
     1              , CARD4S(20)
          DIMENSION  REC(22)
              EQUIVALENCE  (DIRNUM, REC(1))
C---
          IF( NMSTOR+21 .GT. MMEM )  CALL  ERROR ( 19 )
          MEM(NMSTOR+1) = TYP
      IF( TYP .NE. 1 ) GOTO  330
            DO  320  I = 1 , 20
            IM = NMSTOR + I
            MEM(IM+1) = CARD4(I)
320         CONTINUE
            NMSTOR = NMSTOR + 21
                GOTO  390
330   IF( TYP .NE. 2 )  GOTO  340
            MEM(NMSTOR+2) = CALFLG
            NMSTOR = NMSTOR+2
                GOTO  390
340         MEM(NMSTOR+2) = DIRNUM
            NMSTOR = NMSTOR + 2
390   RETURN
      END
      SUBROUTINE  NUMCOL ( NUM )
C---
C--- COLLECT NUMBER FIELD TERMINATED BY <,>,< >
C---
      IMPLICIT INTEGER (A-Z)
      COMMON /CARD/   CARD(80), JCARD, LINCNT, PRTFLG, ICH
     1               ,IFL(8)  , BKSPFL
      COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
C---
      DIMENSION  N09(10)
C---
      DATA  N09/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
C---
      NUM    = 0
      IF( (JCARD.GE.80).OR.(ICH.NE.PERD))  GOTO 800
100   JCARD = JCARD + 1
      IF( JCARD .GT. 80 )  GOTO 250
        ICH = CARD(JCARD)
        IF( (ICH.EQ.BLNK).OR.(ICH.EQ.COMA) )  GOTO 300
C------ CK IF NUMBER
            DO  220  I = 1 , 10
            IF( ICH .EQ. N09(I) )  GOTO  230
220         CONTINUE
           CALL  ERROR ( 2 )
          GOTO  900
230     NUM = 10*NUM + I-1
        GOTO  100
250   ICH = BLNK
300   CONTINUE
C------ GIVE ERROR MSG IF NUMBER IS MISSING
      IF( NUM .EQ. 0 )  CALL  ERROR ( 5 )
      RETURN
C------ PERIOD MISSING BEFORE NUMBER
800   CALL  ERROR ( 4 )
900   RETURN
      END
      SUBROUTINE  OPGET
C---
C--- SCAN OP FIELD AND GET OP NUMBER
C---
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /CARD/   CARD(80), JCARD, LINCNT, PRTFLG, ICH
     1               ,IFL(8)  , BKSPFL
      COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
      COMMON /OPTBL/  OPTBL(5,11), NOPTBL, JOP, OPARG
      COMMON /OP/     IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
C---
      DIMENSION  IFLD(2)
C---
      JCARD = 1
       CALL  CRAK2 ( IFLD, 0 )
      OP = 0
      IF( IFLD(1) .EQ. BLNK )  GOTO  900
        DO  200  I = 1 , NOPTBL
        IF( (IFLD(1).EQ.OPTBL(1,I)).OR.
     1      (IFLD(1).EQ.OPTBL(2,I)) )  GOTO  300
200     CONTINUE
      GOTO  900
300   OP = OPTBL(4,I)
      OPARG = OPTBL(5,I)
      JOP = I
900   RETURN
      END
      SUBROUTINE  OPGET2
C---
C--- GET THE TWO OPERANDS OF UPDATE COMMAND
C---
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /CARD/   CARD(80), JCARD, LINCNT, PRTFLG, ICH
     1               ,IFL(8)  , BKSPFL
      COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
      COMMON /OPTBL/  OPTBL(5,11), NOPTBL, JOP, OPARG
      COMMON /OP/     IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
C---
      DIMENSION  N09(10)
C---
      DATA  N09/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
C---
      IF( OPARG .EQ. 0 )  GOTO 900
      IOPARG = IABS(OPARG)
      SOPARG = OPARG / IOPARG
       CALL CRAK2 ( ID1, 1 )
      IF( SOPARG .LT. 0 )  CALL  NUMCOL ( ND1 )
      IF( IOPARG .EQ. 1 )  GOTO  600
        IF( ICH .NE. COMA )  GOTO  600
           CALL  CRAK2 ( ID2, 1 )
          IF( SOPARG .GE. 0 )  GOTO  900
              DO  300  I = 1 , 10
              IF( IFL(1) .EQ. N09(I) )  GOTO  400
300           CONTINUE
            GOTO  500
400             DO  420  I = 1 , 8
                CARD(I+71) = IFL(I)
420             CONTINUE
              CARD(80) = BLNK
              JCARD = 71
              ICH   = PERD
              ID2(1) = ID1(1)
              ID2(2) = ID1(2)
500          CALL  NUMCOL ( ND2 )
          GOTO  900
600   ID2(1) = BLNK
      ND2 = -1
900   RETURN
      END
      SUBROUTINE  OPLRD
C---
C--- READ OLDPL DIRECTORY
C---
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
     1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
     2              , NCOMDK, NDECK , NIDENT
     3              , MMEM  , NMSTOR, NMFETC
     4              , MCORTB, NCORTB, MMODLS, NMODLS
     5              , LASTDK
      COMMON          SYMTB(7,400)  , DIRLST(5,2000)
     1              , CORTBL(5,1000), MODLST(2,1000)
     2              , MEM(20000)
      COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
     1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
C---
      READ(OLDPL ,1010) NCOMDK, NDECK, NIDENT, NDIRLS
1010  FORMAT( 3X,I4,3X,I4,3X,I4,3X,I4 )
      NSYMTB = NCOMDK + NDECK + NIDENT
      READ(OLDPL ,1007)  ((SYMTB(I,J),  I=1,5), J=1,NSYMTB)
1007  FORMAT( 1X,2A4,I2,I5,I4, 1X,2A4,I2,I5,I4, 1X,2A4,I2,I5,I4,
     1        1X,2A4,I2,I5,I4 )
      READ(OLDPL ,1008)  ((DIRLST(I,J), I=1,3), J=1,NDIRLS)
1008  FORMAT( I4,2I5, I4,2I5, I4,2I5, I4,2I5, I4,2I5 )
C------
        DO  100  I = 1 , NSYMTB
        IF( IABS( SYMTB(3,I) ) .EQ. 1 )  LASTDK = I
        SYMTB(6,I) = 0
        SYMTB(7,I) = I
100     CONTINUE
C------ FILL THE BACK POINTER IN DIRLST
        DO  200  I = 1 , NDIRLS
        DIRLST(4,I) = 0
        DIRLST(5,I) = 0
200     CONTINUE
      IF( NSYMTB .LT. 2 )  GOTO  350
        DO  300  I = 2 , NSYMTB
        J = SYMTB(5,I)
        DIRLST(4,J-1) = -(I-1)
300     CONTINUE
350   DIRLST(4,NDIRLS) = - LASTDK
C------ FILL NEXT ENTRIES IN DIRLST
        DO  400  I = 1 , NDIRLS
        IF( DIRLST(4,I) .EQ. 0 )  DIRLST(4,I) = I+1
400     CONTINUE
C------
      RETURN
      END
      SUBROUTINE PRECMP(REC,LINE1,LINE2,NL)
C
C              PRGEDT EDITS SOURCE FILES, REPLACING NAMES WITHIN<> WITH A
C              POSITION IN THE LINE.
C
C              IA CONTAINS THE INPUT LINE
C              IB CONTAINS THE OUTPUT LINE
C              ID SAVES COLUMNS 73-90 OF IA
C              ICA STORES THE PRESENT POSITION IN IA
C              ICB STORES THE PRESENT POSITION IN IB
C
      IMPLICIT INTEGER (A-Z)
C
      COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
     1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
      COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
     9              , WARNFL, SHOWFL
C
      DIMENSION NAME(2),REC(20),LINE1(20),LINE2(20),CARD(80)
      DIMENSION IA(80), IB(144), INAM(4,1500), ITXT(4,1500),
     1          KEY(16), KEY4(4), IREPL(16), ID( 8), IB2(72), IREPL2(20)
C
      EQUIVALENCE (IA(1), CARD(1)), (IB2(1), IB(1))
C
      DATA NENTS/0/
      DATA ITERMB, ITERME, ICMNT, ICNTNU, IBLNK /
     1 1H<, 1H>, 1HC, 1H., 1H /
      DATA IHI, IAT, IRP / 1HI, 1H@, 1H) /
      DATA IREPL2(2), IREPL2(3), IREPL2(4)
     1 / 1HA, 1H(, 1HI /
C
C
           IF (   NENTS     .GT.       0)                   GO TO    1
C
C     I N I T I A L I Z A T I O N
C
         IERR =       0
       REWIND       EDTT
C              INITIALIZE START OF OVERFLOW LINE
      DO 5 I = 73,77
    5 IB(I)  = IBLNK
      IB(78) = ICNTNU
C              READ IN EDIT TABLE
      READ(EDTT, END=90000)  NENTS, ((INAM(I,J), I=1,4), J=1,NENTS),
     1                  ((ITXT(I,J),I=1,4),J=1,NENTS)
       REWIND       EDTT
C
    1 CONTINUE
      LINE1(19) = IBLNK
      LINE1(20) = IBLNK
      LINE2(19) = IBLNK
      LINE2(20) = IBLNK
      CALL A4A1(REC,CARD,20)
      IF(IA(1) .NE. ICMNT)  GOTO 3
      NL = 1
      DO 4 I=1,20
    4 LINE1(I) = REC(I)
      RETURN
    3       J =       0
      DO  2 I =  73, 80
            J =   J + 1
        ID(J) =   IA(I)
    2          CONTINUE
C
C              LOOP THROUGH IA LOOKING FOR <
   20 ICA    = 0
      ICB    = 0
C              BLANK OUT IB
      DO 25 I=1,72
   25 IB(I)  = IBLNK
      DO 26 I=79,144
   26 IB(I)  = IBLNK
   30 ICA    = ICA + 1
      IF (ICA .EQ. 73)  GO TO 100
      IF (IA(ICA) .EQ.ITERMB)  GO TO 200
C              DID NOT FIND <  --- SET IB = IA
      ICB    = ICB + 1
C              CHECK FOR OVERFLOW
      IF (ICB .EQ. 73)  ICB = ICB + 6
      IB(ICB) = IA(ICA)
      GO TO 30
C              END OF LINE.  CHECK FOR NUM OF LINES AND RETURN
C
  100 NL = 1
      DO 111 I=79,144
      IF(IB(I) .NE. IBLNK) NL = 2
  111 CONTINUE
      CALL A1A4(IB,LINE1,18)
      IF(NL .EQ. 2)  CALL A1A4(IB(73),LINE2,18)
      RETURN
C
C              FOUND <.  LOOP THROUGH IA LOOKING FOR >
  200 KYC    = 0
      IATFLG = 0
C              CHECK FOR AT SIGN
      IF (IA(ICA+1) .NE. IAT)  GO TO 210
      ICA    = ICA + 1
      IATFLG = 1
  210 ICA    = ICA + 1
      KYC    = KYC + 1
C              IF ICA GREATER THAN 72 --- ERROR
      IF (ICA .GT. 72)  GO TO 700
C              IF KYC GREATER THAN 16 --- ERROR
      IF (IA(ICA) .EQ. ITERME)  GO TO 220
      IF (KYC .GT. 16)  GO TO 710
C              SET KEY
      KEY(KYC) = IA(ICA)
      GO TO 210
  220 CONTINUE
C              FOUND > .  ZERO OUT REST OF KEY
      IF(KYC .GT. 16)  GOTO 2002
      DO 225 I=KYC,16
225   KEY(I) = IBLNK
 2002 CONTINUE
C              ENCODE KEY ONTO KEY4 USING A4 FORMAT
      CALL A1A4(KEY,KEY4,4)
C              SEARCH FOR KEY4 IN INAM
      IX     = ISRCH(KEY4,INAM,NENTS,4)
C              COULD NOT FIND --- ERROR
      IF (IX .EQ. 0)  GO TO 720
C              MOVE THE REPLACEMENT TEXT INTO IREPL IN A1 FORMAT
      CALL A4A1(ITXT(1,IX),IREPL,4)
C              CHECK FOR AT SIGN
      IF (IATFLG .EQ. 0)  GO TO 229
C              THERE WAS AN AT SIGN.  FILL IREPL2
      IREPL2(1) = IREPL(1)
      DO 226 I=2,14
  226 IREPL2(I+3) = IREPL(I)
C              MOVE IREPL2 INTO IB, LEAVING OFF TRAILING ZEROS
      DO 227 I=1,18
      IF( IREPL2(I) .EQ. IBLNK )  GOTO 228
      ICB    = ICB + 1
      IF (ICB .EQ. 73)  ICB = ICB + 6
  227 IB(ICB) = IREPL2(I)
      GO TO 30
  228 ICB    = ICB + 1
      IF (ICB .EQ. 73) ICB = ICB + 6
      IB(ICB) = IRP
      GO TO 30
  229 CONTINUE
C              MOVE IREPL INTO IB, LEAVING OFF THE TRAILING ZEROS
      DO 230 I=1,14
      IF( IREPL(I) .EQ. IBLNK )  GOTO 30
      ICB    = ICB + 1
      IF (ICB .EQ. 73)  ICB = ICB + 6
  230 IB(ICB) = IREPL(I)
C              CONTINUE LOOPING THROUGH IA
      GO TO 30
C              ERROR PROCESSING
  700 CONTINUE
 1001  FORMAT (    80A1)
        WRITE (  OUTPUT,     701)      IA
  701 FORMAT(1H ,46HERROR --- FOUND END OF LINE BEFORE>.  THE LINE
     1, 9H WAS ---  /1H ,90A1/)
      IERR   = 1
      WRITE (OUTPUT,1001) IA
      GO TO 10
  710 CONTINUE
        WRITE (  OUTPUT,     711)     KEY,      IA
  711 FORMAT(1H ,52HERROR --- NAME WITHIN <> GREATER THAN 16 CHARACTERS.
     1,14HTHE NAME IS -  ,16A1,16H  THE LINE IS -  /1H ,90A1/)
      IERR   = 1
      WRITE (OUTPUT,1001) IA
      GO TO 10
  720 CONTINUE
        WRITE (  OUTPUT,     721)     KEY,      IA
  721 FORMAT(1H ,41HERROR --- NAME NOT FOUND IN EDIT TABLE.  
     1,14HTHE NAME IS -  ,16A1,16H  THE LINE IS -  /1H ,90A1/)
      IERR   = 1
      ICABS  = ICA - KYC - IATFLG
      DO 724 I=ICABS,ICA
      ICB    = ICB + 1
      IF (ICB .EQ. 73)  ICB = ICB + 6
      IB(ICB) = IA(I)
  724 CONTINUE
      GO TO 30
90000 WRITE(OUTPUT,90001)
90001 FORMAT( 40H ***ERROR*** (UPDATE)  FILE EDTT MISSING )
      PRECOF = 0
   10  RETURN
      END
      SUBROUTINE  RDPLIN
C
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>  COMPILER DEPENDENT
C-
C--- READ ONE LINE FROM PLIN
C-
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
     1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
     2              , NCOMDK, NDECK , NIDENT
     3              , MMEM  , NMSTOR, NMFETC
     4              , MCORTB, NCORTB, MMODLS, NMODLS
     5              , LASTDK
      COMMON          SYMTB(7,400)  , DIRLST(5,2000)
     1              , CORTBL(5,1000), MODLST(2,1000)
     2              , MEM(20000)
      COMMON /DKFLG/  DKFLG
      COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
     1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
      COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
     1              , CARD4S(20)
          DIMENSION  REC(22)
              EQUIVALENCE  (DIRNUM, REC(1))
C---
C>>>>>>>>> *EOF* <<<<<<<<<
      READ( PLIN, 1009, END=800 )  TYP, REC
1009  FORMAT( I2,I4,I5,1X,20A4 )
      DIRNUM = SYMTB(7,DIRNUM)
      IF( TYP .EQ. 3 )  DKFLG = DIRNUM
      CALFLG = 0
      IF( IABS( TYP ) .NE. 2 )  GOTO  900
          READ( PLIN, 1014 )  CALFLG
1014  FORMAT( 4X,I4 )
          CALFLG = SYMTB(7,CALFLG)
          IF( DKFLG .EQ. 0 )  GOTO  900
            IF( SYMTB(4,CALFLG) .LT. 0 )
     1              SYMTB(4,DKFLG) = - IABS( SYMTB(4,DKFLG) )
900   RETURN
800   SEQ = 0
      GOTO  900
      END
      SUBROUTINE  RESEQ
C---
C------ RESEQUENCE (PLIN) INTO (PLTMP)
C---
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
     1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
     2              , NCOMDK, NDECK , NIDENT
     3              , MMEM  , NMSTOR, NMFETC
     4              , MCORTB, NCORTB, MMODLS, NMODLS
     5              , LASTDK
      COMMON          SYMTB(7,400)  , DIRLST(5,2000)
     1              , CORTBL(5,1000), MODLST(2,1000)
     2              , MEM(20000)
      COMMON /DKFLG/  DKFLG
      COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
     1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
      COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
     1              , CARD4S(20)
          DIMENSION  REC(22)
              EQUIVALENCE  (DIRNUM, REC(1))
C---
C------ DISABLE COMPILE FLAG SETTING PART IN RDPLIN
      DKFLG = 0
      NDIRLS = 0
200    CALL  RDPLIN
      IF( SEQ .EQ. 0 )  GOTO  900
        ITYP = IABS ( TYP )
        GOTO ( 12, 12, 34, 34 ), ITYP
C------ *CA, DATA
12      IF( TYP .LT. 0 )  GOTO  200
300         NEWSEQ = NEWSEQ + 1
            SEQ    = NEWSEQ
            SYMTB(4,JSYMTB) = NEWSEQ
            DIRLST(3,NDIRLS) = NEWSEQ
            DIRNUM = JSYMTB
             CALL  WTPL ( PLTMP )
            GOTO  200
C------ *CD, *DK
34      NEWSEQ = 0
        JSYMTB = DIRNUM
        NDIRLS = NDIRLS + 1
        DIRLST(1,NDIRLS) = JSYMTB
        DIRLST(2,NDIRLS) = 1
        DIRLST(3,NDIRLS) = 1
        DIRLST(4,NDIRLS) = -JSYMTB
        GOTO  300
C------ EOF ON PLIN
900   NSYMTB = JSYMTB
      DO  920  I = 1 , NSYMTB
      SYMTB(7,I) = I
920   CONTINUE
      RETURN
      END
      SUBROUTINE  SYMENT ( SYMTYP, SYMERR )
C---
C--- ENTER SYMBOL IN SYMBOL TABLE
C---
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
      COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
     1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
     2              , NCOMDK, NDECK , NIDENT
     3              , MMEM  , NMSTOR, NMFETC
     4              , MCORTB, NCORTB, MMODLS, NMODLS
     5              , LASTDK
      COMMON          SYMTB(7,400)  , DIRLST(5,2000)
     1              , CORTBL(5,1000), MODLST(2,1000)
     2              , MEM(20000)
      COMMON /OP/     IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
C---
      SYMERR = 0
      IF( ID1(2) .EQ. -1 )  GOTO  850
      IF( ID1(1) .EQ. BLNK )  GOTO  8007
C------ SEARCH SYMBOL TABLE
      IF( NSYMTB .EQ. 0 )  GOTO  300
          DO  200  I = 1 , NSYMTB
          IF( ID1(1) .NE. SYMTB(1,I) )  GOTO  200
          IF( ID1(2) .EQ. SYMTB(2,I) )  GOTO  8006
200       CONTINUE
300   NSYMTB = NSYMTB + 1
      ISYMTB = NSYMTB
      SYMTB(1,NSYMTB) = ID1(1)
      SYMTB(2,NSYMTB) = ID1(2)
      SYMTB(3,NSYMTB) = SYMTYP
      SYMTB(4,NSYMTB) = 0
      SYMTB(5,NSYMTB) = 0
      SYMTB(6,NSYMTB) = 0
      SYMTB(7,NSYMTB) = NSYMTB
      GOTO  900
C------ NAME IS NOT UNIQUE
8006   CALL  ERROR ( 6 )
      SYMERR = 1
      GOTO  880
C------ NAME MISSING
8007   CALL  ERROR ( 7 )
850   SYMERR = 2
880   ISYMTB = 0
900   RETURN
      END
      SUBROUTINE  SYMSRC ( SYM, ISYM )
C---
C--- SEARCH SYMBOL TABLE FOR SYM(1-2)
C---
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
     1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
     2              , NCOMDK, NDECK , NIDENT
     3              , MMEM  , NMSTOR, NMFETC
     4              , MCORTB, NCORTB, MMODLS, NMODLS
     5              , LASTDK
      COMMON          SYMTB(7,400)  , DIRLST(5,2000)
     1              , CORTBL(5,1000), MODLST(2,1000)
     2              , MEM(20000)
C---
      DIMENSION  SYM(2)
C---
      IF( NSYMTB .EQ. 0 )  GOTO  800
          DO  200  I = 1 , NSYMTB
          IF( SYM(1) .NE. SYMTB(1,I) )  GOTO  200
          IF( SYM(2) .EQ. SYMTB(2,I) )  GOTO  400
200       CONTINUE
800     I = 0
400   ISYM = I
      RETURN
      END
      SUBROUTINE  WNEWPL
C---
C------ WRITE NEWPL AND COMPILE FILES
C---
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
     1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
     2              , NCOMDK, NDECK , NIDENT
     3              , MMEM  , NMSTOR, NMFETC
     4              , MCORTB, NCORTB, MMODLS, NMODLS
     5              , LASTDK
      COMMON          SYMTB(7,400)  , DIRLST(5,2000)
     1              , CORTBL(5,1000), MODLST(2,1000)
     2              , MEM(20000)
      COMMON /DKFLG/  DKFLG
      COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
     1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
      COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
     9              , WARNFL, SHOWFL
      COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
     1              , CARD4S(20)
          DIMENSION  REC(22)
              EQUIVALENCE  (DIRNUM, REC(1))
C---
      DIMENSION  CDIDDK(3)
           DATA  CDIDDK/2HCD, 2HID, 2HDK/
C------ DISABLE COMPILE FLAG SETTING IN RDPLIN
      DKFLG = 0
      REWIND  COMPIL
C---
      IF( NPLFLG .EQ. 1 )  NPLFLG = FULFLG
      IF( (ERRFLG + WARNFL) .NE. 0 )  NPLFLG = 0
C---
      NMSTOR = 0
      IF( NPLFLG .NE. 0 )  REWIND  NEWPL
      IF( NPLFLG .NE. 0 )
     1          WRITE(NEWPL ,1006) NCOMDK, NDECK, NIDENT, NDIRLS
1006  FORMAT( 10H DIRECTORY,/,3H CD,I4,3H DK,I4,3H ID,I4,3H LM,I4 )
          DO  110  I = 1 , NSYMTB
          SYMTB(6,I) = SYMTB(4,I)
          SYMTB(4,I) = IABS ( SYMTB(4,I) )
110       CONTINUE
      IF( NPLFLG .NE. 0 )
     1          WRITE(NEWPL ,1007)  ((SYMTB(I,J),  I=1,5), J=1,NSYMTB)
1007  FORMAT( 1X,2A4,I2,I5,I4, 1X,2A4,I2,I5,I4, 1X,2A4,I2,I5,I4,
     1        1X,2A4,I2,I5,I4 )
            DO  120  I = 1 , NSYMTB
            SYMTB(5,I) = SYMTB(3,I)
            J = SYMTB(3,I)
            SYMTB(3,I) = CDIDDK(J+2)
120         CONTINUE
      WRITE(OUTPUT,1019) NCOMDK, NDECK, NIDENT
1019  FORMAT( 10H DIRECTORY,/,1X,I4,10H COMDECKS,,I5,7H DECKS,
     1                          ,I5,7H IDENTS)
      WRITE(OUTPUT,1018)  ((SYMTB(I,J),  I=1,4), J=1,NSYMTB)
1018  FORMAT( 1X,2A4,2X,A2,I5, 5X,2A4,2X,A2,I5
     1      , 5X,2A4,2X,A2,I5, 5X,2A4,2X,A2,I5 )
      IF( NPLFLG .NE. 0 )
     1          WRITE(NEWPL ,1008)  ((DIRLST(I,J), I=1,3), J=1,NDIRLS)
1008  FORMAT( I4,2I5, I4,2I5, I4,2I5, I4,2I5, I4,2I5 )
C---
            DO  200  I = 1 , NSYMTB
            SYMTB(3,I) = SYMTB(5,I)
            SYMTB(4,I) = SYMTB(6,I)
            SYMTB(5,I) = 0
200         SYMTB(6,I) = 0
C------ TRANSFER PLIN TO NEWPL
2000   CALL  RDPLIN
          IF( SEQ .EQ. 0 )  GOTO  9000
              IF( NPLFLG .NE. 0 )
     1             CALL  WTPL ( NEWPL )
C.......... DO NOTHING IF INACTIVE
      IF( TYP .LT. 0 )  GOTO  2000
        GOTO  (2100, 2200, 2300, 2400, 2500) , TYP
C------ DATA
2100  IF( CDFLG .NE. 0 )  GOTO  2150
      IF( CFFL  .NE. 0 )  CALL  COMPWT ( REC )
      GOTO  2000
2150  IF( NMSTOR+22 .GT. MMEM )  CALL  ERROR ( 12 )
      SYMTB(6,CDFLG) = SYMTB(6,CDFLG) + 1
          DO  2160  I = 1 , 22
          II = NMSTOR + I
2160      MEM(II) = REC(I)
      NMSTOR = NMSTOR + 22
      GOTO  2000
C------ *CA
2200  IF( CFFL .EQ. 0 )  GOTO  2000
      PTR = SYMTB(5,CALFLG)
      N   = SYMTB(6,CALFLG)
      IF( PTR .EQ. 0 )  GOTO  2280
      IF( N .EQ. 0 )  GOTO  2000
          DO  2220  I = 1 , N
           CALL  COMPWT ( MEM(PTR) )
          PTR = PTR + 22
2220      CONTINUE
      GOTO  2000
2280   CALL  ERROR ( 23 )
      WRITE( OUTPUT, 1017 )  (SYMTB(I,CALFLG), I=1,2)
1017  FORMAT(13X,8HCOMDECK ,2A4,27H MUST BE PREVIOUSLY DEFINED)
      GOTO  2000
C------ *DK
2300  CDFLG = 0
      CFFL   = FULFLG
      IF( SYMTB(4,DIRNUM) .LT. 0 )  CFFL = CFFL + 1
      GOTO  2000
C------ *CD
2400  CDFLG = DIRNUM
      SYMTB(5,CDFLG) = NMSTOR + 1
      SYMTB(6,CDFLG) = 0
      GOTO  2000
C------ *WEOF
2500  ENDFILE  COMPIL
      GOTO  2000
C------ END OF (PLIN)
9000  ENDFILE  COMPIL
      REWIND  PLIN
      REWIND  COMPIL
      ENDFILE  PLIN
      REWIND  PLIN
      IF( NPLFLG .NE. 0 )  ENDFILE  NEWPL
      IF( NPLFLG .NE. 0 )  REWIND   NEWPL
      IF( ERRFLG .EQ. 0 )  GOTO  9900
          ENDFILE  COMPIL
          REWIND   COMPIL
          IF( NPLFLG .EQ. 0 )  GOTO  9900
              ENDFILE  NEWPL
              REWIND   NEWPL
9900  RETURN
      END
      SUBROUTINE  WTPL ( LFN )
C-
C--- WRITE ONE PL LINE TO LFN,  IF LFN=0 WRITE INTO MEM ARRAY
C-
      IMPLICIT INTEGER (A-Z)
C---
      COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
      COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
     1              , CARD4S(20)
          DIMENSION  REC(22)
              EQUIVALENCE  (DIRNUM, REC(1))
C---
1004  FORMAT( I2,I4,I5 )
1005  FORMAT( I2,I4,I5,/,4X,I4 )
1009  FORMAT( I2,I4,I5,1X,20A4 )
C---
      IF( LFN .EQ. 0 )  GOTO  300
          IF( CALFLG .EQ. 0 )  GOTO  200
              WRITE( LFN, 1005 ) TYP, DIRNUM, SEQ, CALFLG
              GOTO  900
200       IF( IABS( TYP ) .NE. 1 )  GOTO  220
              DO  202  I = 1 , 20
              I2 = 23 - I
              IF( REC(I2) .NE. BLNK )  GOTO  204
202           CONTINUE
204       WRITE( LFN, 1009 )  TYP, ( REC(I), I=1,I2 )
              GOTO  900
220       WRITE( LFN, 1004 ) TYP, DIRNUM, SEQ
              GOTO  900
300    CALL  MEMSTO
900   RETURN
      END
