C     A8080 AN 8080 COMPILER FRED S. PARMENTER AND DOVID KASHNOW
C
C     THIS PROGRAM WAS WRITTEN BY DOVID KASHNOW WHILC A STUDENT AT MCP
C     AND MODIFIED SLIGHTLY BY ME (FSP).
C
C     MASS. COLLEGE OF PHARMACY, 179 LONGWOOD AVE., BOSTON, MA. 02215
C     CONTACT ME FOR ANY QUESTIONS ABOUT THE PROGRAM, NOTING ERRORS OR
C     JUST COMMENTS.
C
C     617-732-2926
C
C     JULY 10, 1979 VERSION 9
C
C     BASICALLY THE PROGRAM MAKES ONE PASS AT YOUR FILE TO CREATE A SYMBOL
C     TABLE AND THEN ON THE SECOND PASS GENERATES THE *_ AND L_ FILES
C
C     THE RULES FOR HOW TO CREATE THE EDITOR FILE ARE FAIRLY SIMPLE:
C
C     A COMMENT LINE IS ONE WHICH BEGINS WITH A *, A % OR A ;
C     SUCH A LINE OF COURSE, IS NOT COMPILED
C
C     THERE ARE THREE FIELDS:
C
C         1) THE LABEL FIELD  -  COLUMNS 1 - 8
C         2) THE OP CODE FIELD-  COLUMNS 10-17
C         3) THE DATA FIELD   -  COLUMNS 19-80
C
C     IF A LINE IS TO CONTAIN A LABEL, COLUMN 1 MUST BE NON-BLANK AND MUST NOT
C     BE A COMMENT LINE CHARACTER.  THE OTHER COLUMNS (2-8) MAY BE ANY
C     COMBINATION OF CHARACTERS OR BLANKS.
C
C     IF THIS LINE CONTAINS AN OP CODE THEN THAT OP CODE MUST BE IN
C     COLUMNS 10-17 EXACTLY CORRECT.  THIS IS NOT A FREE FORM ASSEMBLER.
C     GENERALLY SPEAKING THIS MEANS THAT IF THE OP CODE HAS AN EMBEDDED BLANK
C     (FOR EXAMPLE RST  7) THEN IT MUST BE ENTERED WITH ONE SPACE ONLY
C     (I.E. RST 7).
C
C     THERE ARE 7 ALLOWED PSEUDO OP CODES AS DETAILED BELOW:
C
C     1) ORG  -  REQUIRES A 16 BIT ADDRESS
C                THIS CODE TELLS THE ASSEMBLER WHERE TO START LOADING
C                THE ASSEMBLED CODE INTO THE MICRO'S MEMORY
C                FOR EXAMPLE ORG      H3E00 WILL GENERATE A LINE IN THE
C                B_ FILE LIKE: I3E00 C.R.
C     2) END  -  REQUIRES NO DATA FIELD
C                THIS CODE TELLS THE ASSEMBLER YOU ARE AT THE END OF FILE
C                GENERATES AND ESCAPE CHARACTER ON THE B_ FILE
C                IT ALSO, OF COURSE, TERMINATES COMPILATION
C
C     3) EJCT -  REQUIRES NO DATA FIELD
C                THIS CODE GENERATES AN PAGEFEED ON THE L_ FILE
C
C     4) SKIP -  REQUIRES A DATA FIELD
C                THIS CODE GENERATES LINE FEEDS ON THE L_ FILE
C
C     5) DASH -  REQUIRES A DATA FIELD
C                WRITES THE SPECIFIED NUMBER OF DASHES ONTO THE L_ FILE
C     6) DOT  -  REQUIRES A DATA FIELD
C                WRITES THE SPECIFIED NUMBER OF DOTS ONTO THE L_ FILE
C
C     7) EQU  -  REQUIRES A DATA FIELD AND A LABEL FIELD
C                THE LABEL IS PLACED INTO THE SYMBOL TABLE WITH THE VALUE
C                SPECIFIED IN THE DATA FIELD
C
C     THE LAST FIELD TO CONSIDER IS THE DATA FIELD.  THIS FIELD MUST CONTAIN
C     IN COLUMN 19 A CHARACTER TO TELL THE ASSEMBLER HOW THE DATA WHICH
C     FOLLOWS (IN COLUMNS 20-80) SHOULD BE INTERPRETED.  THE FOLLOWING
C     CHARACTERS ARE ALLOWED:
C
C     O,Q OR : IMPLIES OCTAL
C     B        IMPLIES BINARY
C     D        IMPLIES DECIMAL (ACTUALLY A SPACE ALSO IMPLIES DECIMAL)
C     H        IMPLIES HEXADECIMAL
C     $        IMPLIES WE ARE REFERENCING A LINE NUMBER A CERTAIN
C              NUMBER OF LINES (NOT LOCATIONS IN MEMORY) RELATIVE
C              TO THIS LINE
C                   THE NEXT CHARACTER (IN COLUMN 20) MUST BE EITHER A
C                   + OR - AND THE NEXT CHARACTER (IN COLUMN 21) MUST
C                   BE A SINGLE DIGIT 0 - 9.  EXAMPLES OF WHERE SUCH A
C                   FORM WOULD ARISE ARE:
C                        DEMO     JMP      $-3
C                                 JNC      $+4
C                   IN THE FIRST CASE, THE DESIRED EFFECT IS A JUMP
C                   BACK THREE LINES, AND IN THE SECOND A JUMP FORWARD 4 LINES
C     # OR '   IMPLIES AN ASCII CHARACTER FOLLOWS
C              THE # SAYS TO TURN ITS PARITY OFF
C              THE ' SAYS TO TURN ITS PARITY ON
C                     SUCH A USAGE WOULD BE MVI C     #H
C                     TO PUT THE ASCII H INTO THE C REGISTER WITH PARITY OFF
C     L        IMPLIES THAT A LABEL FOLLOWS, E.G. JMP      LDEMO
C
C
C
C     THE FOLLOWING IS AN EXAMPLE OF A DEMO PROGRAM WHICH WOULD OUTPUT
C     AN 'H' EVERY 5 SECONDS TO PRIME
C
C              ORG      H3C00  START THE PROGRAM AT 3C00
C     * A DEMO PROGRAM FOR PULSE
C     *
C     BEGIN    MVI C    'H
C              CALL     LCO        * OUTPUT WHAT'S IN C TO THE TERMINAL
C              SKIP     D3
C     * NOW WAIT 5 SECONDS
C              MVI A    D100
C              CALL     LWAIT
C              JMP      LBEGIN
C              SKIP     D3
C     *
C     * SUBROUTINES INTERNAL TO THIS PROGRAM FOLLOW
C     * NOTE THAT CO IS ALREADY IN THE ROM OF THE MICRO AND THE
C     * ASSEMBLER KNOWS THIS AND WHAT ITS LOCATION IS
C     * THE SAME IS TRUE FOR THE SUBROUINE DELAY WHICH WAIT CALLS
C     *
C     WAIT     MOV B,A
C     WA       DCR B
C              RM       * RETURN IMMEDIATELY IF A WAS ZERO TO START
C              MVI C    D7
C     WB       CALL     LDELAY
C              DCR C
C              JNZ      LWB
C              JMP      LWA
C              SKIP     D3
C              END
C
C
C     THE FOLLOWING IS THE L_ FILE WHICH THE ASSEMBLER GENERATES
C     (AND THE USER HAS REQUESTED THAT THE SYMBOL TABLE BE PRINTED
C     WITHOUT THE ROUTINES SUPPLIED BY INTEL)
C
C                1                          ORG      H3C00  START THE PROGRAM AT 3C00
C                2                 * A DEMO PROGRAM FOR PULSE
C                3                 *
C     3C00       4     0EC8        BEGIN    MVI C    'H
C     3C02       5     CDE801               CALL     LCO        * OUTPUT WHAT'S IN C TO THE TERMINAL
C                6                          SKIP     D3
C
C
C
C                7                 * NOW WAIT 5 SECONDS
C     3C05       8     3E64                 MVI A    D100
C     3C07       9     CD0D3C               CALL     LWAIT
C     3C0A      10     C3003C               JMP      LBEGIN
C               11                          SKIP     D3
C
C
C
C               12                 *
C               13                 * SUBROUTINES INTERNAL TO THIS PROGRAM FOLLOW
C               14                 * NOTE THAT CO IS ALREADY IN THE ROM OF THE MICRO AND THE
C               15                 * ASSEMBLER KNOWS THIS AND WHAT ITS LOCATION IS
C               16                 * THE SAME IS TRUE FOR THE SUBROUINE DELAY WHICH WAIT CALLS
C               17                 *
C     3C0D      18     47          WAIT     MOV B,A
C     3C0E      19     05          WA       DCR B
C     3C0F      20     F8                   RM       * RETURN IMMEDIATELY IF A WAS ZERO TO START
C     3C10      21     0E07                 MVI C    D7
C     3C12      22     CDB104      WB       CALL     LDELAY
C     3C15      23     0D                   DCR C
C     3C16      24     C2123C               JNZ      LWB
C     3C19      25     C30E3C               JMP      LWA
C               26                          SKIP     D3
C
C
C
C               27                          END
C        0 ERRORS
C     ASSEMBLY COMPLETED (DCK ** REV 8)
C
C
C
C
C     SYMBOL TABLE
C
C     A LABEL INCLUDING ** MEANS IT IS AN INTEL ROUTINE IN ROM
C
C     ORDERED AS IN PROGRAM      ORDERED BY LABEL           ORDERED BY HEX VALUE
C
C     BEGIN        3C00          BEGIN        3C00          BEGIN        3C00
C     WAIT         3C0D          WA           3C0E          WAIT         3C0D
C     WA           3C0E          WAIT         3C0D          WA           3C0E
C     WB           3C12          WB           3C12          WB           3C12
C
C     IF THE USER HAD REQUESTED A 'FULL' SYMBOL TABLE IT WOULD
C     HAVE LOOKED LIKE:
C
C     SYMBOL TABLE
C
C     A LABEL INCLUDING ** MEANS IT IS AN INTEL ROUTINE IN ROM
C
C     ORDERED AS IN PROGRAM      ORDERED BY LABEL           ORDERED BY HEX VALUE
C
C     DCMD  **     005F          ADRD  **     01A8          DCMD  **     005F
C     GCMD  **     008B          ADROUT**     01B1          GCMD  **     008B
C     ICMD  **     00A9          BEGIN        3C00          ICMD  **     00A9
C     MCMD  **     00EF          BREAK **     01C2          MCMD  **     00EF
C     RCMD  **     0406          BYTE  **     0496          SCMD  **     010F
C     SCMD  **     010F          CI    **     01D5          XCMD  **     0133
C     WCMD  **     0441          CNVBN **     01DF          ADRD  **     01A8
C     XCMD  **     0133          CO    **     01E8          ADROUT**     01B1
C     ADRD  **     01A8          CROUT **     01F3          BREAK **     01C2
C     ADROUT**     01B1          DCMD  **     005F          CI    **     01D5
C     BREAK **     01C2          DELAY **     04B1          CNVBN **     01DF
C     CI    **     01D5          ECHO  **     01F9          CO    **     01E8
C     CNVBN **     01DF          ERROR **     0212          CROUT **     01F3
C     CO    **     01E8          FRET  **     021D          ECHO  **     01F9
C     CROUT **     01F3          GCMD  **     008B          ERROR **     0212
C     ECHO  **     01F9          GETCH **     0220          FRET  **     021D
C     ERROR **     0212          GETHX **     0227          GETCH **     0220
C     FRET  **     021D          GETNM **     025B          GETHX **     0227
C     GETCH **     0220          HILO  **     02A0          GETNM **     025B
C     GETHX **     0227          ICMD  **     00A9          HILO  **     02A0
C     GETNM **     025B          INUST **     02B2          INUST **     02B2
C     HILO  **     02A0          LEAD  **     04C0          NMOUT **     02C2
C     INUST **     02B2          MCMD  **     00EF          PRVAL **     02D5
C     NMOUT **     02C2          NMOUT **     02C2          REGDS **     02DF
C     PRVAL **     02D5          PADR  **     04CC          RGADR **     0310
C     REGDS **     02DF          PBYTE **     04D5          RSTTF **     0327
C     RGADR **     0310          PEOF  **     04EC          SRET  **     033B
C     RSTTF **     0327          PEOL  **     050A          STHFO **     033D
C     SRET  **     033B          PO    **     0515          STHLF **     0348
C     STHFO **     033D          PRVAL **     02D5          VALDG **     0367
C     STHLF **     0348          RCMD  **     0406          VALDL **     0382
C     VALDG **     0367          REGDS **     02DF          RCMD  **     0406
C     VALDL **     0382          RGADR **     0310          WCMD  **     0441
C     BYTE  **     0496          RI    **     0522          BYTE  **     0496
C     DELAY **     04B1          RICH  **     0519          DELAY **     04B1
C     LEAD  **     04C0          RSTTF **     0327          LEAD  **     04C0
C     PADR  **     04CC          SCMD  **     010F          PADR  **     04CC
C     PBYTE **     04D5          SRET  **     033B          PBYTE **     04D5
C     PEOF  **     04EC          STHFO **     033D          PEOF  **     04EC
C     PEOL  **     050A          STHLF **     0348          PEOL  **     050A
C     PO    **     0515          VALDG **     0367          PO    **     0515
C     RI    **     0522          VALDL **     0382          RICH  **     0519
C     RICH  **     0519          WA           3C0E          RI    **     0522
C     BEGIN        3C00          WAIT         3C0D          BEGIN        3C00
C     WAIT         3C0D          WB           3C12          WAIT         3C0D
C     WA           3C0E          WCMD  **     0441          WA           3C0E
C     WB           3C12          XCMD  **     0133          WB           3C12
C
C
C     NOW THE MAIN PROGRAM BEGINS
C
      INTEGER CODE(256),TRNAME(16),LINE(80),COMNT(3),ICHAR(4),HEX(4)
      INTEGER BFILE(3),HEXNUM(4),PC(4),NEW(4),PCTEMP(4),JUNK(4),ERROR
      INTEGER FORMFD,CR,IBEGIN(3),TFILE1(3),TFILE2(3),ISYMBL(2,300,4)
     *,IREAL(2),TRLEN
      LOGICAL OK
      DIMENSION WORDS(2,256),PSEUDO(7),LFILE(3)
      REAL SYMBOL(300,4),MEMCNT,MCOUNT
      EQUIVALENCE (ISYMBL(1,1,1),SYMBOL(1,1)),(IREAL(1),REAL)
      DATA TRLEN/16/
      DATA WORDS/'NOP     LXI B   STAX B  INX B   INR B   ',
     .'DCR B   MVI B   RLC             DAD B   ',
     .'LDAX B  DCX B   INR C   DCR C   MVI C   ',
     .'RRC             LXI D   STAX D  INX D   ',
     .'INR D   DCR D   MVI D   RAL             ',
     .'DAD D   LDAX D  DCX D   INR E   DCR E   ',
     .'MVI E   RAR             LXI H   SHLD    ',
     .'INX H   INR H   DCR H   MVI H   DAA     ',
     .'        DAD H   LHLD    DCX H   INR L   ',
     .'DCR L   MVI L   CMA             LXI SP  ',
     .'STA     INX SP  INR M   DCR M   MVI M   ',
     .'STC             DAD SP  LDA     DCX     ',
     .'INR A   DCR A   MVI A   CMC     MOV B,B ',
     .'MOV B,C MOV B,D MOV B,E MOV B,H MOV B,L ',
     .'MOV B,M MOV B,A MOV C,B MOV C,C MOV C,D ',
     .'MOV C,E MOV C,H MOV C,L MOV C,M MOV C,A ',
     .'MOV D,B MOV D,C MOV D,D MOV D,E MOV D,H ',
     .'MOV D,L MOV D,M MOV D,A MOV E,B MOV E,C ',
     .'MOV E,D MOV E,E MOV E,H MOV E,L MOV E,M ',
     .'MOV E,A MOV H,B MOV H,C MOV H,D MOV H,E ',
     .'MOV H,H MOV H,L MOV H,M MOV H,A MOV L,B ',
     .'MOV L,C MOV L,D MOV L,E MOV L,H MOV L,L ',
     .'MOV L,M MOV L,A MOV M,B MOV M,C MOV M,D ',
     .'MOV M,E MOV M,H MOV M,L HLT     MOV M,A ',
     .'MOV A,B MOV A,C MOV A,D MOV A,E MOV A,H ',
     .'MOV A,L MOV A,M MOV A,A ADD B   ADD C   ',
     .'ADD D   ADD E   ADD H   ADD L   ADD M   ',
     .'ADD A   ADC B   ADC C   ADC D   ADC E   ',
     .'ADC H   ADC L   ADC M   ADC A   SUB B   ',
     .'SUB C   SUB D   SUB E   SUB H   SUB L   ',
     .'SUB M   SUB A   SBB B   SBB C   SBB D   ',
     .'SBB E   SBB H   SBB L   SBB M   SBB A   ',
     .'ANA B   ANA C   ANA D   ANA E   ANA H   ',
     .'ANA L   ANA M   ANA A   XRA B   XRA C   ',
     .'XRA D   XRA E   XRA H   XRA L   XRA M   ',
     .'XRA A   ORA B   ORA C   ORA D   ORA E   ',
     .'ORA H   ORA L   ORA M   ORA A   CMP B   ',
     .'CMP C   CMP D   CMP E   CMP H   CMP L   ',
     .'CMP M   CMP A   RNZ     POP B   JNZ     ',
     .'JMP     CNZ     PUSH B  ADI     RST 0   ',
     .'RZ      RET     JZ              CZ      ',
     .'CALL    ACI     RST 1   RNC     POP D   ',
     .'JNC     OUT     CNC     PUSH D  SUI     ',
     .'RST 2   RC              JC      IN      ',
     .'CC              SBI     RST 3   RPO     ',
     .'POP H   JPO     XTHL    CPO     PUSH H  ',
     .'ANI     RST 4   RPE     PCHL    JPE     ',
     .'XCHG    CPE             XRI     RST 5   ',
     .'RP      POP PSW JP      DI      CP      ',
     .'PUSH PSWORI     RST 6   RM      SPHL    ',
     .'JM      EI      CM              CPI     ',
     .'RST 7   '/
      DATA CODE/0,2,4*0,1,7*0,1,0,0,2,4*0,1,0,0,
     1 5*0,1,0,0,2,2,0,0,0,1,0,0,0,2,3*0,1,0,0,2,
     2 2,3*0,1,0,0,0,2,0,0,0,1,131*0,3*2,0,
     3 1,3*0,2,0,2,2,1,0,0,0,2,1,2,0,1,0,0,0,2,1,2,0,
     4 1,0,0,0,2,0,2,0,1,0,0,0,2,0,2,0,1,0,0,0,2,0,2,0,1,
     5 3*0,2,0,2,0,1,0/
      DATA PSEUDO/'ORG END EJCTSKIPDASHDOT EQU '/
      DATA SYMBOL/
     . 'DCMDGCMDICMDMCMDRCMDSCMDWCMDXCMDADRDADRO',
     . 'BREACI  CNVBCO  CROUECHOERROFRETGETCGETH',
     . 'GETNHILOINUSNMOUPRVAREGDRGADRSTTSRETSTHF',
     . 'STHLVALDVALDBYTEDELALEADPADRPBYTPEOFPEOL',
     . 'PO  RI  RICH',257*'XXXX',
     . 9*'    ','UT  ',
     . 'K       N       T       R       H   X   ',
     . 'M       T   T   L   S   R   F       O   ',
     . 'F   G   L       Y           E           ',
     . '            ',257*'    ',300*'0000',
     . 95.,139.,169.,239.,1030.,271.,1089.,307.,424.,433.,
     . 450.,469.,479.,488.,499.,505.,530.,541.,544.,551.,
     . 603.,672.,690.,706.,725.,735.,784.,807.,827.,829.,
     . 840.,871.,898.,1174.,1201.,1216.,1228.,1237.,1260.,1290.,
     . 1301.,1314.,1305.,257*0./
      DATA FORMFD/:106000/,CR/:106400/
      CALL ATCH$$(0,0,0,0,0,IERR)
      DO 13 I=1,43
      CALL DEC2HX(HEX,SYMBOL(I,4))
      CALL EQUIV(HEX,SYMBOL(I,3))
13    CONTINUE
      ERROR=0
      CALL RDTK2(2,TRNAME,TRLEN,OK)
      IF(OK)GO TO 1
3     WRITE(1,14)
14    FORMAT('THE PROPER COMMAND LINE IS:'//
     *'A8080 TRNAME'//
     *'WHERE TRNAME IS THE NAME OF YOUR FILED TO BE COMPILED BY THE'/
     *'8080 ASSEMBLER- A LISTING FILE OF THE FORM L_TRNAME'/
     *'IS FORMED ALONG WITH THE COMPILED VERSION *_TRNAME'//)
      CALL EXIT
1     CALL OF1(3,TRNAME,TRLEN,1,$3)
      LFILE(1)='L_'
      LFILE(2)=TRNAME(1)
      LFILE(3)=TRNAME(2)
      BFILE(1)='*_'
      BFILE(2)=LFILE(2)
      BFILE(3)=LFILE(3)
      CALL OF1(3,LFILE,6,2,$1)
      CALL OF1(3,BFILE,6,3,$1)
      CALL OF1(8,0,0,3,$1)
      CALL OF1(8,0,0,2,$1)
      LINECT=0
      COMNT(1)='*'
      COMNT(2)='%'
      COMNT(3)=';'
      IFIRST=0
      READ(5,10)LINE
      LINECT=LINECT+1
      IF(LINE(10).NE.'O'.OR.LINE(11).NE.'R'.OR.LINE(12).NE.'G')GOTO 221
      CALL BLFILL(PC,LINE)
      CALL HX2DEC(PC,MCOUNT)
1001  READ(5,10,END=11)LINE
      LINECT=LINECT+1
      CALL DEC2HX(PC,MCOUNT)
      IF(LINE(1).EQ.'%'.OR.LINE(1).EQ.'*'.OR.LINE(1).EQ.';')GOTO 1001
      IF(LINE(1).NE.' ')GOTO 70
      GOTO 85
11    IF(ERROR.NE.0)GO TO 12
      DO 9 I=1,3
9     CALL OF1(7,0,0,I,$1)
      IFIRST=1
      MEMCNT=0
      LINECT=0
      READ(5,10)LINE
      LINECT=LINECT+1
      IF(LINE(10).EQ.'O'.AND.LINE(11).EQ.'R'.AND.LINE(12).EQ.'G')
     . GOTO 50
221   WRITE(1,2)
      WRITE (6,2)
2     FORMAT ('FIRST STATEMENT MUST BE AN ORG')
12    CALL CL$
      CALL OF1(5,BFILE,6,0,0)
      CALL EXIT
C
C
C
5     READ(5,10,END=252)LINE
10    FORMAT (80A1)
6     LINECT=LINECT+1
50    IF(LINE(1).EQ.' ')GOTO 85
      DO 55 LOOP=1,3
      IF(LINE(1).EQ.COMNT(LOOP))GOTO 60
55    CONTINUE
      GOTO 85
C ***    PRINT COMMENT LINE   ***
60    WRITE(6,65)LINECT,LINE
65    FORMAT (T10,I3,T30,80A1)
      GOTO 5
C ***   THIS IS A LABEL   ***
70    CALL EQUIV(LINE(10),CHECK)
      IF(CHECK.EQ.'    ')GOTO 820
      IF(CHECK.NE.PSEUDO(7))GOTO 72
C *** PSEUDO - OP  +++++++ EQU   ***
      DO 7103 LOOP=20,50
      IF(LINE(LOOP).EQ.' ')GOTO 7104
7103   CONTINUE
      WRITE (1,102)LINECT
      WRITE (6,102)LINECT
      ERROR=ERROR+1
      GOTO 5
7104  NUMDIG=LOOP-20
      CALL POOL(SYMBOL,LINE,LINECT,LOOP,RLABEL,SLABEL,K,ERROR)
      IF(K.EQ.1)GOTO 5
      SYMBOL(LOOP,1)=RLABEL
      SYMBOL(LOOP,2)=SLABEL
C
C     NOW LET'S MAKE SURE THE NUMBER OF DIGITS, AND THE ACTUAL DIGITS
C     ARE ALLOWABLE
C
7105  CALL CHKDIG(LINE,NUMDIG,LINECT,$7106)
      GO TO 7107
7106  ERROR=ERROR+1
      GO TO 1001
7107  IF(LINE(19).NE.'H')GO TO 715
      CALL BLFILL(NEW,LINE)
      CALL EQUIV (NEW,TRCODE)
      SYMBOL(LOOP,3)=TRCODE
      CALL HX2DEC(NEW,SYMBOL(LOOP,4))
      GOTO 1001
715   IF(LINE(19).NE.'O'.AND.LINE(19).NE.'Q'.AND.LINE(19).NE.':')
     . GOTO 716
      CALL SWITCH(LINE,NUMDIG,8,SYMBOL(LOOP,4))
      CALL DEC2HX(NEW,SYMBOL(LOOP,4))
      CALL EQUIV(NEW,SYMBOL(LOOP,3))
      GOTO 1001
716   IF(LINE(19).NE.' '.AND.LINE(19).NE.'D')GOTO 717
      CALL SWITCH(LINE,NUMDIG,10,SYMBOL(LOOP,4))
      CALL DEC2HX(NEW,SYMBOL(LOOP,4))
      CALL EQUIV(NEW,SYMBOL(LOOP,3))
      GOTO 1001
717   IF(LINE(19).NE.'B')GOTO 718
      CALL SWITCH(LINE,NUMDIG,2,SYMBOL(LOOP,4))
      CALL DEC2HX(NEW,SYMBOL(LOOP,4))
      CALL EQUIV(NEW,SYMBOL(LOOP,3))
      GOTO 1001
718   WRITE (1,719)LINECT
719   FORMAT ('LINE ',I3,3X,'INVALID CODE IN COLUMN 19')
      WRITE(6,719)LINECT
      ERROR=ERROR+1
      GOTO 1001
C
C *** DUMMY LABEL ***
C
820   CALL POOL(SYMBOL,LINE,LINECT,LOOP,RLABEL,SLABEL,K,ERROR)
      IF(K.EQ.1)GOTO 5
      SYMBOL(LOOP,1)=RLABEL
      SYMBOL(LOOP,2)=SLABEL
      CALL EQUIV(PC,SYMBOL(LOOP,3))
      CALL HX2DEC(PC,SYMBOL(LOOP,4))
      GOTO 1001
72    CALL POOL(SYMBOL,LINE,LINECT,LOOP,RLABEL,SLABEL,K,ERROR)
      IF(K.EQ.1)GOTO 5
      SYMBOL(LOOP,1)=RLABEL
      SYMBOL(LOOP,2)=SLABEL
      CALL EQUIV(LINE(5),SYMBOL(LOOP,2))
      CALL DEC2HX(PC,MCOUNT)
      CALL EQUIV(PC,SYMBOL(LOOP,3))
      CALL HX2DEC(PC,SYMBOL(LOOP,4))
C ***   FIND OP CODE   ***
85    CALL EQUIV(LINE(10),OPCOD1)
      CALL EQUIV(LINE(14),OPCOD2)
      IF(OPCOD1.NE.'    ')GOTO 87
      WRITE (6,65)LINECT,LINE
      GOTO 5
87    DO 90 I=1,256
      IF(WORDS(1,I).EQ.OPCOD1.AND.WORDS(2,I).EQ.OPCOD2)GOTO 100
90    CONTINUE
      IF(IFIRST.EQ.0)GOTO 1001
C ***   NO OP CODE - - - - CHECK FOR PSEUDO OP CODE   ***
      DO 95 IPSEUD=1,7
      IF(PSEUDO(IPSEUD).EQ.OPCOD1)GOTO 240
95    CONTINUE
      WRITE (1,98) LINECT,LINE
98    FORMAT ('ERROR .... ILLEGAL OP CODE IN LINE ',I3,3X,80A1)
      WRITE (6,98)LINECT,LINE
      ERROR=ERROR+1
      GOTO 5
C ***   NOW WE HAVE A DECIMAL VALUE FOR THE OP CODE   ***
C ***   LET'S CONVERT THE OP CODE (I) TO ITS HEX EQUIVALENT   ***
100   IF(IFIRST.NE.0)GOTO 101
      MCOUNT=MCOUNT+CODE(I)+1
      GOTO 1001
101   RK=I*1.-1.
      CALL DEC2HX(HEXNUM,RK)
      CALL IN8080(HEXNUM(3),ICODE)
C ***   FOR PROGRAMMING PURPOSES WE WILL CHANGE THE DECIMAL LINE   ***
C ***   COUNTER TO HEX. THEN WE WILL LOCATE THE FIRST BLANK SPOT   ***
      CALL DEC2HX(PC,MEMCNT)
      DO 103 LOOP=20,50
      IF(LINE(LOOP).EQ.' ')GOTO 104
103   CONTINUE
      WRITE (1,102)LINECT
      WRITE (6,102)LINECT
102   FORMAT ('ERROR ... IN NUMDIG CALCULATION... PROGRAM FAULT',I3)
      ERROR=ERROR+1
      GOTO 5
104   NUMDIG=LOOP-20
C ***   THE OP-CODE WILL BE FOLLOWED BY 0,1, OR 2 DATA POINTS   ***
C ***   LET'S DIVIDE THE PROGRAM INTO THOSE THREE CATEGORIES   ***
      IF (CODE(I)-1) 105,115,190
C *** THERE ARE NO DATA POINTS WITH THIS OP CODE   ***
105   WRITE(6,110)PC,LINECT,ICODE,LINE
110   FORMAT (4A1,T10,I3,T18,A2,T30,80A1)
      CALL PRWF$$(2,3,LOC(ICODE),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      MEMCNT=MEMCNT+1.
      GOTO 5
C ***   THIS SECTION OF THE PROGRAM IS FOR OP CODES WITH   ***
C ***   ONE DATA POINT.   ***
C
C     CHECK FOR VALID DIGITS IN THE DATA FIELD
C
115   CALL CHKDIG(LINE,NUMDIG,LINECT,$12)
117   IF(LINE(19).EQ.'O'.OR.LINE(19).EQ.'Q'.OR.LINE(19).EQ.':')GOTO 120
      IF(LINE(19).EQ.'H')GOTO 130
      IF(LINE(19).EQ.' '.OR.LINE(19).EQ.'D')GOTO 135
      IF(LINE(19).EQ.'B') GOTO 140
      IF(LINE(19).EQ.'$')GOTO 145
      IF(LINE(19).EQ.'#' .OR. LINE(19).EQ.1H')GOTO 160
      IF (LINE(19).EQ.'L') GOTO 1162
      WRITE (1,118)LINECT,LINE
118   FORMAT ('ILLEGAL CODE IN COLUMN 19',I3,3X,80A1)
      WRITE(6,118)LINECT,LINE
      CALL EXIT
      GOTO 5
C ***   DATA IS IN OCTAL FORM   ***
120   CALL SWITCH(LINE,NUMDIG,8,SUM)
123   CALL DEC2HX(ICHAR,SUM)
      CALL IN8080(ICHAR(3),IDATA)
124   WRITE(6,125) PC,LINECT,ICODE,IDATA,LINE
125   FORMAT (4A1,T10,I3,T18,2A2,T30,80A1)
      CALL PRWF$$(2,3,LOC(ICODE),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      CALL PRWF$$(2,3,LOC(IDATA),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      MEMCNT=MEMCNT+2.
      CALL DEC2HX(PC,MEMCNT)
      GOTO 5
C *** DATA IS IN HEX FORM   ***
130   CALL BLFILL(NEW,LINE)
      CALL IN8080(NEW(3),IDATA)
      GOTO 124
C *** DATA IS IN DECIMAL FORM   ***
135   CALL SWITCH(LINE,NUMDIG,10,SUM)
      GOTO 123
C ***   DATA IS IN BINARY FORM   ***
140   CALL SWITCH(LINE,NUMDIG,2,SUM)
      GOTO 123
C ***   THIS IS A -$- LINE .  2ND CHARACTER MUST BE + OR -   ***
145   CALL DEC20(LINE,ISUM)
      IF(LINE(20).EQ.'-') GOTO 152
      IF(LINE(20).EQ.'+') GOTO 154
      WRITE (1,147)LINECT
147   FORMAT ('ILLEGAL CHARACTER IN COLUMN 20.....LINE #',I3)
      WRITE (6,147)LINECT
      ERROR=ERROR+1
      GOTO 5
152   KLOOP=0
      IFAR=ISUM-1
      IBACK=1
      CALL HX2DEC(PC,S)
      CALL BACKUP(1,1)
      S=S-1.
      GOTO 1531
1530  CALL BACKUP(1,2)
      IBACK=IBACK+1
1531  READ(5,10) LINE
      CALL EQUIV(LINE(10),OPCOD1)
      CALL EQUIV(LINE(14),OPCOD2)
      DO 1153 IJ=1,256
      IF(WORDS(1,IJ).EQ.OPCOD1.AND.WORDS(2,IJ).EQ.OPCOD2)GOTO 555
1153  CONTINUE
      GOTO 1530
555   S=S-CODE(IJ)-1.
      KLOOP=KLOOP+1
      IF(KLOOP.NE.IFAR)GOTO 1530
      CALL DEC2HX(PCTEMP,S)
      IB=IBACK-1
      DO 1154 II=1,IB
      READ(5,10)LINE
1154  CONTINUE
      GOTO 151
154   KLOOP=0
      IHEAD=0
      CALL HX2DEC(PC,S)
      S=S+3.
      ISUM=ISUM-1
1540  READ(5,10,END=1590)
      IHEAD=IHEAD+1
      CALL EQUIV(LINE(10),OPCOD1)
      CALL EQUIV(LINE(14),OPCOD2)
      DO 1541 IJ=1,256
      IF(WORDS(1,IJ).EQ.OPCOD1.AND.WORDS(2,IJ).EQ.OPCOD2)GOTO 1542
1541  CONTINUE
      GOTO 1540
1542  S=S+CODE(IJ)+1
      KLOOP=KLOOP+1
      IF(KLOOP.NE.ISUM)GOTO 1540
      CALL DEC2HX(PCTEMP,S)
      CALL BACKUP(1,KLOOP)
151   CALL IN8080(PCTEMP(1),JDATA)
      CALL IN8080(PCTEMP(3),IDATA)
      WRITE (6,153) PC,LINECT,ICODE,IDATA,JDATA,LINE
153   FORMAT (4A1,T10,I3,T18,3A2,T30,80A1)
      CALL PRWF$$(2,3,LOC(ICODE),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      CALL PRWF$$(2,3,LOC(IDATA),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      CALL PRWF$$(2,3,LOC(JDATA),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      MEMCNT=MEMCNT+3.
      GOTO 5
C *** ERROR IN $LINE ***
1590  LINECT=LINECT+IHEAD
      ERROR=ERROR+1
      WRITE(1,1592)LINECT
1592  FORMAT ('ERROR **** TO MANY $ LINES IN LINE#',I3)
      WRITE(6,1592)LINECT
      GOTO 5
C ***   THE DATA IS IN ASCII FORM   ***
160   IF(LINE(19).EQ.'#')LINE(20)=AND(LINE(20),:77577)
      IF(LINE(19).EQ.1H')LINE(20)=OR(LINE(20),:100200)
      IASCII=SHFT(LINE(20),8)
      R=IASCII
      CALL DEC2HX(ICHAR,R)
      CALL IN8080(ICHAR(3),IDATA)
      WRITE(6,125) PC,LINECT,ICODE,IDATA,LINE
      CALL PRWF$$(2,3,LOC(ICODE),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      CALL PRWF$$(2,3,LOC(IDATA),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      MEMCNT=MEMCNT+2.
      GOTO 5
C ***   DATA IS A DATA LABEL   ***
1162  CALL EQUIV(LINE(20),DAT1)
      CALL EQUIV(LINE(24),DAT2)
      DO 1164 LOOP=1,300
      IF(SYMBOL(LOOP,1).EQ.'XXXX')GOTO 175
      IF(SYMBOL(LOOP,1).NE.DAT1)GOTO 1164
      IF(SYMBOL(LOOP,2).EQ.DAT2)GOTO 1166
1164  CONTINUE
      GOTO 175
1166  CALL DEC2HX(ICHAR,SYMBOL(LOOP,4))
      CALL IN8080(ICHAR(3),IDATA)
      GOTO 124
C ***   THE DATA IS AN ADDRESS LABEL   ***
165   CALL EQUIV(LINE(20),RLABEL)
      CALL EQUIV(LINE(24),SLABEL)
      DO 170 LOOP=1,300
      IF(SYMBOL(LOOP,1).EQ.'XXXX')GOTO 175
      IF(SYMBOL(LOOP,1).NE.RLABEL)GOTO 170
      IF(SYMBOL(LOOP,2).EQ.SLABEL)GOTO 180
170   CONTINUE
175   WRITE(1,177)LINECT,LINE
177   FORMAT (' LABEL IS NOT FOUND',5X,I3,3X,80A1)
      WRITE(6,177)LINECT,LINE
      ERROR=ERROR+1
      GOTO 5
C ***   LABEL HAS BEEN LOCATED IN -LOOP- POSITION   ***
C ***   COLUMN 4 WILLL EQUAL THE DECIMAL MEMORY LOCATION  ***
180   CALL DEC2HX(ICHAR,SYMBOL(LOOP,4))
      CALL IN8080(ICHAR(1),JDATA)
      CALL IN8080(ICHAR(3),IDATA)
      WRITE (6,153)PC,LINECT,ICODE,IDATA,JDATA,LINE
      CALL PRWF$$(2,3,LOC(ICODE),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      CALL PRWF$$(2,3,LOC(IDATA),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      CALL PRWF$$(2,3,LOC(JDATA),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      MEMCNT=MEMCNT+3.
      GOTO 5
C
C     THIS SECTION IS FOR OP CODES REQUIRING 2 DATA POINTS
C
190   CALL CHKDIG(LINE,NUMDIG,LINECT,$12)
      IF(LINE(19).EQ.'O'.OR.LINE(19).EQ.'Q'.OR.LINE(19).EQ.':')GOTO 195
      IF(LINE(19).EQ.'H')GOTO 210
      IF(LINE(19).EQ.' '.OR.LINE(19).EQ.'D')GOTO 220
      IF(LINE(19).EQ.'B') GOTO 225
      IF(LINE(19).EQ.'$')GOTO 145
      IF(LINE(19).EQ.'#' .OR. LINE(19).EQ.1H')GOTO 230
      IF (LINE(19).EQ.'L') GOTO 165
      WRITE (1,118)LINECT,LINE
      WRITE(6,118)LINECT,LINE
      ERROR=ERROR+1
      GOTO 5
C ***   DATA IS IN OCTAL FORM   ***
195   CALL SWITCH(LINE,NUMDIG,8,SUM)
197   CALL DEC2HX(ICHAR,SUM)
      WRITE(6,200)PC,LINECT,ICODE,ICHAR,LINE
200   FORMAT (4A1,5X,I3,6X,A2,4A1,9X,80A1)
      CALL PRWF$$(2,3,LOC(ICODE),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      CALL IN8080(ICHAR(1),IDATA)
      CALL IN8080 (ICHAR(3),JDATA)
      CALL PRWF$$(2,3,LOC(IDATA),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      CALL PRWF$$(2,3,LOC(JDATA),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      MEMCNT=MEMCNT+3.
      GOTO 5
C ***   THE DATA IS IN HEX FORM   ***
210   CALL BLFILL(NEW,LINE)
      CALL EQUIV(NEW,REAL)
      WRITE(6,215)PC,LINECT,ICODE,REAL,LINE
215   FORMAT (4A1,T10,I3,T18,A2,A4,T30,80A1)
      CALL PRWF$$(2,3,LOC(ICODE),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      CALL IN8080(LINE(20),JDATA)
      CALL IN8080(LINE(22),IDATA)
      CALL PRWF$$(2,3,LOC(IDATA),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      CALL PRWF$$(2,3,LOC(JDATA),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      MEMCNT=MEMCNT+3.
      GOTO 5
C ***   DATA IS IN DECIMAL FORM   ***
220   CALL SWITCH(LINE,NUMDIG,10,SUM)
      GOTO 197
C ***  DATA IS IN BINARY FORM   ***
225   CALL SWITCH(LINE,NUMDIG,2,SUM)
      GOTO 197
C ***   DATA IS IN ASCII FORM   ***
230   IASCII=SHFT(LINE(20),8)
      JASCII=SHFT(LINE(21),8)
      IF(LINE(19).EQ.'#')GO TO 2302
      IASCII=OR(IASCII,:200)
      JASCII=OR(JASCII,:200)
      GO TO 2303
2302  IASCII=AND(IASCII,:177)
      JASCII=AND(JASCII,:177)
2303  CONTINUE
      R=IASCII
      S=JASCII
      CALL DEC2HX(ICHAR,R)
      CALL IN8080(ICHAR(3),IDATA)
      CALL DEC2HX(ICHAR,S)
      CALL IN8080(ICHAR(3),JDATA)
      WRITE (6,153) PC,LINECT,ICODE,IDATA,JDATA,LINE
      CALL PRWF$$(2,3,LOC(ICODE),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      CALL PRWF$$(2,3,LOC(IDATA),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      CALL PRWF$$(2,3,LOC(JDATA),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      MEMCNT=MEMCNT+3.
      GOTO 5
C ***   THIS SECTION OF THE PROGRAM EXECUTES THE PSEUDO OPS   ***
240   GOTO (245,250,255,260,270,280,290),IPSEUD
C
C *** ORG ***
C
245   CALL EQUIV(LINE(20),REAL)
      CALL HX2DEC(LINE(20),MEMCNT)
      CALL DEC2HX(PC,MEMCNT)
      WRITE(6,65)LINECT,LINE
      IBEGIN(1)='I'-:240+SHFT(IREAL(1),8)
      IBEGIN(2)=SHFT(IREAL(1),-8)+SHFT(IREAL(2),8)
      IBEGIN(3)=SHFT(IREAL(2),-8)+:215
      CALL PRWF$$(2,3,LOC(IBEGIN),3,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
      GOTO 5
C
C *** END ***
C
250   WRITE(6,65)LINECT,LINE
      I=:233
      I=SHFT(I,-8)
      CALL PRWF$$(2,3,LOC(I),1,000000,IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
2001  FORMAT (2A4,5X,A4)
2002  CONTINUE
252   WRITE (1,254)ERROR
      WRITE (6,254)ERROR
254   FORMAT (I4,' ERRORS'/'ASSEMBLY COMPLETED (DCK ** REV 9)'//)
      CALL CL$
      IF(ERROR.NE.0)CALL OF1(5,BFILE,6,0,0)
C
C     THIS SECTION WAS ADDED BY FSP TO PRINT THE SYMBOL TABLE
C
      CALL TNOUA('DO YOU WANT A LISTING FILE? ',28)
      CALL YESNO(JUNK,$2540,$2548)
2540  CALL TNOUA('DO YOU WANT THE SYMBOL TABLE PRINTED? ',38)
      CALL YESNO(JUNK,$2541,$2549)
2541  CALL TNOUA('WITH THE 43 INTEL ROUTINES? ',28)
      CALL YESNO(IANS,$2544,$2542)
C
C     THIS SECTION ELIMINATES THE INTEL ROUTINES FROM THE SYMBOL TABLE
C
2542  DO 2543 I=1,257
      DO 2543 J=1,4
2543  SYMBOL(I,J)=SYMBOL(I+43,J)
C
C     COUNT TNE NUMBER OF LABELS IN THE SYMBOL TABLE
C     AND OPEN THE TEMPORARY FILES
C     THE TEMPORARY FILES HAVE THE FORM B_TRNAME#1 AND B_TRNAME#2
C     THESE UNUSUAL NAMES WERE CHOSEN SO THAT
C     IF TNE FILES ACCIDENTLY GOT LEFT IN THE UFD THE FUTIL
C     CLEAN B_ COMMAND WILL GET RID OF THEM
C     MAKE SURE TO CHANGE ALL SPACES IN THE SOURCE FILE NAME TO '#'
C
2544  IF(SHFT(TRNAME(1),-8,8).EQ.:240)TRNAME(1)=TRNAME(1)+3
      TFILE1(1)='B_'
      TFILE1(2)=TRNAME(1)
      TFILE2(1)='B_'
      TFILE2(2)=TRNAME(1)
      TFILE1(3)='#1'
      TFILE2(3)='#2'
      CALL OF1(3,TFILE1,6,1,$2548)
      CALL OF1(3,TFILE2,6,2,$2548)
      CALL OF1(8,0,0,1,$2548)
      CALL OF1(8,0,0,2,$2548)
      DO 2545 IMAX=1,300
      IF(SYMBOL(IMAX,1).EQ.'XXXX')GO TO 2546
C
C     IF THE USER HAS NOT REQUESTED THAT THE INTEL ROUTINES BE ELIMINATED
C     FROM THE SYMBOL TABLE, LET'S PUT IN '**' IN THE LAST TWO
C     CHARACTERS SO THE USER REALIZES THESE WERE NOT PART OF HIS PROGRAM
C
      IF(IANS.EQ.'Y'.AND.IMAX.LE.43)ISYMBL(2,IMAX,2)='**'
      WRITE(5,2001)(SYMBOL(IMAX,I),I=1,3)
2545  WRITE(6,2001)(SYMBOL(IMAX,I),I=1,3)
      IMAX=301
2546  IMAX=IMAX-1
C
C     CLOSE AND SORT THE FILES
C
      CALL CL$
      IONE=1
      I8=8
      I14=14
      I17=17
      CALL SUBSRT(TFILE1,6,TFILE1,6,IONE,IONE,I8,JUNK1,JUNK2)
      CALL SUBSRT(TFILE2,6,TFILE2,6,IONE,I14,I17,JUNK1,JUNK2)
C
C     OPEN TO THE END OF THE L_ FILE
C
      CALL OF1(1,TFILE1,6,1,$2548)
      CALL OF1(1,TFILE2,6,2,$2548)
      CALL OF1(3,LFILE,6,3,$2548)
      CALL OF1(11,0,0,3,$2548)
25470 IF(IANS.EQ.'Y')WRITE(7,25471)FORMFD
25471 FORMAT(A1)
      WRITE(7,25474)
      DO 25472 I=1,IMAX
      READ(5,2001)R1,R2,R3
      READ(6,2001)R4,R5,R6
25472 WRITE(7,25473)(SYMBOL(I,J),J=1,3),R1,R2,R3,R4,R5,R6
25473 FORMAT(3(2A4,5X,A4,10X))
25474 FORMAT(///'SYMBOL TABLE'//
     *'A LABEL INCLUDING ** MEANS IT IS AN INTEL'
     *' ROUTINE IN ROM'//
     *'ORDERED AS IN PROGRAM ',5X,
     *'ORDERED BY LABEL      ',5X,
     *'ORDERED BY HEX VALUE  '//)
C
C     NOW CLOSE ALL FILES AND DELETE THE TEMPORARY ONES
C
      CALL CL$
      CALL OF1(5,TFILE1,6,0,0)
      CALL OF1(5,TFILE2,6,0,0)
      CALL EXIT
2548  CALL OF1(5,LFILE,6,0,0)
2549  CALL EXIT
C
C *** EJCT ***
C
255   WRITE (6,65)LINECT,LINE
      WRITE(6,257)FORMFD
257   FORMAT (A1)
      GOTO 5
C
C *** SKIP ***
C
260   IERR=260
      IPRINT='SK'
265   WRITE(6,65)LINECT,LINE
      CALL POPS (LOOP,LINE,NUMDIG,IERR,IPRINT)
      GOTO 5
C
C *** DASH ***
C
270   IERR=270
      IPRINT='--'
      GOTO 265
C
C *** DOT ***
C
280   IERR=280
      IPRINT='..'
      GOTO 265
C
C *** EQU ***
C
290   WRITE (6,65)LINECT,LINE
      GOTO 5
      END
C
C
C
C     SUBROUTINE YESNO
C
      SUBROUTINE YESNO(IANS,IYES,INO)
10    CALL I$AA01(0,IANS,1,0)
      IANS=SHFT(IANS,8,-8)+:240
      IF(IANS.EQ.'Y')GO TO IYES
      IF(IANS.EQ.'N')GO TO INO
      CALL TNOUA('WHAT? ',6)
      GO TO 10
      END
C
C     SUBROUTINE CHKDIG
C
      SUBROUTINE CHKDIG(LINE,NUMDIG,LINECT,IRTN)
      INTEGER LINE(80),DIGITS(16),TYPES(11),MAXDIG(11)
      DATA TYPES/22HO Q : H   D B $ # ' L /
      DATA MAXDIG/8,8,8,16,10,10,2,10,256,256,32767/
      DATA DIGITS/'0 1 2 3 4 5 6 7 8 9 A B C D E F '/
      DO 5 ITYPE=1,11
      IF(LINE(19).EQ.TYPES(ITYPE))GO TO 8
5     CONTINUE
      WRITE(1,6)LINECT,LINE
6     FORMAT('ERROR IN LINE #',I5,' INVALID DATA SPECIFICATION IN',
     *' COLUMN 19'/'THE LINE WAS:'/80A1)
8     MAX=MAXDIG(ITYPE)
C
C     NOW LET'S RETURN IN THE EVENT THAT THE DATA TYPE IS A LABEL
C     OR AN ASCII CHARACTER
C
      IF(MAX.GT.16)RETURN
C
C     THE $ REQUIRES A SPECIAL SORT OF TEST
C
      IF(LINE(19).NE.'$')GO TO 9
      IF(LINE(21).GE.'0 '.AND.LINE(21).LE.'9 '.AND.
     *  (LINE(20).EQ.'+ '. OR.LINE(20).EQ.'- '))    RETURN
      GO TO 44
9     IF(NUMDIG.GT.0)GO TO 20
      WRITE(1,10)LINECT,LINE
10    FORMAT('ERROR IN LINE # ',I4, '  DATA REQUIRED IS NOT THERE'/
     *'THE LINE WAS:'/80A1)
      GO TO IRTN
C
C     AT LEAST THE NUMBER OF DIGITS IS POSITIVE
C     LET'S SEE IF THEY ARE VALID FOR THE CODE IN LINE (19)
C
20    DO 50 IDIGIT=1,NUMDIG
      DO 40 I=1,MAX
      IF(LINE(IDIGIT+19).EQ.DIGITS(I))GO TO 50
40    CONTINUE
44    WRITE(1,45)LINECT,LINE
45    FORMAT('ERROR IN LINE # ',I4,'  INVALID DIGIT - LINE WAS:'/
     *80A1)
      GO TO IRTN
50    CONTINUE
      RETURN
      END
C
C
C
      SUBROUTINE BACKUP(LUNIT,LINES)
      CALL PRWF$$(1,LUNIT,0,0,INTL(-1),IR,IERR)
      IF(IERR.NE.0)GO TO 40
10    CALL PRWF$$(:21,LUNIT,LOC(ICHAR),1,INTL(-2),IR,IERR)
      IF(IERR.NE.0)GO TO 40
      IF(SHFT(ICHAR,8).EQ.:212.OR.SHFT(ICHAR,-8,8).EQ.:212)GO TO 15
      GO TO 10
15    DO 30 I=1,LINES
20    CALL PRWF$$(:21,LUNIT,LOC(ICHAR),1,INTL(-2),IR,IERR)
      IF(IERR.NE.0)GO TO 40
      IF(SHFT(ICHAR,8).NE.:212.AND.SHFT(ICHAR,-8,8).NE.:212)GO TO 20
30    CONTINUE
      CALL PRWF$$(1,LUNIT,0,0,INTL(2),IR,IERR)
      IF(IERR.NE.0)CALL ERRPR$(0,IERR,0,0,0,0)
40    RETURN
      END
C
C
C
      SUBROUTINE HX2DEC(HEXVAL,SUM)
      INTEGER HEXNUM(4),NUMBER(16),HEXVAL(4)
      DATA NUMBER/'0 1 2 3 4 5 6 7 8 9 A B C D E F '/
      DO 15 J=1,4
      DO 10 I=1,16
      IF(HEXVAL(J).NE.NUMBER(I))GOTO 10
      HEXNUM(J)=I-1
      GOTO 15
10    CONTINUE
15    CONTINUE
      SUM=HEXNUM(4) + HEXNUM(3)*16. + HEXNUM(2)*256. + HEXNUM(1)*4096.
      RETURN
      END
C
C
C
      SUBROUTINE DEC2HX (ICHAR,ISTART)
      INTEGER NUMBER (16),ICHAR(4)
      REAL ISTART
      DATA NUMBER/'1 2 3 4 5 6 7 8 9 A B C D E F 0 '/
      DO 7 LOOP=1,4
7     ICHAR(LOOP)=0
      IF(ISTART .LT. 0) CALL EXIT
      REAL=ISTART
      ID1=0
      ID2=0
      ID3=0
      ID4=0
      ICALC=REAL/16
      IF (ICALC .NE. 0) GOTO 10
      ID1=REAL
      GOTO 40
10    ID1=REAL-ICALC*16
      ITEMP=ICALC/16
      IF (ITEMP .NE. 0) GOTO 20
      ID2=ICALC
      GOTO 40
20    ID2=ICALC-ITEMP*16
      ICALC=ITEMP/16
      IF(ICALC .NE. 0) GOTO 30
      ID3=ITEMP
      GOTO 40
30    ID3=ITEMP-ICALC*16
      ID4=ICALC
40    IF(ID1 .EQ. 0)ID1=16
      IF(ID2 .EQ.0)ID2=16
      IF(ID3.EQ.0)ID3=16
      IF(ID4.EQ.0)ID4=16
      ICHAR(1)=NUMBER(ID4)
      ICHAR(2)=NUMBER(ID3)
      ICHAR(3)=NUMBER(ID2)
      ICHAR(4)=NUMBER(ID1)
      RETURN
      END
C
C
C
      SUBROUTINE SWITCH (LINE,NUMDIG,KEY,SUM)
      INTEGER LINE(80),RNUMB(80)
      SUM=0.
      DO 10 I=1,80
10    RNUMB(I)=SHFT(LINE(I),8)-:260
C     CONVERTING TO A REAL NUMBER
      IPOWER=NUMDIG
      IPOS=19
      IEND=19+NUMDIG
25    IPOS=IPOS+1
      IPOWER=IPOWER-1
      IF(IPOWER.LT.0)RETURN
      SUM=SUM+(RNUMB(IPOS)*KEY**IPOWER)
      GOTO 25
      END
C
C
C
      SUBROUTINE EQUIV(LINE,SYMBOL)
      REAL SYMBOL,HELP
      INTEGER LINE(4),ALL(2)
      EQUIVALENCE(ALL(1),HELP)
      ALL(1)=LINE(1)-:240+SHFT(LINE(2),8)
      ALL(2)=LINE(3)-:240+SHFT(LINE(4),8)
      SYMBOL=HELP
      RETURN
      END
C
C
C
      SUBROUTINE IN8080(LINE,SYMBOL)
      INTEGER SYMBOL,HELP
      INTEGER LINE(2),ALL
      EQUIVALENCE(ALL,HELP)
      ALL=LINE(1)-:240+SHFT(LINE(2),8)
      SYMBOL=HELP
      RETURN
      END
C
C
C
      SUBROUTINE DEC20(LINE,ISUM)
      INTEGER LINE(80),RNUM(80)
      ISUM=0
      DO 10 I=1,80
10    RNUM(I)=SHFT(LINE(I),8)-:260
      ISUM=RNUM(21)
      RETURN
      END
C
C
C
      SUBROUTINE POPS(LOOP,LINE,NUMDIG,IERR,IPRINT)
      INTEGER LINE(80)
      DO 5 LOOP=20,50
      IF(LINE(LOOP).EQ.' ')GOTO 10
5     CONTINUE
      WRITE(1,7)IERR
7     FORMAT ('ERROR #',I3)
      CALL EXIT
10    NUMDIG=LOOP-20
      CALL SWITCH(LINE,NUMDIG,10,SUM)
      IF(IPRINT.EQ.'SK')GOTO 27
      IF(IPRINT .NE.'..'.AND.IPRINT.NE.'--')SUM=SUM*2.
      ISUM=SUM/2
      DO 15 LOOP=I,ISUM
      CALL PRWF$$(2,2,LOC(IPRINT),1,INTL(0),IR,IERR)
15    CONTINUE
      WRITE (6,25)
25    FORMAT (' ')
      RETURN
27    IPRINT=' '
      ISUM=SUM
      DO 30 IP=1,ISUM
      WRITE (6,28)
28    FORMAT (/)
30    CONTINUE
      RETURN
      END
C
C
C
      SUBROUTINE BLFILL (HXVAL,LINE)
      INTEGER HXVAL(4),LINE(80)
      DO 5 I=1,4
      HXVAL(I)='0'
5     CONTINUE
      IF(LINE(20).EQ.' ')RETURN
      IF(LINE(21).NE.' ')GOTO 20
      HXVAL(4)=LINE(20)
      WRITE (1,111)HXVAL
111   FORMAT (4A1)
      RETURN
20    IF(LINE(22).NE.' ')GOTO 30
      HXVAL(3)=LINE(20)
      HXVAL(4)=LINE(21)
      RETURN
30    IF(LINE(23).NE.' ')GOTO 40
      HXVAL(2)=LINE(20)
      HXVAL(3)=LINE(21)
      HXVAL(4)=LINE(22)
      RETURN
40    HXVAL(1)=LINE(20)
      HXVAL(2)=LINE(21)
      HXVAL(3)=LINE(22)
      HXVAL(4)=LINE(23)
      RETURN
      END
C
C
C
      SUBROUTINE POOL(SYMBOL,LINE,LINECT,LOOP,RLABEL,SLABEL,K,ERROR)
      DIMENSION SYMBOL(300,4),LINE(80)
      INTEGER ERROR
      CALL EQUIV(LINE(1),RLABEL)
      CALL EQUIV(LINE(5),SLABEL)
      K=0
      DO 10 LOOP=1,300
      IF(SYMBOL(LOOP,1).EQ.'XXXX')GOTO 18
      IF(SYMBOL(LOOP,1).NE.RLABEL)GOTO 10
      IF(SYMBOL(LOOP,2).EQ.SLABEL)GOTO 20
10    CONTINUE
      WRITE(1,15)LINECT,LINE
15    FORMAT('SYMBOL TABLE IS FULL. LINE# ',I3,' IS NOT ACCEPTED'/80A1)
      WRITE (6,16)LINE
16    FORMAT ('SYMBOL TABLE IS FULL'/80A1)
      GOTO 30
18    CALL EQUIV(LINE(1),SYMBOL(LOOP,1))
      CALL EQUIV(LINE(5),SYMBOL(LOOP,2))
      RETURN
20    WRITE(1,22)LINECT,LINE
      WRITE(6,22)LINECT,LINE
22    FORMAT ('DUPLICATE LABEL FOUND ON LINE # ',I3/80A1)
30    ERROR=ERROR+1
      K=1
      RETURN
      END
C
C
C
