C     COPYRIGHT 1977      MOSTEK CORPORATION
C
C
C     FORTRAN IV CROSS ASSEMBLER FOR THE Z80
C     XFOR-80 V1.1 03JUN77
C     COPYRIGHT 1977
C     MOSTEK CORPORATION
C     CARROLLTON, TEXAS
C
C
C     THE VARIABLES PASSED IN COMMON ARE DEFINED BELOW
C
C     ICRD  = LOGICAL INPUT UNIT NUMBER
C     IPRT  = LOGICAL OUTPUT UNIT NUMBER
C     IPCH  = LOGICAL OBJECT MODULE UNIT NUMBER
C     IMFLE = INTERMEDIATE FILE LOGICAL UNIT NUMBER
C     MCFLE = MACRO SOURCE FILE LOGICAL UNIT NUMBER
C     IMREC = RECORD NUMBER FOR INTERMEDIATE FILE
C     MCREC = RECORD NUMBER FOR MACRO SOURCE FILE
C     IOLIN = NUMBER OF LINES PER PAGE
C     IPAGE = OUTPUT PAGE COUNT
C     LINE  = OUTPUT LISTING LINE COUNT
C     IERRS = TOTAL NUMBER OF ERRORS
C     IFCOL = FIRST SOURCE COLUMN NUMBER
C     MCOL  = LAST SOURCE COLUMN NUMBER
C     MLAB  = MAXIMUM LABEL LENGTH IN CHARACTERS
C     MOPC  = MAXIMUM OPCODE LENGTH IN CHARACTERS
C     IBIT  = NUMBER OF BITS PER HOST COMPUTER WORD
C     ICCNT = NUMBER OF CHARACTERS PER HOST COMPUTER WORD
C     IWORD = NUMBER OF WORDS IN HOST COMPUTER PER LABEL
C     MXMAC = MAXIMUM NUMBER OF MACROS
C     MXPAR = MAXIMUM NUMBER OF PARAMETERS PASSED IN MACROS
C     ITAB  = SYMBOL TABLE
C     ITABV = NUMERIC VALUE OF SYMBOL (USUALLY AN ADDRESS)
C     INDEX = INDEX INTO THE SYMBOL TABLE
C     LTAB  = LENGTH OF SYMBOL TABLE
C     NAME  = SYMBOL BUFFER
C     ISSYM = DEFL SYMBOL FLAG
C     LABCT = SYMBOL CHARACTER COUNT
C     KWTYP = KEYWORD TYPE
C     KWVAL = KEYWORD VALUE
C     KWIND = KEYWORD INDEX
C     NJMP  = INSTRUCTION CLASS
C     LPAR  = LEADING PARENTHESIS FLAG
C     MLCOL = MAXIMUM SOURCE COLUMNS THAT WILL BE PRINTED
C     NSPAR = SCAN PARENTHESIS FLAG
C     MDISK = TABLE OF STARTING RECORD NUMBERS FOR MACROS
C     MPARC = NUMBER OF PARAMETERS IN A MACRO DEFINITION
C     MPARP = POINTERS TO BEGINNING AND END OF EACH MACRO PARAMETER
C     MCNAM = MACRO NAME TABLE
C     MCALL = MACRO CALL LINE BUFFER
C     MCNT  = MACRO COUNT (TOTAL NUMBER OF MACROS)
C     MSAVE = TEMPORARY STORAGE USED WHEN NESTING MACROS
C     MCSET = MACRO NESTING LEVEL NUMBER
C     MPCNT = MACRO PARAMETER COUNT (TOTAL NUMBER FOR ALL CALLS)
C     NBIN  = STRING BUFFER FOR CONST ROUTINE
C     ICNT  = OUT SUBROUTINE BYTE COUNT
C     IRLEN = RECORD LENGTH OF OBJECT RECORD
C     ICKSM = CHECK SUM OF OBJECT RECORD
C     LODLC = ADDRESS FOR OBJECT RECORD
C     IOBIN = STORAGE FOR OBJECT BYTES
C     ISN   = INTERNAL LINE COUNT
C     LISN  = OUTPUT LINE COUNT
C     MSREC = MACRO RECORD NUMBER
C     IEND  = END CARD INDICATOR
C     LLEN  = LENGTH OF BYTES IN ARGUMENT FIELD
C     IBIN  = ARRAY FOR ONE LINE OF OBJECT CODE
C     IADDR = OUTPUT BUFFER FOR PROGRAM COUNTER AND SYMBOL TALBE
C     LSOR  = FLAG TO INDICATE SOURCE WILL BE LISTED
C     LSYM  = FLAG TO INDICATE THE SYMBOL TABLE WILL BE LISTED
C     LMAC  = FLAG TO INDICATE MACROS WILL BE EXPANDED
C     LIF   = FLAG TO INDICATE WHETHER IF STATEMENTS WILL BE EXPANDED
C     LOBJ  = FLAG TO INDICATE OBJECT MODULE WILL BE PUNCHED
C     LREF  = FLAG TO INDICATE CROSS REFERENCE TABLE WILL BE LISTED
C     LEVEL = CURRENT MACRO LEVEL NUMBER
C     LC    = LOCATION COUNTER
C     IPVAL = TEMPORARY STORAGE LOCATION
C     LEN   = LENGTH OF CURRENT INSTRUCTION IN BYTES
C     MAC   = INDICATES A MACRO IS CURRENTLY BEING PROCESSED
C     IOPVA = NUMERIC VALUE OF CURRENT OPCODE
C     IARG  = FIRST COLUMN OF ARGUMENT FIELD
C     IERRI = ERROR INDICATORS FOR OUTPUT
C     ITYPE = INSTRUCTION TYPE NUMBER
C     IN    = CARD IMAGE INPUT BUFFER
C     IERR  = ERROR STATUS INDICATOR
C     IAST  = HOST REPRESENTATION OF AN ASTERISK
C     IDOLR = HOST REPRESENTATION OF A DOLLAR SIGN
C     IQUOT = HOST REPRESENTATION OF A QUOTE CHARACTER
C     ICOLN = HOST REPRESENTATION OF A COLON
C     ISHRP = HOST REPRESENTATION OF SHARP SIGN
C     IBLNK = HOST REPRESENTATION OF A BLANK
C     ICOMM = HOST REPRESENTATION OF A COMMA
C     ISEMI = HOST REPRESENTATION OF A SEMICOLON
C     ICTAB = HOST REPRESENTATION OF HORIZONTAL TAB
C     IPER  = HOST REPRESENTATION OF PERIOD
C     IPLUS = HOST REPRESENTATION OF PLUS CHARACTER
C     IMIN  = HOST REPRESENTATION OF MINUS CHARACTER
C     IMULT = HOST REPRESENTATION OF AN ASTERISK
C     IDIV  = HOST REPRESENTATION OF A SLASH
C     IRPAR = HOST REPRESENTATION OF A RIGHT PARENTHESIS
C     ILPAR = HOST REPRESENTATION OF A LEFT PARENTHESIS
C     IEQUL = HOST REPRESENTATION OF EQUAL SIGN
C     IGRAT = HOST REPRESENTATION OF A GREATER THAN CHARACTER
C     ILESS = HOST REPRESENTATION OF A LESS THAN CHARACTER
C     IAMP  = HOST REPRESENTATION OF AMPERSAND
C     IVBAR = HOST REPRESENTATION OF VERTICAL BAR
C     IALPH = ASSEMBLER CHARACTER SET
C     LTITL - ARRAY FOR TITLE
C     ICHRA = HOST REPRESENTATION OF CHARACTER A
C     ICHRB = HOST REPRESENTATION OF CHARACTER B
C     ICHRC = HOST REPRESENTATION OF CHARACTER C
C     ICHRD = HOST REPRESENTATION OF CHARACTER D
C     ICHRE = HOST REPRESENTATION OF CHARACTER E
C     ICHRF = HOST REPRESENTATION OF CHARACTER F
C     ICHRH = HOST REPRESENTATION OF CHARACTER H
C     ICHRK = HOST REPRESENTATION OF CHARACTER K
C     ICHRL = HOST REPRESENTATION OF CHARACTER L
C     ICHRM = HOST REPRESENTATION OF CHARACTER M
C     ICHRN = HOST REPRESENTATION OF CHARACTER N
C     ICHRO = HOST REPRESENTATION OF CHARACTER O
C     ICHRQ = HOST REPRESENTATION OF CHARACTER Q
C     ICHRR = HOST REPRESENTATION OF CHARACTER R
C     ICHRS = HOST REPRESENTATION OF CHARACTER S
C     ICHRT = HOST REPRESENTATION OF CHARACTER T
C     ICHRU = HOST REPRESENTATION OF CHARACTER U
C     ICHRV = HOST REPRESENTATION OF CHARACTER V
C     ICHRY = HOST REPRESENTATION OF CHARACTER Y
C     MXREF = SIZE OF CROSS REFERENCE ARRAY
C     IXTAB = CROSS REFERENCE ARRAY
C     IXT   = CROSS REFERENCE DISK RECORD
C     IXPNT = POINTER INTO CROSS REFERENCE TABLE
C     IXCNT = NUMBER OF CROSS REFERENCE PAGES
C     IXPAG = MAXIMUM NUMBER OF CROSS REFERENCE PAGES
C     IPASS = PASS INDICATOR
C     MCORE = BUFFER USED TO WRITE CROSS REFERENCE DISK FILE
C
C
C
C     THE MAIN ROUTINE CALLS THE MAJOR SUBROUTINES
C
C
      REAL LC,LODLC,IPVAL,ITABV(200)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
C
C     THE FOLLOWING DEFINE FILE STATEMENTS DEFINE THE INTERMEDIATE
C     FILE AND THE MACRO SOURCE FILE USED BY THIS ASSEMBLER.  THESE ARE
C     STANDARD IBM STATEMENTS.  THE INTERMEDIATE FILE DEFINED (SYMBOLIC
C     FILE NUMBER 2) CONSISTS OF 2000 94-WORD RECORDS.  U INDICATES A
C     BINARY FILE.  THE NAME IMREC IS THE RECORD INDEX.  THE MACRO
C     SOURCE FILE IS DEFINED IN A SIMILAR MANNER.
C     VARIOUS COMPUTERS DEFINE FILES IN DIFFERENT WAYS.  THIS FILE
C     MIGHT HAVE TO BE DEFINED DIFFERENTLY ON YOUR COMPUTER.
C     ALSO NOTE THAT THE INTERMEDIATE FILE COULD BE A TAPE FILE.
C
      DEFINE FILE 2(2000,93,U,IMREC)
      DEFINE FILE 4(200,128,U,MCREC)
      CALL INIT
      CALL PASS1
      CALL PASS2
      IF(LSYM+LREF) 400,400,100
100   WRITE(IPRT,1000) (LTITL(I),I=1,28),IPAGE
1000  FORMAT(34H1   MOSTEK XFOR-80 CROSS ASSEMBLER,
     1  1X,28A1,5H PAGE,I4,//)
      IF(LREF) 200,200,250
200   WRITE(IPRT,1010)
1010  FORMAT(32X,12HSYMBOL TABLE,/)
      LINE = 4
      GO TO 300
250   WRITE(IPRT,1011)
1011  FORMAT(30X,15HCROSS REFERENCE,//,
     1  15H LABEL    VALUE,7X,9HREFERENCE,/)
      LINE = 6
300   CALL SYMTA
400   WRITE(IPRT,1001)
1001  FORMAT(1H1)
      STOP
      END
      SUBROUTINE INIT
C
C     THIS SUBROUTINE INITIALIZES THE
C     VARIABLES USED BY THE ASSEMBLER
C
      REAL LC,LODLC,IPVAL,ITABV(200)
      DIMENSION NALPH(62)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
C
C     SOME COMPUTERS DO NOT ACCEPT THE FULL ASCII CHARACTER SET.
C     THEREFORE SOME OF THE CHARACTERS DEFINED BELOW MAY BE ILLEGAL
C     ON YOUR MACHINE.  IF THIS IS THE CASE, THE ILLEGAL CHARACTERS
C     SHOULD BE REPLACED BY VALID CHARACTERS.  IF THE ILLEGAL CHARACTERS
C     ARE NOT USED IN THE ASSEMBLER LANGUAGE, REPLACE THEM WITH BLANKS.
C     IF THE ILLEGAL CHARACTERS ARE USED IN THE ASSEMBLER LANGUAGE,
C     REPLACE THEM WITH ANY OTHER VALID CHARACTERS.
C     THE ILLEGAL CHARACTERS MUST BE CHANGED IN THE FOLLOWING TWO DATA
C     ARRAYS.
C
      DATA NALPH( 1),NALPH( 2),NALPH( 3),NALPH( 4) /1H0,1H1,1H2,1H3/
      DATA NALPH( 5),NALPH( 6),NALPH( 7),NALPH( 8) /1H4,1H5,1H6,1H7/
      DATA NALPH( 9),NALPH(10),NALPH(11),NALPH(12) /1H8,1H9,1HA,1HB/
      DATA NALPH(13),NALPH(14),NALPH(15),NALPH(16) /1HC,1HD,1HE,1HF/
      DATA NALPH(17),NALPH(18),NALPH(19),NALPH(20) /1HG,1HH,1HI,1HJ/
      DATA NALPH(21),NALPH(22),NALPH(23),NALPH(24) /1HK,1HL,1HM,1HN/
      DATA NALPH(25),NALPH(26),NALPH(27),NALPH(28) /1HO,1HP,1HQ,1HR/
      DATA NALPH(29),NALPH(30),NALPH(31),NALPH(32) /1HS,1HT,1HU,1HV/
      DATA NALPH(33),NALPH(34),NALPH(35),NALPH(36) /1HW,1HX,1HY,1HZ/
      DATA NALPH(37),NALPH(38),NALPH(39),NALPH(40) /1H!,1H%,1H?,1H@/
      DATA NALPH(41),NALPH(42),NALPH(43),NALPH(44) /1H_,1H ,1H",1H#/
      DATA NALPH(45),NALPH(46),NALPH(47),NALPH(48) /1H$,1H&,1H',1H(/
      DATA NALPH(49),NALPH(50),NALPH(51),NALPH(52) /1H),1H*,1H+,1H,/
      DATA NALPH(53),NALPH(54),NALPH(55),NALPH(56) /1H-,1H.,1H/,1H:/
      DATA NALPH(57),NALPH(58),NALPH(59),NALPH(60) /1H;,1H<,1H=,1H>/
      DATA NALPH(61),NALPH(62)                     /1H^,1H]/
      DATA NCHRA,NCHRB,NCHRC,NCHRD,NCHRE /1HA,1HB,1HC,1HD,1HE/
      DATA NCHRF,NCHRH,NCHRK,NCHRL,NCHRM /1HF,1HH,1HK,1HL,1HM/
      DATA NCHRN,NCHRO,NCHRQ,NCHRS,NCHRT /1HN,1HO,1HQ,1HS,1HT/
      DATA NCHRU,NCHRV,NCHRY /1HU,1HV,1HY/
      DATA NBLNK,NQUOT,NPLUS,NMIN,NGRAT /1H ,1H',1H+,1H-,1H>/
      DATA NLESS,NDOLR,NCOMM,NAST,NSEMI /1H<,1H$,1H,,1H*,1H;/
      DATA NCOLN,NSHRP,NCTAB,NPER,NAMP /1H:,1H#,1H ,1H.,1H&/
      DATA NMULT,NDIV,NLPAR,NRPAR,NEQUL /1H*,1H/,1H(,1H),1H=/
      DATA NVBAR,NRSLA /1H^,1H]/
C
C     DEFINE OBJECT,INPUT,OUTPUT,INTERMEDIATE AND MACRO FILES
C
      IPCH = 3
      ICRD = 1
      IPRT = 6
      IMFLE = 2
      MCFLE = 4
C
C     TO INCREASE THE SIZE OF THE SYMBOL TABLE AND THUS THE
C     NUMBER AND LENGTH OF THE SYMBOLS USED BY THE ASSEMBLER
C     THE USER MUST CHANGE CERTAIN VARIABLES.  THE VARIABLES
C     THAT MUST BE CHANGED DEPEND ON THE NUMBER OF BITS
C     PER WORD FOR YOUR COMPUTER, THE NUMBER OF CHARACTERS
C     USED TO DEFINE A SYMBOL, AND THE NUMBER OF SYMBOLS IN THE
C     SYMBOL TABLE.  THE VARIABLES THAT DEFINE THESE
C     CHARACTERISTICS ARE - IBIT,MLAB,ICCNT,IWORD,LTAB.
C
C     IBIT = NUMBER OF BITS PER HOST COMPUTER WORD (SET BY USER)
C     MLAB  = MAXIMUM LABEL LENGTH IN CHARACTERS (SET BY USER)
C     ICCNT = NUMBER OF CHARACTERS PER HOST COMPUTER WORD (CALCULATED)
C     IWORD = NUMBER OF COMPUTER WORDS PER LABEL (CALCULATED)
C     LTAB  = LENGTH OF THE SYMBOL TABLE (SET BY USER)
C     THUS THE FOLLOWING VARIABLES MUST BE CHANGED OR DIMENSIONED
C     AS FOLLOWS TO CHANGE THE SIZE OF THE SYMBOL TABLE
C     TO CHANGE THE SIZE OF A SYMBOL OR THE SYMBOL TABLE
C
C     LTAB
C     ITAB(IWORD,LTAB)
C     ITABV(LTAB)
C     NAME(IWORD)
C     MCNAM(IWORD,MXMAC)
C
C     TO INCREASE THE TOTAL NUMBER OF PARAMETERS THAT MAY BE
C     USED AMONG ALL NESTED MACROS CHANGE THE FOLLOWING VARIABLES
C
C     MXPAR
C
C     TO INCREASE THE NUMBER OF MACROS THAT MAY BE DEFINED
C     THE USER MUST CHANGE CERTAIN VARIABLES.  THESE VARIABLES
C     ARE AS FOLLOWS
C
C     MXMAC
C     MDISK(MXMAC)
C     MPARC(MXMAC)
C     MCNAM(IWORD,MXMAC)
C     MPARP(2,MXPAR)
C     TO INCREASE PAGE SIZE OF CROSS REFERENCE TABLE OR TOTAL
C     NUMBER OF PAGES PRODUCED OR TO NOT USE DISK TO STORE
C     REFERENCES, THE FOLLOWING VARIABLES MUST BE CHANGED.
C
C     MXREF = MAXIMUM PAGE SIZE OF CROSS REFERENCE TABLE.  THE
C     NUMBER OF REFERENCES ON A PAGE IS (MXREF/2).  MXREF SHOULD BE
C     GREATER THAN OR EQUAL TO (2*MLAB) AND DIVISIBLE BY 128.
C     IXTAB = ARRAY TO ACCUMULATE CROSS REFERENCES
C     IXPAG = TOTAL NUMBER OF PAGES OF SIZE MXREF THAT WILL BE
C     PRODUCED BEFORE ACCUMULATING REFERENCES STOPS.  IF
C     IXPAG = 0, THEN THE DISK FILE WILL NOT BE USED AND REFERENCES
C     WILL ONLY BE ACCUMULATED IN MEMORY UNTIL FULL.
C
C     TO INCREASE CROSS REFERENCE PAGE SIZE THE FOLLOWING SHOULD BE
C     CHANGED.
C
C     MXREF
C     IXTAB(MXREF)
C
C
      IBIT = 16
      MLAB = 6
      ICCNT = IBIT/8
      IWORD = 1+(MLAB-1)/ICCNT
      LTAB = 200
      IFCOL = 1
      MCOL = 72
      MOPC = 5
      MXMAC = 50
      MXPAR = 60
      NSPAR = 0
      LC = 0
      LODLC = -1.
      MSREC = 1
      ISN = 1
      LISN = 0
      IOLIN = 56
C     TO CHANGE OUTPUT LINE SIZE SET MLCOL TO (OUTPUT WIDTH-24)
C     ILCOL SHOULD NOT BE SET GREATER THAN 80.
      MLCOL = 48
      LINE = IOLIN
      IERRS = 0
      IPAGE = 1
      LSOR = 1
      LSYM = 1
      LMAC = 0
      LIF = 0
      LOBJ = 1
      LREF = 0
      IXPAG = 25
      MXREF = 1024
      IXT = 1
      IXPNT = 0
      IXCNT = 0
C     INITIALIZE THE SYMBOL TABLE TO ZEROS
      DO 20 LL=1,LTAB
      DO 30 K=1,IWORD
      ITAB(K,LL) = 0
30    CONTINUE
      ITABV(LL) = 0.
20    CONTINUE
C     INITIALIZE THE CHARACTER VARIABLES
      DO 40 K=1,62
      IALPH(K) = NALPH(K)
40    CONTINUE
C
C     THE CHARACTERS LISTED BELOW ARE CHARACTERS USED INTERNALLY BY
C     THE ASSEMBLER FOR ERROR CODES AND SYNTAX.
C
      ICHRA = NCHRA
      ICHRB = NCHRB
      ICHRC = NCHRC
      ICHRD = NCHRD
      ICHRE = NCHRE
      ICHRF = NCHRF
      ICHRH = NCHRH
      ICHRK = NCHRK
      ICHRL = NCHRL
      ICHRM = NCHRM
      ICHRN = NCHRN
      ICHRO = NCHRO
      ICHRQ = NCHRQ
      ICHRS = NCHRS
      ICHRT = NCHRT
      ICHRU = NCHRU
      ICHRV = NCHRV
      ICHRY = NCHRY
      IAST = NAST
      IDOLR = NDOLR
      IQUOT = NQUOT
      ICOLN = NCOLN
      ISHRP = NSHRP
      IBLNK = NBLNK
      ICOMM = NCOMM
      ISEMI = NSEMI
      ICTAB = NCTAB
      IPER = NPER
      IPLUS = NPLUS
      IMIN = NMIN
      IMULT = NMULT
      IDIV = NDIV
      IRPAR = NRPAR
      ILPAR = NLPAR
      IRSLA = NRSLA
      IEQUL = NEQUL
      IGRAT = NGRAT
      ILESS = NLESS
      IAMP = NAMP
      IVBAR = NVBAR
      DO 200 LL=1,50
      LTITL(LL) = IBLNK
200   CONTINUE
      RETURN
      END
      SUBROUTINE INOUT(ICTL)
C
C
C     THIS ROUTINE PERFORMS ALL I/O FOR THE PROGRAM EXCEPT
C     FOR THE FINAL OUTPUT LISTING.  THESE STATEMENTS MAY
C     HAVE TO CHANGE ON SOME MACHINES PARTICULARILY FOR DISK
C     I/O.  TWO STATEMENTS ARE SHOWN FOR EACH DISK I/O
C     OPERATION.  A STANDARD READ OR WRITE AS USED BY IBM, DEC
C     AND SOME OTHERS, AND A CALL TO A SYSTEM I/O ROUTINE
C     AS USED BY H.P. AND SOME OTHERS.(FOR INFORMATIVE PURPOSES)
C     THE RECORD NUMBER FOR RANDOM ACCESS I/O IS PASSED INTO THE
C     ROUTINE VIA COMMON.
C
C
      REAL LC,LODLC,IPVAL,ITABV(200)
      DIMENSION NAMEI(3),NAMEM(3),MCBUF(80),IMBUF(93)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
      EQUIVALENCE(LC,IMBUF(1))
      EQUIVALENCE (NBIN(1),MCBUF(1))
      DATA NAMEI(1),NAMEI(2),NAMEI(3) /2HIM,2HFL,2HE /
      DATA NAMEM(1),NAMEM(2),NAMEM(3) /2HMC,2HFL,2HE /
C
C     *ENTRY PARAMETERS
C     ICTL - I/O CONTROL WORD
C        1 = READ SOURCE
C        2 = READ INTERMEDIATE RECORD
C        3 = READ MACRO RECORD
C        4 = READ CROSS REFERENCE RECORD
C        5 = WRITE INTERMEDIATE RECORD
C        6 = WRITE MACRO RECORD
C        7 = WRITE CROSS REFERENCE RECORD
C
      GO TO(100,200,300,400,500,600,700),ICTL
C
C     READ SOURCE
100   READ(ICRD,1000) IN
1000  FORMAT(80A1)
      RETURN
C     READ INTERMEDIATE FILE
200   READ(IMFLE'IMREC) IMBUF
C     CALL EXEC(14,1091,IMBUF,93,NAMEI,IMREC)
      RETURN
C     READ MACRO FILE
300   READ(MCFLE'MCREC) MCBUF
C     CALL EXEC(14,1091,MCBUF,80,NAMEM,MCREC)
      RETURN
C     READ CROSS REFERENCE FILE
400   READ(MCFLE'MCREC) MCORE
C     CALL EXEC(14,1091,MCORE,128,NAMEM,MCREC)
      RETURN
C     WRITE INTERMEDIATE FILE
500   WRITE(IMFLE'IMREC) IMBUF
C     CALL EXEC(15,1091,IMBUF,93,NAMEI,IMREC)
      RETURN
C     WRITE MACRO FILE
600   WRITE(MCFLE'MCREC) MCBUF
C     CALL EXEC(15,1091,MCBUF,80,NAMEM,MCREC)
      RETURN
C     WRITE CROSS REFERENCE FILE
700   WRITE(MCFLE'MCREC) (IXTAB(J),J=1,128)
C     CALL EXEC(15,1091,IXTAB,128,NAMEM,MCREC)
      RETURN
      END
      SUBROUTINE PASS1
C
C
C     THIS SUBROUTINE EXECUTES THE PSEUDO-OPS THAT NEED TO BE EXECUTED
C     DURING PASS 1, PROCESSES SYMBOLS IN THE LABEL FIELD, STORES
C     INFORMATION IN THE INTERMEDIATE FILE WHICH IS USED DURING PASS 2,
C     STORES THE MACRO DEFINITIONS ON THE MACRO SOURCE FILE, AND
C     INCREMENTS THE LOCATION COUNTER FOR EACH INSTRUCTION MAKING ROOM
C     FOR THE RESULTING OBJECT CODE.
C
C
      REAL IVAL,LENBS
      REAL LC,LODLC,IPVAL,ITABV(200)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
      DATA LISTS /1HI/
C
C     *ENTRY PARAMETERS
C     VARIABLES IN COMMON INITIALIZED IN INIT
C
C     *EXIT PARAMETERS
C     SOURCE LINE ALONG WITH PROGRAM COUNTER,INSTRUCTION LENGTH
C     INSTRUCTION TYPE, ETC. WRITTEN TO INTERMEDIATE FILE.
C
      IPASS = 1
      LISN = 1
      MAC = 1
      IEND = 0
      IMREC = 1
      MCREC = 1
      LEVEL = 0
      IERR = 1
C     INITIALIZE IF STATEMENT NESTING LEVEL NUMBER
      IFSET = 0
      IFON = 0
C     INITIALIZE CURRENT NESTING LEVEL
      MCSET = 0
C     INITIALIZE IF STATEMENT FLAG
      IFCTL = 0
C     INITIALIZE CURRENT LEVEL NUMBER
      LEVEL = 0
C     INITIALIZE TOTAL MACRO COUNT
      MCNT = 0
C     INITIALIZE TOTAL MACRO PARAMETER COUNT
      MPCNT = 0
      IPVAL = 0
C     INITIALIZE NUMBER OF PARAMETERS FOR CURRENT MACRO
      NOPAR = 0
C     INITIALIZE ERROR INDICATORS
100   IERRI(1) = IBLNK
      IERRI(2) = IBLNK
      IERRI(3) = IBLNK
      IERRI(4) = 0
      IOPVA = 0
      LEN = 0
      INDEX = 0
      ITYPE = 0
C     INITIALIZE INDEX INTO SYMBOL TABLE
      INDET = 0
C     INITIALIZE CURRENT COLUMN NUMBER
      ICOL = IFCOL
C     INITIALIZE BYTE COUNT FOR DEFS DIRECTIVE
      LENBS = 0
      IF(MAC-1) 110,110,120
C     READ SOURCE FROM INPUT DEVICE
110   CALL INOUT(1)
      GO TO 130
C     READ SOURCE FROM MACRO DEFINITION
120   CALL MCREF
      LISN=LISN-1
      IF(IERRI(4)-1) 125,135,125
125   IMERR = IERR
C     CHECK FOR A COMMENT OR ASSEMBLER COMMAND
130   IF (IN(ICOL)-IAST) 132,135,132
132   IF(IN(ICOL)-ISEMI) 136,135,136
135   ITYPE = -1
      IF (IFCTL-2) 805,195,805
C     CHECK FOR A LABEL
136   IF(IN(ICOL)-IBLNK) 137,160,137
137   IF(IN(ICOL)-ICTAB) 138,160,138
138   IF(INDET) 139,139,910
C     GET AND PROCESS LABEL
139   CALL LABEL(ICOL,IVAL,0)
      IF (IFCTL-2) 140,160,140
C     IF NEXT CHARACTER IS NOT BLANK OR COLON, LABEL IS IN ERROR
140   IF (IN(ICOL)-IBLNK) 141,145,141
141   IF (IN(ICOL)-ICOLN) 142,144,142
142   IF (IN(ICOL)-ISEMI) 143,145,143
143   IF (IN(ICOL)-ICTAB) 900,145,900
144   ICOL=ICOL+1
145   GO TO (970,146,900,925),IERR
146   DO 147 I=1,IWORD
      ITAB(I,INDEX) = NAME(I)
147   CONTINUE
150   ITABV(INDEX) = LC
155   INDET = INDEX
      CALL XREFT(0,0)
      LDUP = IERR
      IERR = IMERR
C     GET OPCODE FIELD.
160   CALL OPCOD(ICOL,ICHK)
180   IF(IFCTL-2) 185,190,185
185   GO TO(200,910,910,135,187,138),IERR
C     NO OPCODE ON LINE, CHECK IF LABEL PRESENT
187   IERR = 2
      IF(INDET) 800,910,800
C     CHECK IF THIS IS AN IF LOOP AND THESE LINE ARE TO BE SKIPPED
C     CHECK FOR ENDIF DIRECTIVE
190   IF(ICHK-1015) 192,450,192
192   IF(ICHK-1006) 193,360,193
193   IF(ICHK-1014) 195,194,195
194   IFSET = IFSET+1
C     CHECK IF SKIPPED IF LINES ARE TO BE LISTED
195   IF(LIF) 196,100,196
196   LEN = 0
      ITYPE = -1
      GO TO 805
C
C     IF AN ASSEMBLER DIRECTIVE OR A MACRO REFERENCE WAS THE OPERATION
C     PROCESS IT NOW IF NECESSARY, OTHERWISE PROCESS IT IT PASS 2
C
200   ICOL = IARG
      IF(ITYPE-2) 300,600,250
250   CALL CODEZ(ICOL)
      GO TO 805
300   GO TO(310,320,330,340,350,360,370,800,390,
     1  400,410,420,430,440,450,460,470,480),IOPVA
C     ***** PROCESS THE ORG DIRECTIVE
310   CALL SCAN(ICOL,IVAL)
311   GO TO(312,950,940,312,930),IERR
312   LC = IVAL
C     SET VALUE IF ORG HAS A LABEL
      IF(IERRI(1)-ICHRD) 315,800,315
315   IF(INDET) 800,800,316
316   ITABV(INDET) = LC
      GO TO 800
C     ***** PROCESS THE EQU DIRECTIVE
320   IF(IERRI(1)-ICHRD) 321,800,321
321   IF(INDET) 960,960,322
322   IOPVA = -INDET
      CALL SCAN(ICOL,IVAL)
      GO TO(324,323,323,324,323),IERR
C     SET VALUE TO ZERO IF THERE IS AN ERROR
323   IPVAL = 0
      ITABV(INDET) = 0
      GO TO 311
324   IPVAL = IVAL
      ITABV(INDET) = IVAL
      GO TO 800
C     ***** PROCESS THE DEFB DIRECTIVE
330   LEN = 1
      GO TO 800
C     ***** PROCESS THE DEFS DIRECTIVE
340   CALL SCAN(ICOL,IVAL)
      GO TO (342,950,940,342,930),IERR
342   LENBS = IVAL
      GO TO 800
C     **** PROCESS THE DEFW DIRECTIVE
350   LEN = 2
      GO TO 800
C     ***** PROCESS THE END DIRECTIVE
360   IEND = 1
      GO TO 800
C     ***** PROCESS THE EJEC DIRECTIVE
370   GO TO 800
C     ***** PROCESS THE LIST DIRECTIVE
390   LSET = 1
392   IF(IARG-MCOL) 393,393,800
393   ICOL = IARG
394   IF(IN(ICOL)-LISTS) 398,397,398
397   LIF = LSET
398   ICOL1 = ICOL+1
      ICOL = ICOL1+1
      IF(IN(ICOL1)-ICOMM) 800,394,800
C     ***** PROCESS NLIST DIRECTIVE
400   LSET = 0
      GO TO 392
C     ***** PROCESS THE SPAC DIRECTIVE
410   GO TO 800
C     ***** PROCESS THE DEFL DIRECTIVE
420   IF(INDET) 960,960,421
421   IOPVA = -INDET
      IF(IERRI(1)-IBLNK) 422,424,422
422   IF(ISSYM) 800,800,423
423   IERRI(1) = IBLNK
      IERRI(4) = 0
      IERRS = IERRS-1
424   CALL SCAN(ICOL,IVAL)
      GO TO(425,950,940,425,930),IERR
425   IPVAL = IVAL
      ITABV(INDET) = IVAL+100000.
      GO TO 800
C     ***** PROCESS THE TITLE DIRECTIVE
430   GO TO 800
C     ***** PROCESS THE IF DIRECTIVE
440   CALL SCAN(ICOL,IVAL)
      GO TO (442,950,940,442,930),IERR
442   IF(IVAL) 444,443,444
443   IFCTL = 2
      IFON = IFSET
444   IFSET = IFSET+1
      GO TO 800
C     ***** PROCESS THE ENDIF DIRECTIVE
450   IF(IFSET-1) 912,452,454
452   IFCTL = 1
454   IFSET = IFSET-1
      IF(IFSET-IFON) 456,455,456
455   IFCTL = 1
456   IF(IFCTL-2) 457,195,457
457   IFON = 0
      GO TO 800
C     ***** PROCESS THE MACR DIRECTIVE
460   IF(MAC-1) 4605,4605,912
4605  IF(MCNT-MXMAC) 461,925,925
461   IF(INDET) 960,960,4612
4612  IERR = LDUP
      IXPNT = IXPNT-2
      IF(MCNT) 4614,4625,4614
4614  DO 462 N=1,MCNT
C
      DO 4616 LL=1,IWORD
      IF(ITAB(LL,INDET)-MCNAM(LL,N)) 462,4616,462
4616  CONTINUE
      IERRI(1) = ICHRD
      IF(IERR-2) 990,4618,990
4618  ITAB(1,INDET) = 0
      GO TO 990
462   CONTINUE
4625  MCNT = MCNT+1
      DO 4630 LL=1,IWORD
      MCNAM(LL,MCNT) = ITAB(LL,INDET)
4630  CONTINUE
      IF(IERR-2) 4640,4650,4660
4640  IERRI(1) = IBLNK
      IERRI(4) = 0
      IERRS = IERRS-1
      GO TO 4660
4650  ITAB(1,INDET) = 0
4660  CALL MCDEF
      IF(IEND) 4670,100,4670
4670  ISN = ISN-1
      ITYPE = 1
      GO TO 800
C     ***** PROCESS THE ENDM DIRECTIVE
470   IF(MCSET) 912,912,472
472   MCREC = MSAVE(1,MCSET)
      MCSET = MCSET-1
      IF(MCSET) 476,476,474
474   NOPAR = MSAVE(2,MCSET)
      MPCNT = MPCNT-NOPAR
      GO TO 478
476   MAC = 1
      MPCNT = 0
478   IF(IERRI(4)) 100,100,805
C     ***** PROCESS THE DEFM DIRECTIVE
480   CALL CONST(ICOL,IVAL)
      LEN = LLEN
      GO TO 805
C
C     PROCESS A MACRO REFERENCE CALL. MACRO MUST BE EXPANDED
C     IOPVA INDICATES WHICH MACRO IS BEING CALLED.
C
600   IF(MCSET-3) 602,915,915
602   IF(MCSET) 604,604,603
603   MPCNT = MPCNT+NOPAR
604   LEVEL = LEVEL+1
      MCSET = MCSET+1
      MSAVE(1,MCSET) = MCREC
      MCREC = MDISK(IOPVA)
      NOPAR = MPARC(IOPVA)
      MSAVE(2,MCSET) = NOPAR
C     SET UP PARAMETER TABLE
605   DO 610 LL=1,80
      MCALL(LL,MCSET) = IN(LL)
610   CONTINUE
C     SET SYSTEM LEVEL NUMBER FOR #$YM SYMBOL
      ID = 4096
      L = LEVEL
      DO 612 LL=1,4
      N = 1+L/ID
      I = 81+LL
      MCALL(I,MCSET) = IALPH(N)
      L = L-(N-1)*ID
      ID = ID/16
612   CONTINUE
      MCALL(81,MCSET) = IBLNK
      LL = MPCNT+1
      MPARP(1,LL) = 82
      MPARP(2,LL) = 85
      IF(NOPAR-1) 660,660,614
614   DO 620 MM=2,NOPAR
      LL = LL+1
      IF(LL-MXPAR) 616,616,925
616   MPARP(1,LL) = 81
      MPARP(2,LL) = 81
620   CONTINUE
C     SCAN FOR PARAMETERS FROM MACRO REFERENCE CALL
      ICOL = IARG
      L = MPCNT+2
622   ISTA = ICOL
      IF(ISTA-MCOL) 624,660,660
624   NCHAR = IN(ICOL)
      IF(NCHAR-IBLNK) 626,644,626
626   IF(NCHAR-ISEMI) 628,644,628
628   IF(NCHAR-ICTAB) 630,644,630
630   IF(NCHAR-ICOMM) 632,644,632
632   IF(NCHAR-IQUOT) 634,636,634
634   ICOL = ICOL+1
      IF(ICOL-MCOL) 624,624,644
C     SCAN OVER QUOTE STRING
636   ICOL = ICOL+1
      IF(IN(ICOL)-IQUOT) 642,638,642
638   ICOL1 = ICOL+1
      IF(IN(ICOL1)-IQUOT) 634,640,634
640   ICOL = ICOL1
642   IF(ICOL-MCOL) 636,644,644
644   IF(ISTA-ICOL) 646,652,646
C     CHECK FOR OUTER QUOTES ON PARAMETER
646   IF(IN(ISTA)-IQUOT) 650,648,650
648   MPARP(1,L) = ISTA+1
      MPARP(2,L) = ICOL-2
      GO TO 652
650   MPARP(1,L) = ISTA
      MPARP(2,L) = ICOL-1
C     CHECK FOR END OF PARAMETER LIST
652   IF(IN(ICOL)-ICOMM) 660,654,660
654   ICOL = ICOL+1
      L = L+1
      IF(L-(NOPAR+MPCNT)) 622,622,660
660   GO TO 800
C
C     CHECK FOR AN EXPRESSION ERROR
800   IF(IERR-4) 805,980,805
805   IMREC = ISN
      ISN = ISN+1
C     WRITE RECORD TO INTERMEDIATE FILE
      CALL INOUT(5)
      IF(ITYPE-2) 815,810,815
810   MAC = 2
815   IVAL = LEN
      LISN = LISN+1
      LC = LC+IVAL+LENBS
      IF(LC-65536.) 830,820,820
820   LC = LC-65536.
C     CHECK FOR END CARD OR END OF FILE
830   IF(IEND) 840,100,840
840   RETURN
C     SET ERROR INDICATORS INTO THE OUTPUT VARIABLES
C     LABEL ERROR
900   IERRI(1) = ICHRL
C     INCREMENT PC BY 3 TO PROVIDE FOR A PATCH
905   LEN = 4
      GO TO 990
C     OPCODE ERROR
910   LEN = 4
912   IERRI(2) = ICHRO
      GO TO 990
C     MACRO NESTING ERROR
915   IERRI(2) = ICHRN
      GO TO 990
C     TABLE OVERFLOW ERROR
925   IERRI(2) = ICHRT
      GO TO 990
C     SYNTAX ERROR - ILLEGAL EXPRESSION
930   IERRI(2) = ICHRS
      GO TO 990
C     ARGUMENT ERROR - UNDEFINED SYMBOL
940   IERRI(2) = ICHRU
      GO TO 990
C     ARGUMENT ERROR
950   IERRI(2) = ICHRA
      GO TO 990
C     MISSING LABEL ON EQU OR DEFL OR MACR DIRECTIVE
960   IERRI(1) = ICHRM
      GO TO 990
C     DUPLICATE LABEL ERROR
970   IERRI(1) = ICHRD
      IERRS = IERRS+1
      IERRI(4) = 1
      GO TO 155
C     FORMAT ERROR
980   IERRI(2) = ICHRF
990   IERRS = IERRS+1
      IERRI(4) = 1
      IERR = 1
      GO TO 800
      END
      SUBROUTINE PASS2
C
C
C     THIS ROUTINE PROCESSES INSTRUCTION ARGUMENTS, GENERATES OBJECT
C     CODE, EXECUTES ALL PSEUDO-OPS NOT EXECUTED IN PASS 1, AND
C     GENERATES THE OUTPUT LISTING.
C
C
      REAL IVAL,IVAL2
      REAL LC,LODLC,IPVAL,ITABV(200)
      DIMENSION LCTL(6),LISTS(6)
C
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
      EQUIVALENCE(LCTL(1),LSOR)
      DATA LISTS(1),LISTS(2),LISTS(3) /1HS,1HT,1HM/
      DATA LISTS(4),LISTS(5),LISTS(6) /1HI,1HO,1HX/
C
C     *ENTRY PARAMETERS
C     INFORMATION FROM INTERMEDIATE FILE
C
C     *EXIT PARAMETERS
C     OUTPUT LISTING AND OBJECT MODULE PRODUCED
C
      IPASS = 2
      ISN = 1
      LISN = 0
      IEND = 0
      LINE = IOLIN
1     IMREC = ISN
      ISN = ISN+1
C
C     READ NEXT RECORD FROM INTERMEDIATE FILE
      CALL INOUT(2)
      IBIN(1) = IOPVA
      IBIN(2) = 0
      IBIN(3) = 0
      IBIN(4) = 0
      MODE = 1
      IF(ITYPE) 450,800,20
20    IF(ITYPE-2) 500,800,100
C
C     PROCESS OPCODES
100   CALL CODEZ(IARG)
      GO TO(800,910,900,800,930,960,970,940),IERR
C
C     CHECK IF ASSEMBLER COMMAND
450   ICOL = IFCOL
      IARG = MCOL
      IF(IN(ICOL)-IAST) 800,452,800
452   ICOL = ICOL+1
      NCHAR = IN(ICOL)
C     CHECK IF EJECT
      IF(NCHAR-ICHRE) 454,570,454
C     SCAN TO ARGUMENT
454   ICOL = ICOL+1
      IF(IN(ICOL)-IBLNK) 454,456,454
456   ICOL = ICOL+1
      IF(ICOL-MCOL) 458,458,476
458   IF(IN(ICOL)-IBLNK) 460,456,460
460   IARG = ICOL-1
      IF(NCHAR-ICHRH) 462,630,462
462   LSET = 1
      IF(IN(ICOL)-ICHRO) 910,464,910
464   ICOL = ICOL+1
      IF(IN(ICOL)-ICHRF) 468,466,468
466   LSET = 0
C     CHECK FOR MACRO
468   IF(NCHAR-ICHRM) 472,470,472
470   LMAC = LSET
      GO TO 800
C     CHECK FOR LIST
472   IF(NCHAR-ICHRL) 910,474,910
474   LSOR = LSET
      GO TO 800
C     CHECK FOR HEADING
476   IF(NCHAR-ICHRH) 910,630,910
C
C     PROCESS ASSEMBLER DIRECTIVES (TYPE 1)
C
500   ITYPE = -1
      IF(IOPVA) 520,505,505
505   GO TO(510,520,530,540,550,560,570,800,590,600,610,620,
     1  630,640,650,660,670,680),IOPVA
C     ***** PROCESS ORG
510   GO TO 690
C     ***** PROCESS EQU DIRECTIVE
520   CALL SCAN(IARG,IVAL)
      INDEX = -IOPVA
      IF(INDEX) 805,805,525
525   ITABV(INDEX) = IPVAL
      IOPVA = 100
      GO TO 805
C     ***** PROCESS DEFB DIRECTIVE
530   IBIN(1) = 0
      ITYPE = 1
      IF(IARG-MCOL) 531,531,910
531   CALL SCAN(IARG,IVAL)
      GO TO(532,910,900,532,930),IERR
532   IF(IVAL-256.) 535,533,533
533   IF(IVAL-65280.) 940,534,534
534   IVAL = IVAL-65280.
535   IBIN(1) = IVAL
      GO TO 800
C     ***** PROCESS DEFS DIRECTIVE
540   ITYPE = 1
      GO TO 690
C     ***** PROCESS DEFW DIRECTIVE
550   IBIN(1) = 0
      ITYPE = 1
      IF(IARG-MCOL) 551,551,910
551   CALL SCAN(IARG,IVAL)
      GO TO(552,910,900,552,930),IERR
552   IBIN(2) = IVAL/256.
      IVAL2 = IBIN(2)
      IBIN(1) = IVAL-IVAL2*256.
      GO TO 800
C     ***** PROCESS END DIRECTIVE
560   IPVAL = 0.
      IEND = 1
      ITYPE = 1
      IF(IARG-MCOL) 561,561,800
561   CALL SCAN(IARG,IVAL)
      GO TO(562,910,900,562,930),IERR
562   IPVAL = IVAL
      GO TO 800
C     ***** PROCESS EJEC DIRECTIVE
570   MODE = 4
      IF(LSOR) 575,800,575
575   LINE = 100
      GO TO 800
C     ***** PROCESS LIST DIRECTIVE
590   LSET = 1
592   IF(IARG-MCOL) 594,594,910
594   DO 595 LL=1,6
      IF(IN(IARG)-LISTS(LL)) 595,596,595
595   CONTINUE
      GO TO 910
596   LCTL(LL) = LSET
      ICOL1 = IARG+1
      IARG = ICOL1+1
      IF(IN(ICOL1)-IBLNK) 597,800,597
597   IF(IN(ICOL1)-ICOMM) 598,594,598
598   IF(IN(ICOL1)-ICTAB) 910,800,910
C     ***** PROCESS NLIST DIRECTIVE
600   LSET = 0
      GO TO 592
C     ***** PROCESS SPAC DIRECTIVE
610   CALL SCAN(IARG,IVAL)
      GO TO (615,910,900,615,930),IERR
615   IARG = IVAL
      MODE = 3
      GO TO 800
C     ***** PROCESS DEFL DIRECTIVE
620   GO TO 520
C     ***** PROCESS TITLE DIRECTIVE
630   N = 1
      IF(IARG-MCOL) 631,631,635
631   IARG = IARG+1
      ICOL = IARG+49
      DO 633 J=IARG,ICOL
      IF(J-MCOL) 632,632,634
632   LTITL(N) = IN(J)
      N = N+1
633   CONTINUE
634   IF(N-50) 635,635,638
635   DO 636 J=N,50
      LTITL(J) = IBLNK
636   CONTINUE
C     CHECK IF *HEADING COMMAND
638   IF(IOPVA-13) 570,800,570
C     ***** PROCESS IF DIRECTIVE
640   GO TO 690
C     ***** PROCESS ENDIF DIRECTIVE
650   GO TO 800
C     ***** PROCESS MACR DIRECTIVE
660   GO TO 800
C     ***** PROCESS ENDM DIRECTIVE
670   GO TO 800
C     ***** PROCESS DEFM DIRECTIVE
680   IF(LEN) 910,910,681
681   ITYPE = 1
      CALL CONST(IARG,IVAL)
      IF(IERR-1) 683,683,682
682   IERRI(2) = ICHRA
      IERRI(4) = 1
      IERRS = IERRS+1
683   DO 684 LL=1,4
      IBIN(LL) = NBIN(LL)
      IF(LL-LLEN) 684,685,685
684   CONTINUE
685   CALL LOUT(MODE)
      LL = 0
686   LLEN = 0
687   LLEN = LLEN+1
      LL = LL+1
      IBIN(LLEN) = NBIN(LL)
      IF(LL-LEN) 688,689,689
688   IF(LLEN-4) 687,689,689
689   CALL OUT
      IVAL = LLEN
      LC = LC+IVAL
      IF(LL-LEN) 686,1,1
C     GET CROSS REFERENCES FOR PASS 2
690   IF(LREF) 800,800,692
692   CALL SCAN(IARG,IVAL)
      IERR = 1
C
800   IF(IERR-4) 805,920,805
805   LLEN = LEN
C     OUTPUT CURRENT LINE
      CALL LOUT(MODE)
C     OUTPUT OBJECT CODE
      IF(LLEN) 830,850,830
830   CALL OUT
C     CHECK FOR END CARD
850   IF(IEND) 855,1,855
855   CALL OUT
859   WRITE(IPRT,1002) IERRS
1002  FORMAT(//,27H   TOTAL ASSEMBLER ERRORS =,I5)
      RETURN
C
C     ASSEMBLER ERRORS
C
C     UNDEFINED LABEL IN ARGUMENT
900   IERRI(2) = ICHRU
      GO TO 990
C     ARGUMENT ERROR (MISSING OR ILLEGAL)
910   IERRI(2) = ICHRA
      GO TO 990
C     FORMAT ERROR
920   IERRI(2) = ICHRF
      GO TO 990
C     SYNTAX ERROR
930   IERRI(2) = ICHRS
      GO TO 990
C     VALUE ERROR - VALUE NOT WITHIN RANGE
940   IERRI(2) = ICHRV
      GO TO 990
C     KEYWORD ERROR
960   IERRI(2) = ICHRK
      GO TO 990
C     QUESTIONABLE OPERANDS
970   IERRI(2) = ICHRQ
990   IERRS = IERRS+1
      IERRI(4) = 1
      IERR = 1
      GO TO 800
      END
      SUBROUTINE OPCOD(ICOL,ICHK)
C
C
C     THE FOLLOWING DATA TABLE DEFINES ALL LEGAL MNEMONICS AND
C     DIRECTIVES.  EACH DATA STATEMENT CONSISTS OF FOUR OR FIVE
C     CHARACTERS REPRESENTING THE MNEMONIC OR DIRECTIVE, FOLLOWED BY
C     THE INSTRUCTION TYPE AND ITS DECIMAL NUMERIC EQUIVALENT.
C
C
      REAL LC,LODLC,IPVAL,ITABV(200)
      DIMENSION INST(5,81),INSTE(6,3)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
C
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
      DATA INST(1, 1),INST(2, 1),INST(3, 1),INST(4, 1),INST(5, 1)
     1  /1HJ,1HP,1H ,1H ,19194/
      DATA INST(1, 2),INST(2, 2),INST(3, 2),INST(4, 2),INST(5, 2)
     1  /1HC,1HA,1HL,1HL,18196/
      DATA INST(1, 3),INST(2, 3),INST(3, 3),INST(4, 3),INST(5, 3)
     1  /1HJ,1HR,1H ,1H ,17016/
      DATA INST(1, 4),INST(2, 4),INST(3, 4),INST(4, 4),INST(5, 4)
     1  /1HR,1HE,1HT,1H ,16192/
      DATA INST(1, 5),INST(2, 5),INST(3, 5),INST(4, 5),INST(5, 5)
     1  /1HI,1HN,1H ,1H ,15064/
      DATA INST(1, 6),INST(2, 6),INST(3, 6),INST(4, 6),INST(5, 6)
     1  /1HO,1HU,1HT,1H ,14065/
      DATA INST(1, 7),INST(2, 7),INST(3, 7),INST(4, 7),INST(5, 7)
     1  /1HA,1HD,1HD,1H ,13128/
      DATA INST(1, 8),INST(2, 8),INST(3, 8),INST(4, 8),INST(5, 8)
     1  /1HA,1HD,1HC,1H ,13136/
      DATA INST(1, 9),INST(2, 9),INST(3, 9),INST(4, 9),INST(5, 9)
     1  /1HS,1HB,1HC,1H ,13152/
      DATA INST(1,10),INST(2,10),INST(3,10),INST(4,10),INST(5,10)
     1  /1HB,1HI,1HT,1H ,12064/
      DATA INST(1,11),INST(2,11),INST(3,11),INST(4,11),INST(5,11)
     1  /1HR,1HE,1HS,1H ,12128/
      DATA INST(1,12),INST(2,12),INST(3,12),INST(4,12),INST(5,12)
     1  /1HS,1HE,1HT,1H ,12192/
      DATA INST(1,13),INST(2,13),INST(3,13),INST(4,13),INST(5,13)
     1  /1HE,1HX,1H ,1H ,11000/
      DATA INST(1,14),INST(2,14),INST(3,14),INST(4,14),INST(5,14)
     1  /1HL,1HD,1H ,1H ,10000/
      DATA INST(1,15),INST(2,15),INST(3,15),INST(4,15),INST(5,15)
     1  /1HP,1HU,1HS,1HH, 9197/
      DATA INST(1,16),INST(2,16),INST(3,16),INST(4,16),INST(5,16)
     1  /1HP,1HO,1HP,1H , 9193/
      DATA INST(1,17),INST(2,17),INST(3,17),INST(4,17),INST(5,17)
     1  /1HS,1HU,1HB,1H , 8144/
      DATA INST(1,18),INST(2,18),INST(3,18),INST(4,18),INST(5,18)
     1  /1HA,1HN,1HD,1H , 8160/
      DATA INST(1,19),INST(2,19),INST(3,19),INST(4,19),INST(5,19)
     1  /1HX,1HO,1HR,1H , 8168/
      DATA INST(1,20),INST(2,20),INST(3,20),INST(4,20),INST(5,20)
     1  /1HO,1HR,1H ,1H , 8176/
      DATA INST(1,21),INST(2,21),INST(3,21),INST(4,21),INST(5,21)
     1  /1HC,1HP,1H ,1H , 8184/
      DATA INST(1,22),INST(2,22),INST(3,22),INST(4,22),INST(5,22)
     1  /1HI,1HN,1HC,1H , 8004/
      DATA INST(1,23),INST(2,23),INST(3,23),INST(4,23),INST(5,23)
     1  /1HD,1HE,1HC,1H , 8005/
      DATA INST(1,24),INST(2,24),INST(3,24),INST(4,24),INST(5,24)
     1  /1HR,1HL,1HC,1H , 7000/
      DATA INST(1,25),INST(2,25),INST(3,25),INST(4,25),INST(5,25)
     1  /1HR,1HR,1HC,1H , 7008/
      DATA INST(1,26),INST(2,26),INST(3,26),INST(4,26),INST(5,26)
     1  /1HR,1HL,1H ,1H , 7016/
      DATA INST(1,27),INST(2,27),INST(3,27),INST(4,27),INST(5,27)
     1  /1HR,1HR,1H ,1H , 7024/
      DATA INST(1,28),INST(2,28),INST(3,28),INST(4,28),INST(5,28)
     1  /1HS,1HL,1HA,1H , 7032/
      DATA INST(1,29),INST(2,29),INST(3,29),INST(4,29),INST(5,29)
     1  /1HS,1HR,1HA,1H , 7040/
      DATA INST(1,30),INST(2,30),INST(3,30),INST(4,30),INST(5,30)
     1  /1HS,1HR,1HL,1H , 7056/
      DATA INST(1,31),INST(2,31),INST(3,31),INST(4,31),INST(5,31)
     1  /1HD,1HJ,1HN,1HZ, 6016/
      DATA INST(1,32),INST(2,32),INST(3,32),INST(4,32),INST(5,32)
     1  /1HR,1HS,1HT,1H , 5199/
      DATA INST(1,33),INST(2,33),INST(3,33),INST(4,33),INST(5,33)
     1  /1HI,1HM,1H ,1H , 5070/
      DATA INST(1,34),INST(2,34),INST(3,34),INST(4,34),INST(5,34)
     1  /1HL,1HD,1HI,1H , 4160/
      DATA INST(1,35),INST(2,35),INST(3,35),INST(4,35),INST(5,35)
     1  /1HL,1HD,1HI,1HR, 4176/
      DATA INST(1,36),INST(2,36),INST(3,36),INST(4,36),INST(5,36)
     1  /1HL,1HD,1HD,1H , 4168/
      DATA INST(1,37),INST(2,37),INST(3,37),INST(4,37),INST(5,37)
     1  /1HL,1HD,1HD,1HR, 4184/
      DATA INST(1,38),INST(2,38),INST(3,38),INST(4,38),INST(5,38)
     1  /1HC,1HP,1HI,1H , 4161/
      DATA INST(1,39),INST(2,39),INST(3,39),INST(4,39),INST(5,39)
     1  /1HC,1HP,1HI,1HR, 4177/
      DATA INST(1,40),INST(2,40),INST(3,40),INST(4,40),INST(5,40)
     1  /1HC,1HP,1HD,1H , 4169/
      DATA INST(1,41),INST(2,41),INST(3,41),INST(4,41),INST(5,41)
     1  /1HC,1HP,1HD,1HR, 4185/
      DATA INST(1,42),INST(2,42),INST(3,42),INST(4,42),INST(5,42)
     1  /1HN,1HE,1HG,1H , 4068/
      DATA INST(1,43),INST(2,43),INST(3,43),INST(4,43),INST(5,43)
     1  /1HR,1HE,1HT,1HI, 4077/
      DATA INST(1,44),INST(2,44),INST(3,44),INST(4,44),INST(5,44)
     1  /1HR,1HL,1HD,1H , 4111/
      DATA INST(1,45),INST(2,45),INST(3,45),INST(4,45),INST(5,45)
     1  /1HR,1HR,1HD,1H , 4103/
      DATA INST(1,46),INST(2,46),INST(3,46),INST(4,46),INST(5,46)
     1  /1HR,1HE,1HT,1HN, 4069/
      DATA INST(1,47),INST(2,47),INST(3,47),INST(4,47),INST(5,47)
     1  /1HI,1HN,1HI,1H , 4162/
      DATA INST(1,48),INST(2,48),INST(3,48),INST(4,48),INST(5,48)
     1  /1HI,1HN,1HI,1HR, 4178/
      DATA INST(1,49),INST(2,49),INST(3,49),INST(4,49),INST(5,49)
     1  /1HI,1HN,1HD,1H , 4170/
      DATA INST(1,50),INST(2,50),INST(3,50),INST(4,50),INST(5,50)
     1  /1HI,1HN,1HD,1HR, 4186/
      DATA INST(1,51),INST(2,51),INST(3,51),INST(4,51),INST(5,51)
     1  /1HO,1HU,1HT,1HI, 4163/
      DATA INST(1,52),INST(2,52),INST(3,52),INST(4,52),INST(5,52)
     1  /1HO,1HT,1HI,1HR, 4179/
      DATA INST(1,53),INST(2,53),INST(3,53),INST(4,53),INST(5,53)
     1  /1HO,1HU,1HT,1HD, 4171/
      DATA INST(1,54),INST(2,54),INST(3,54),INST(4,54),INST(5,54)
     1  /1HO,1HT,1HD,1HR, 4187/
      DATA INST(1,55),INST(2,55),INST(3,55),INST(4,55),INST(5,55)
     1  /1HE,1HX,1HX,1H , 3217/
      DATA INST(1,56),INST(2,56),INST(3,56),INST(4,56),INST(5,56)
     1  /1HD,1HA,1HA,1H , 3039/
      DATA INST(1,57),INST(2,57),INST(3,57),INST(4,57),INST(5,57)
     1  /1HC,1HP,1HL,1H , 3047/
      DATA INST(1,58),INST(2,58),INST(3,58),INST(4,58),INST(5,58)
     1  /1HC,1HC,1HF,1H , 3063/
      DATA INST(1,59),INST(2,59),INST(3,59),INST(4,59),INST(5,59)
     1  /1HS,1HC,1HF,1H , 3055/
      DATA INST(1,60),INST(2,60),INST(3,60),INST(4,60),INST(5,60)
     1  /1HR,1HL,1HC,1HA, 3007/
      DATA INST(1,61),INST(2,61),INST(3,61),INST(4,61),INST(5,61)
     1  /1HR,1HR,1HC,1HA, 3015/
      DATA INST(1,62),INST(2,62),INST(3,62),INST(4,62),INST(5,62)
     1  /1HR,1HL,1HA,1H , 3023/
      DATA INST(1,63),INST(2,63),INST(3,63),INST(4,63),INST(5,63)
     1  /1HR,1HR,1HA,1H , 3031/
      DATA INST(1,64),INST(2,64),INST(3,64),INST(4,64),INST(5,64)
     1  /1HN,1HO,1HP,1H , 3000/
      DATA INST(1,65),INST(2,65),INST(3,65),INST(4,65),INST(5,65)
     1  /1HH,1HA,1HL,1HT, 3118/
      DATA INST(1,66),INST(2,66),INST(3,66),INST(4,66),INST(5,66)
     1  /1HD,1HI,1H ,1H , 3243/
      DATA INST(1,67),INST(2,67),INST(3,67),INST(4,67),INST(5,67)
     1  /1HE,1HI,1H ,1H , 3251/
      DATA INST(1,68),INST(2,68),INST(3,68),INST(4,68),INST(5,68)
     1  /1HO,1HR,1HG,1H , 1001/
      DATA INST(1,69),INST(2,69),INST(3,69),INST(4,69),INST(5,69)
     1  /1HE,1HQ,1HU,1H , 1002/
      DATA INST(1,70),INST(2,70),INST(3,70),INST(4,70),INST(5,70)
     1  /1HD,1HE,1HF,1HB, 1003/
      DATA INST(1,71),INST(2,71),INST(3,71),INST(4,71),INST(5,71)
     1  /1HD,1HE,1HF,1HS, 1004/
      DATA INST(1,72),INST(2,72),INST(3,72),INST(4,72),INST(5,72)
     1  /1HD,1HE,1HF,1HW, 1005/
      DATA INST(1,73),INST(2,73),INST(3,73),INST(4,73),INST(5,73)
     1  /1HE,1HN,1HD,1H , 1006/
      DATA INST(1,74),INST(2,74),INST(3,74),INST(4,74),INST(5,74)
     1  /1HE,1HJ,1HE,1HC, 1007/
      DATA INST(1,75),INST(2,75),INST(3,75),INST(4,75),INST(5,75)
     1  /1HL,1HI,1HS,1HT, 1009/
      DATA INST(1,76),INST(2,76),INST(3,76),INST(4,76),INST(5,76)
     1  /1HS,1HP,1HA,1HC, 1011/
      DATA INST(1,77),INST(2,77),INST(3,77),INST(4,77),INST(5,77)
     1  /1HD,1HE,1HF,1HL, 1012/
      DATA INST(1,78),INST(2,78),INST(3,78),INST(4,78),INST(5,78)
     1  /1HI,1HF,1H ,1H , 1014/
      DATA INST(1,79),INST(2,79),INST(3,79),INST(4,79),INST(5,79)
     1  /1HM,1HA,1HC,1HR, 1016/
      DATA INST(1,80),INST(2,80),INST(3,80),INST(4,80),INST(5,80)
     1  /1HD,1HE,1HF,1HM, 1018/
      DATA INST(1,81),INST(2,81),INST(3,81),INST(4,81),INST(5,81)
     1  /1HE,1HN,1HD,1HM, 1017/
      DATA INSTE(1,1),INSTE(2,1),INSTE(3,1),INSTE(4,1),INSTE(5,1),
     1  INSTE(6,1) /1HN,1HL,1HI,1HS,1HT,1010/
      DATA INSTE(1,2),INSTE(2,2),INSTE(3,2),INSTE(4,2),INSTE(5,2),
     1  INSTE(6,2) /1HE,1HN,1HD,1HI,1HF, 1015/
      DATA INSTE(1,3),INSTE(2,3),INSTE(3,3),INSTE(4,3),INSTE(5,3),
     1  INSTE(6,3) /1HT,1HI,1HT,1HL,1HE,1013/
C
C     *ENTRY PARAMETERS
C     ICOL  - STARTING COLUMN OF SCAN FOR OPCODE
C
C     *EXIT PARAMETERS
C     ICOL  - END OF OPCODE +1, OR BEGINNING OF LABEL IF IERR = 6
C     ITYPE - INSTRUCTION TYPE
C        -1 = COMMENT (SET IN PASS 1)
C         0 = ERROR
C         1 = DIRECTIVE
C         2 = MACRO CALL
C         3 = INHERENT - 1 BYTE
C         4 = INHERENT - 2 BYTE
C         5 = RST
C         6 = DJNZ
C         7 = ROTATES AND SHIFTS
C         8 = ACCUMULATOR AND OPERAND GROUP - 1 OPERAND
C         9 = PUSH AND POP
C        10 = LD
C        11 = EX
C        12 = BIT,RES,SET
C        13 = AND,ADC,SBC
C        14 = OUT
C        15 = IN
C        16 = RET
C        17 = JR
C        18 = CALL
C        19 = JP
C     IOPVA - VALUE OF INSTRUCTION
C     ICHK  - 1000*ITYPE+IOPVA
C     ICNT  - LENGTH OF OPCODE
C     IERR  - ERROR STATUS
C         1 = VALID OPCODE
C         2 = VALID FORMAT - PRESUMED MACRO NAME
C         3 = OPCODE ERROR
C         4 = COMMENT LINE
C         5 = NO OPCODE ON LINE
C         6 = SYMBOL END WITH A COLON, PRESUMED LABEL
C
      NUMOP = 81
      ITYPE = 0
      IOPVA = 0
      ICHK=0
      ICNT = 0
      IERR = 1
      INSTT = 0
      ILEN = 4
C     LOOK FOR START OF OPCODE
100   IF(IN(ICOL)-IBLNK) 105,115,105
105   IF(IN(ICOL)-ICTAB) 110,115,110
C     CHECK FOR COMMENT LINE
110   IF(IN(ICOL)-ISEMI) 120,920,120
115   ICOL = ICOL+1
      IF(ICOL-MCOL) 100,100,930
C     FOUND START OF OPCODE, CHECK FOR A MACRO
120   J1 = ICOL
      IF(MCNT) 200,200,130
130   CALL SYMBL(ICOL)
      GO TO(150,910,200,910),IERR
150   DO 170 L=1,MCNT
      DO 160 K=1,IWORD
      IF(MCNAM(K,L)-NAME(K)) 170,160,170
160   CONTINUE
      IOPVA = L
      ITYPE = 2
      ICHK = 2000+L
      GO TO 600
170   CONTINUE
C     GET END OF OPCODE AND CHECK FOR VALIDITY
200   ICOL = J1
      ICNT = 0
210   IF(IN(ICOL)-IBLNK) 220,260,220
220   IF(IN(ICOL)-ISEMI) 230,260,230
230   IF(IN(ICOL)-ICTAB) 235,260,235
235   IF(IN(ICOL)-ICOLN) 240,940,240
240   ICNT = ICNT+1
      ICOL = ICOL+1
      IF(ICNT-MOPC) 250,250,910
250   IF(ICOL-MCOL) 210,210,260
260   IF(ICNT-ILEN) 300,300,270
270   ILEN = 5
      INSTT = 1
      NUMOP = 3
C     CHECK OPCODE AGAINST ALL LEGAL OPCODES
300   DO 370 L=1,NUMOP
      DO 330 K=1,ICNT
      K1 = J1+K-1
      IF(INSTT) 310,310,320
310   IF(IN(K1)-INST(K,L)) 370,330,370
320   IF(IN(K1)-INSTE(K,L)) 370,330,370
330   CONTINUE
      IF(ICNT-ILEN) 340,500,500
340   K2 = ICNT+1
      IF(INSTT) 350,350,360
350   IF(INST(K2,L)-IBLNK) 370,500,370
360   IF(INSTE(K2,L)-IBLNK) 370,500,370
370   CONTINUE
      GO TO 910
C     FETCH INSTRUCTION TYPE AND VALUE
500   ICHK = INST(5,L)
      IF(INSTT) 550,550,510
510   ICHK = INSTE(6,L)
550   ITYPE = ICHK/1000
      IOPVA = ICHK-ITYPE*1000
C     SCAN TO START OF ARGUMENT FIELD
600   IF(IN(ICOL)-IBLNK) 650,610,650
610   ICOL = ICOL+1
      IF(ICOL-MCOL) 600,600,650
650   IARG = ICOL
      RETURN
C     OPCODE ERROR
910   IERR = 3
      RETURN
C     FOUND COMMENT INDICATOR
920   IERR = 4
      RETURN
C     NO OPCODE ON LINE
930   IERR = 5
      RETURN
C     PRESUMED LABEL
940   IERR = 6
      ICOL = J1
      RETURN
      END
      SUBROUTINE LABEL(ICOL,IVAL,MODE)
C
C
C     THIS ROUTINE PROCESSES ALL SYMBOLS USED IN THE ASSEMBLY
C     PROGRAM.  IT SCANS THE SYMBOL TABLE TO SEE IF A GIVEN SYMBOL
C     IS DEFINED OR NOT
C
C
      REAL IVAL
      REAL LC,LODLC,IPVAL,ITABV(200)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
C
C
C
C     *ENTRY PARAMETERS
C     ICOL  - STARTING COLUMN OF SCAN
C     MODE  - REFERENCE OR DEFINITION FLAG
C         0 = DEFINITION
C         1 = REFERENCE
C
C     *EXIT PARAMETERS
C     ICOL  - ENDING COLUMN OF SCAN
C     IVAL  - VALUE OF LABEL
C     IERR  - ERROR STATUS
C         1 = VALID SYMBOL FOUND
C         2 = SYMBOL NOT IN TABLE
C         3 = SYMBOL ERROR
C         4 = SYMBOL TABLE FULL
C     ISSYM - INDICATES A DEFL SYMBOL IF SET TO 1
C
      ISSYM = 0
      IVAL = 0
      NOTRY = 0
C     FETCH LABEL AND ITS INDEX
      CALL SYMBL(ICOL)
      IF(IERR-4) 100,920,100
C     CHECK IF LABEL IS IN TABLE
100   INDEX = 3*INDEX
150   IF(INDEX-LTAB) 160,160,155
155   INDEX = INDEX-LTAB
      GO TO 150
C     CHECK FOR EMPTY SLOT IN TABLE
160   IF(ITAB(1,INDEX)) 165,910,165
165   DO 170 J=1,IWORD
      IF(ITAB(J,INDEX)-NAME(J)) 200,170,200
170   CONTINUE
      GO TO 800
C     TRY NEXT SLOT IN TABLE
200   NOTRY = NOTRY+1
      INDEX = INDEX+1
      IF(NOTRY-LTAB) 150,940,940
C     CHECK IF A DEFL SYMBOL
800   IVAL = ITABV(INDEX)
      IF(IVAL-100000.) 900,810,810
810   IVAL = IVAL-100000.
      ISSYM = 1
C     SYMBOL FOUND
900   IERR = 1
      IF(MODE+IPASS+LREF-4) 945,905,945
905   CALL XREFT(MODE,0)
      RETURN
C     SYMBOL NOT IN TABLE
910   IERR = 2
      RETURN
C     SYMBOL ERROR
920   IERR = 3
      RETURN
C     SYMBOL TABLE FULL
940   IERR = 4
945   RETURN
      END
      SUBROUTINE SYMBL(ICOL)
C
C
C     THIS SUBROUTINE IS USED TO FORM A SYMBOL AND ITS INDEX
C     INTO THE SYMBOL TABLE
C
C
      REAL LC,LODLC,IPVAL,ITABV(200)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
C
C     *ENTRY PARAMETERS
C     ICOL  - STARTING COLUMN OF SCAN
C
C     *EXIT PARAMETERS
C     ICOL  - ENDING COLUMN OF SCAN
C     NAME  - CONTAINS NUMERIC EQUIVALENT OF SYMBOL
C     LABCT - NUMBER OF CHARACTERS IN SYMBOL
C     IERR  - ERROR STATUS
C         1 = SYMBOL ENDS WITH BLANK,SEMICOLON, OR TAB
C         2 = SYMBOL ENDS WITH A COMMA
C         3 = SYMBOL ENDS WITH OTHER THAN 1 OR 2
C         4 = SYMBOL ERROR
C
      INDEX = 0
      LABCT = 0
      DO 10 J=1,IWORD
      NAME(J) = 0
10    CONTINUE
      IC1 = 1
      IC2 = 1
C     CHECK FOR VALID CHARACTER
100   DO 110 J=1,41
      IF(IN(ICOL)-IALPH(J)) 110,130,110
110   CONTINUE
C     END OF SCAN IF FOUND INVALID CHARACTER
      IF(LABCT) 115,930,115
115   IF(IC2-ICCNT) 116,116,120
116   DO 117 J=IC2,ICCNT
      NAME(IC1) = NAME(IC1)*256
117   CONTINUE
C     CHECK FOR BLANK OR COMMA
120   IF(IN(ICOL)-IBLNK) 122,900,122
122   IF(IN(ICOL)-ISEMI) 125,900,125
125   IF(IN(ICOL)-ICOMM) 126,910,126
126   IF(IN(ICOL)-ICTAB) 920,900,920
C     CHECK IF MORE CHARACTER THAN WILL FIT IN TABLE
130   IF(LABCT-MLAB) 132,160,160
132   IF(LABCT) 134,134,140
134   IF(J-10) 930,930,140
140   LABCT = LABCT+1
C     CALCULATE INDEX INTO SYMBOL TABLE
      INDEX = INDEX+J
      IF(IC2-ICCNT) 150,150,142
142   IC1 = IC1+1
      IC2 = 1
150   IC2 = IC2+1
C     FORM SYMBOL FOR PLACEMENT IN TABLE
      NAME(IC1) = NAME(IC1)*256+J
160   IF(ICOL-MCOL) 162,930,930
162   ICOL = ICOL+1
      GO TO 100
C     SYMBOL END WITH A BLANK OR SEMICOLON OR TAB
900   IERR = 1
      RETURN
C     SYMBOL ENDS WITH A COMMA
910   IERR = 2
      RETURN
C     SYMBOL ENDS WITH OTHER THAN A BLANK, COMMA, OR SEMICOLON
920   IERR = 3
      RETURN
C     SYMBOL ERROR
930   IERR = 4
      RETURN
      END
      SUBROUTINE SCAN(ICOL,IVAL)
C
C
C     THIS SUBROUTINE IS USED TO EVALUATE A GENERAL EXPRESSION
C     AND RETURNS A VALUE REPRESENTING THE EXPRESSION TO THE
C     CALLING PROGRAM.  THE METHOD USED IS INFIX TO POLISH
C     CONVERSION AND THEN AN EVALUATION OF THE POLISH STRING
C
C
      REAL IVAL,IVAL1,MDIV,IOP1,IOP2,ISTK2(80)
      REAL LC,LODLC,IPVAL,ITABV(200)
      DIMENSION ISTK1(80),IOPER(12),IPREC(20),ISYM(17),NOPER(3,13)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
      EQUIVALENCE (IOPER(1),IPLUS)
      EQUIVALENCE (ISYM(1),IBLNK)
      DATA IPREC( 1),IPREC( 2),IPREC( 3),IPREC( 4) /11,11,13,13/
      DATA IPREC( 5),IPREC( 6),IPREC( 7),IPREC( 8) /0,21,9,3/
      DATA IPREC( 9),IPREC(10),IPREC(11),IPREC(12) /3,3,7,5/
      DATA IPREC(13),IPREC(14),IPREC(15),IPREC(16) /5,13,13,13/
      DATA IPREC(17),IPREC(18),IPREC(19),IPREC(20) /3,3,1,15/
      DATA NOPER(1, 1),NOPER(2, 1),NOPER(3, 1) /1HN,1HO,1HT/
      DATA NOPER(1, 2),NOPER(2, 2),NOPER(3, 2) /1HE,1HQ,1H /
      DATA NOPER(1, 3),NOPER(2, 3),NOPER(3, 3) /1HG,1HT,1H /
      DATA NOPER(1, 4),NOPER(2, 4),NOPER(3, 4) /1HL,1HT,1H /
      DATA NOPER(1, 5),NOPER(2, 5),NOPER(3, 5) /1HA,1HN,1HD/
      DATA NOPER(1, 6),NOPER(2, 6),NOPER(3, 6) /1HO,1HR,1H /
      DATA NOPER(1, 7),NOPER(2, 7),NOPER(3, 7) /1HX,1HO,1HR/
      DATA NOPER(1, 8),NOPER(2, 8),NOPER(3, 8) /1HM,1HO,1HD/
      DATA NOPER(1, 9),NOPER(2, 9),NOPER(3, 9) /1HS,1HH,1HL/
      DATA NOPER(1,10),NOPER(2,10),NOPER(3,10) /1HS,1HH,1HR/
      DATA NOPER(1,11),NOPER(2,11),NOPER(3,11) /1HU,1HG,1HT/
      DATA NOPER(1,12),NOPER(2,12),NOPER(3,12) /1HU,1HL,1HT/
      DATA NOPER(1,13),NOPER(2,13),NOPER(3,13) /1HR,1HE,1HS/
C
C
C     *ENTRY PARAMETERS
C     ICOL  - STARTING COLUMN OF SCAN
C     NSPAR - INDICATES USE LEFT PARENTHESIS AS FIRST CHARACTER
C
C     *EXIT PARAMETERS
C     ICOL  - ENDING COLUMN OF SCAN
C     IVAL  - VALUE OF EXPRESSION ON RETURN
C     NSPAR - SET TO ZERO
C     IERR  - ERROR STATUS
C         1 = NO ERRORS
C         2 = MISSING ARGUMENT OR ARGUMENT ERROR
C         3 = UNDEFINED SYMBOL
C         4 = NO ERROR, SCAN ENDED WITH A COMMA
C         5 = SYNTAX ERROR
C
      IF(ICOL-MCOL) 10,10,920
10    NEXP = -2
      NUNDS = 0
      NUARY = 1
      NEND = 0
      IVAL = 0
      NPNTO = 81
      NPRCS = 0
      IPNTS = 1
      LLEN = 0
      ISTK1(1) = 0
      ISTK2(1) = 0
      IF(NSPAR) 100,100,20
20    ICHAR = ILPAR
      NSPAR = 0
      ICOL = ICOL-1
      GO TO 105
100   ICHAR = IN(ICOL)
      IF(ICOL-MCOL) 105,105,118
C     CHECK FOR AN OPERATOR
105   DO 110 L=1,12
      IF(ICHAR-IOPER(L)) 110,200,110
110   CONTINUE
C     CHECK FOR SCAN TERMINATOR (COMMA,BLANK, SEMICOLON)
      IERR = 4
      IF(ICHAR-ICOMM) 112,119,112
112   IF(ICHAR-IBLNK) 114,118,114
114   IF(ICHAR-ISEMI) 116,118,116
116   IF(ICHAR-ICTAB) 120,118,120
118   IERR = 1
119   NPRCI = 0
      NEND = 1
      GO TO 300
C     CHECK FOR OPERATOR DELIMITED BY PERIODS
120   IF(ICHAR-IPER) 130,121,130
121   ICOL1 = ICOL
      J = 0
122   ICOL = ICOL+1
      IF(IN(ICOL)-IPER) 123,124,123
123   J = J+1
      IF(J-3) 122,122,910
C     CHECK IF VALID OPERATOR
124   DO 127 LL=1,13
      DO 125 N=1,J
      L = ICOL1+N
      IF(IN(L)-NOPER(N,LL)) 127,125,127
125   CONTINUE
C     VALID OPERATOR SET OPERATOR INDEX
      L = LL+6
      IF(J-3) 126,200,200
126   J = J+1
      IF(NOPER(J,LL)-IBLNK) 920,200,920
127   CONTINUE
      GO TO 920
C     CHECK FOR AN OPERAND
130   NUARY = 0
      IVAL = 0
      IF(NEXP+1) 140,910,140
C     CHECK FOR NUMERIC OPERAND
140   DO 1410 J=1,10
      IF(ICHAR-IALPH(J)) 1410,1420,1410
1410  CONTINUE
      GO TO 150
C     FOUND NUMERIC, LOOK FOR TERMINATOR
1420  N1 = ICOL
1425  ICOL = ICOL+1
      IF(ICOL-MCOL) 1430,1430,1440
1430  ICHAR = IN(ICOL)
      DO 1435 LL=1,17
      IF(ISYM(LL)-ICHAR) 1435,1440,1435
1435  CONTINUE
      GO TO 1425
1440  ICOL1 = ICOL-1
C     CHECK FOR CONSTANT TYPE (B,D,O,Q,H)
      ICHAR = IN(ICOL1)
      IFACT = 2
C     BINARY CONSTANT
      IF(ICHAR-ICHRB) 1445,1470,1445
C     OCTAL CONSTANT
1445  IFACT = 8
      IF(ICHAR-ICHRO) 1450,1470,1450
1450  IF(ICHAR-ICHRQ) 1455,1470,1455
C     HEXADECIMAL CONSTANT
1455  IFACT = 16
      IF(ICHAR-ICHRH) 1460,1470,1460
C     DECIMAL CONSTANT
1460  IFACT = 10
      IF(ICHAR-ICHRD) 1465,1470,1465
1465  ICOL1 = ICOL
1470  ICOL1 = ICOL1-1
C     FORM NUMERIC VALUE
      IOP1 = IFACT
      DO 1490 LL=N1,ICOL1
      DO 1480 K=1,IFACT
      IF(IN(LL)-IALPH(K)) 1480,1485,1480
1480  CONTINUE
      GO TO 910
1485  IOP2 = K-1
      IVAL = IVAL*IOP1+IOP2
1490  CONTINUE
      GO TO 190
C     CHECK FOR LOCATION COUNTER REFERENCE
150   IF(ICHAR-IDOLR) 160,155,160
155   IVAL = LC
      ICOL = ICOL+1
      GO TO 190
160   CALL CONST(ICOL,IVAL)
      GO TO (170,920,180,910),IERR
170   IF(LLEN) 915,915,172
172   IF(LLEN-2) 190,174,915
174   IVAL1 = NBIN(2)
      IVAL = IVAL*256.+IVAL1
      GO TO 190
C     CHECK FOR SYMBOL OPERAND
180   CALL LABEL(ICOL,IVAL,1)
      GO TO(190,185,920,930),IERR
185   IVAL = 0
      NUNDS = 1
C     FOUND OPERAND, PLACE IT IN OUTPUT STACK
190   NPNTO = NPNTO-1
      ISTK1(NPNTO) = 0
      ISTK2(NPNTO) = IVAL
      NEXP = -1
      GO TO 100
C     HAVE AN OPERATOR, PLACE IN INPUT STACK
200   NPRCI = IPREC(L)
C     CHECK IF PREVIOUS TOKEN WAS AN OPERATOR - IF SO CHECK SYNTAX
      IF(NEXP) 250,205,205
C     CHECK IF RIGHT PARENTHESIS
205   IF(L-5) 215,210,215
210   IF(NEXP-5) 910,270,910
C     CHECK IF LEFT PARENTHESIS
215   IF(L-6) 225,220,225
220   NUARY = 1
      IF(NEXP-5) 270,910,270
C     CHECK IF PREVIOUS TOKEN WAS LEFT PARENTHESIS
225   IF(NEXP-6) 240,230,240
230   IF(L-7) 235,270,235
235   IF(L-2) 270,270,910
C     CHECK IF PREVIOUS TOKEN RIGHT PARENTHESIS
240   IF(NEXP-5) 910,245,910
245   IF(L-7) 250,910,250
C     CHECK IF EXPONENTIATION
250   IF(L-3) 270,255,270
255   ICOL1 = ICOL+1
      IF(IN(ICOL1)-IMULT) 270,260,270
260   L = 20
      NPRCI = 15
      ICOL = ICOL1
270   NEXP = L
C     CHECK IF UNARY PLUS OR MINUS
      IF(L-2) 275,275,300
275   IF(NUARY) 300,300,280
280   L = L+4
      NPRCI = 17
C     PERFORM INFIX TO POLISH CONVERSION
C     CHECK IF INPUT STACK IS EMPTY
300   IF(IPNTS) 310,920,310
C     COMPARE INPUT STRING PRECEDENCE TO INPUT STACK PRECEDENCE
310   IF(NPRCI-NPRCS) 400,410,420
C     STACK PRECEDENCE GREATER THAN INPUT STRING PRECEDENCE
400   NPNTO = NPNTO-1
      ISTK1(NPNTO) = ISTK1(IPNTS)
      ISTK2(NPNTO) = 0
      IPNTS = IPNTS-1
      NPRCS = ISTK2(IPNTS)
      GO TO 300
C     STACK PRECEDENCE EQUALS INPUT STRING PRECEDENCE
410   IPNTS = IPNTS-1
      IF(NEND-1) 412,415,412
412   IF(IPNTS) 910,910,414
414   NPRCS = ISTK2(IPNTS)
      GO TO 430
C     CHECK FOR EMPTY INPUT STACK
415   IF(IPNTS-1) 417,910,910
C     PLACE END INDICATOR IN OUTPUT STACK
417   NPNTO = NPNTO-1
      ISTK1(NPNTO) = -1
      GO TO 500
C     STACK PRECEDENCE LESS THAN INPUT STRING PRECEDENCE
420   IPNTS = IPNTS+1
      ISTK1(IPNTS) = L
      IF(NPRCI-21) 424,422,424
422   NPRCI = -1
424   NPRCS = NPRCI+1
      ISTK2(IPNTS) = NPRCS
430   ICOL = ICOL+1
      GO TO 100
C
C     EVALUATE EXPRESSION
C
C     CHECK IF OUTPUT STACK IS EMPTY
500   NPNTE = 0
      IF(NPNTO-80) 505,920,920
505   NPNTO = 81
C     GET NEXT ENTRY IN STACK
510   NPNTO = NPNTO-1
      ICHAR = ISTK1(NPNTO)
      IF(ICHAR) 520,540,560
C     END OF STACK - CHECK FOR ONLY ONE ENTRY IN EVALUATION
C     STACK WHICH IS THE EXPRESSION VALUE
520   IF(NPNTE-1) 910,530,910
530   IVAL = ISTK2(1)
      LLEN = 1
      GO TO 905
C     THIS IS AN OPERAND - PLACE IN EVALUATION STACK
540   NPNTE = NPNTE+1
      IVAL = ISTK2(NPNTO)
      GO TO 810
C     THIS IS AN OPERATOR - PERFORM NECESSARY OPERATION
560   IF(NPNTE-1) 910,562,566
562   IF(ICHAR-4) 910,910,564
564   IF(ICHAR-7) 568,568,565
565   IF(ICHAR-19) 910,568,910
566   NPNT1 = NPNTE-1
      IOP2 = ISTK2(NPNT1)
568   IOP1 = ISTK2(NPNTE)
      IVAL = 0
      GO TO(570,580,590,600,610,620,630,640,650,660,670,
     1  680,690,700,710,720,730,740,750,760),ICHAR
C     ADDITION
570   IVAL = IOP2+IOP1
      GO TO 800
C     SUBTRACTION
580   IVAL = IOP2-IOP1
      GO TO 800
C     MULTIPLICATION
590   IVAL = IOP2*IOP1
      GO TO 800
C     DIVISION
600   IF(IOP1) 602,810,602
602   J = IOP2/IOP1
      IVAL = J
      GO TO 800
C     UNARY ADDITION
610   GO TO 510
C     UNARY SUBTRACTION
620   IVAL = -IOP1
      GO TO 810
C     .NOT.
630   IVAL = 65535.-IOP1
      GO TO 810
C     .EQ.
640   IF(IOP1-IOP2) 800,790,800
C     .GT.
650   IF(IOP1-32768.) 652,651,651
651   IOP1 = IOP1-65536.
652   IF(IOP2-32768.) 730,653,653
653   IOP2 = IOP2-65536.
      GO TO 730
C     .LT.
660   IF(IOP1-32768.) 662,661,661
661   IOP1 = IOP1-65536.
662   IF(IOP2-32768.) 740,663,663
663   IOP2 = IOP2-65536.
      GO TO 740
C     .AND.
670   IC1 = 2
      IC2 = 2
      GO TO 770
C     .OR.
680   IC1 = 1
      IC2 = 2
      GO TO 770
C     .XOR.
690   IC1 = 1
      IC2 = 1
      GO TO 770
C     .MOD.
700   IVAL = IOP2
      IF(IOP1) 705,800,705
705   J = IOP2/IOP1
      IVAL = J
      IVAL = IOP2-IOP1*IVAL
      GO TO 800
C     .SHL.
710   IF(IOP1-16.) 712,800,800
712   IC1 = IOP1
      IVAL = 2**IC1
      IVAL = IOP2*IVAL
      GO TO 800
C     .SHR.
720   IF(IOP1-16.) 722,800,800
722   IC1 = IOP1
      IVAL = 2**IC1
      IVAL = IOP2/IVAL
      GO TO 800
C     .UGT.
730   IF(IOP2-IOP1) 800,800,790
C     .ULT.
740   IF(IOP2-IOP1) 790,800,800
C     .RES.
750   GO TO 510
C     EXPONENTIATION
760   IVAL = IOP2**IOP1
      GO TO 800
C     PERFORM BIT PROCESSING FOR AND,OR,XOR
770   MDIV = 32768.
      DO 778 I=1,16
      IB1 = IOP1/MDIV
      IVAL1 = IB1
      IOP1 = IOP1-IVAL1*MDIV
      IB2 = IOP2/MDIV
      IVAL1 = IB2
      IOP2 = IOP2-IVAL1*MDIV
      IB1 = IB1+IB2
      IF(IB1-IC1) 776,774,772
772   IF(IB1-IC2) 776,774,776
774   IVAL = IVAL+MDIV
776   MDIV = MDIV/2.
778   CONTINUE
      GO TO 800
C     SET RELATIONSHIP TO TRUE
790   IVAL = 65535.
C     CHECK IF VALUE WITHIN RANGE
800   NPNTE = NPNT1
810   J = IVAL/65536.
      IVAL1 = J
      IVAL = IVAL-IVAL1*65536.
      IF(IVAL) 820,830,830
820   IVAL = IVAL+65536.
830   ISTK2(NPNTE) = IVAL
      GO TO 510
C     CHECK FOR UNDEFINED SYMBOL
905   IF(NUNDS) 940,940,930
C     SYNTAX ERROR
910   IERR = 5
      RETURN
C     ARGUMENT ERROR
915   LLEN = 0
920   IERR = 2
      RETURN
C     UNDEFINED SYMBOL
930   IERR = 3
940   RETURN
      END
      SUBROUTINE CONST(ICOL,IVAL)
C
C
C     THIS SUBROUTINE PROCESSES ALL CONSTANT STRINGS IN THE
C     ARGUMENT FIELD
C
C
      REAL LC,LODLC,IPVAL,ITABV(200)
      REAL IVAL
      DIMENSION IASCI(62),IEBCD(62)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
      DATA IASCI( 1),IASCI( 2),IASCI( 3),IASCI( 4) /48,49,50,51/
      DATA IASCI( 5),IASCI( 6),IASCI( 7),IASCI( 8) /52,53,54,55/
      DATA IASCI( 9),IASCI(10),IASCI(11),IASCI(12) /56,57,65,66/
      DATA IASCI(13),IASCI(14),IASCI(15),IASCI(16) /67,68,69,70/
      DATA IASCI(17),IASCI(18),IASCI(19),IASCI(20) /71,72,73,74/
      DATA IASCI(21),IASCI(22),IASCI(23),IASCI(24) /75,76,77,78/
      DATA IASCI(25),IASCI(26),IASCI(27),IASCI(28) /79,80,81,82/
      DATA IASCI(29),IASCI(30),IASCI(31),IASCI(32) /83,84,85,86/
      DATA IASCI(33),IASCI(34),IASCI(35),IASCI(36) /87,88,89,90/
      DATA IASCI(37),IASCI(38),IASCI(39),IASCI(40) /33,37,63,64/
      DATA IASCI(41),IASCI(42),IASCI(43),IASCI(44) /95,32,34,35/
      DATA IASCI(45),IASCI(46),IASCI(47),IASCI(48) /36,38,39,40/
      DATA IASCI(49),IASCI(50),IASCI(51),IASCI(52) /41,42,43,44/
      DATA IASCI(53),IASCI(54),IASCI(55),IASCI(56) /45,46,47,58/
      DATA IASCI(57),IASCI(58),IASCI(59),IASCI(60) /59,60,61,62/
      DATA IASCI(61),IASCI(62)                     /94,92/
      DATA IEBCD( 1),IEBCD( 2),IEBCD( 3),IEBCD( 4) /240,241,242,243/
      DATA IEBCD( 5),IEBCD( 6),IEBCD( 7),IEBCD( 8) /244,245,246,247/
      DATA IEBCD( 9),IEBCD(10),IEBCD(11),IEBCD(12) /248,249,193,194/
      DATA IEBCD(13),IEBCD(14),IEBCD(15),IEBCD(16) /195,196,197,198/
      DATA IEBCD(17),IEBCD(18),IEBCD(19),IEBCD(20) /199,200,201,209/
      DATA IEBCD(21),IEBCD(22),IEBCD(23),IEBCD(24) /210,211,212,213/
      DATA IEBCD(25),IEBCD(26),IEBCD(27),IEBCD(28) /214,215,216,217/
      DATA IEBCD(29),IEBCD(30),IEBCD(31),IEBCD(32) /226,227,228,229/
      DATA IEBCD(33),IEBCD(34),IEBCD(35),IEBCD(36) /230,231,232,233/
      DATA IEBCD(37),IEBCD(38),IEBCD(39),IEBCD(40) /90,108,111,124/
      DATA IEBCD(41),IEBCD(42),IEBCD(43),IEBCD(44) /109,64,127,123/
      DATA IEBCD(45),IEBCD(46),IEBCD(47),IEBCD(48) /91,80,125,77/
      DATA IEBCD(49),IEBCD(50),IEBCD(51),IEBCD(52) /93,92,78,107/
      DATA IEBCD(53),IEBCD(54),IEBCD(55),IEBCD(56) /96,75,97,122/
      DATA IEBCD(57),IEBCD(58),IEBCD(59),IEBCD(60) /94,76,126,110/
      DATA IEBCD(61),IEBCD(62)                     /79,224/
C
C     *ENTRY PARAMETERS
C     ICOL - STARTING COLUMN OF SCAN
C
C     *EXIT PARAMETERS
C     ICOL  - ENDING COLUMN OF SCAN
C     IVAL - 1ST BYTE OF CONSTANT ON RETURN
C     NBIN - ARRAY OF CONSTANT VALUES
C     IERR - ERROR STATUS
C        1 = FOUND VALID CONSTANTS
C        2 = ERROR IN DATA OR NO DATA FOUND
C        3 = THIS IS NOT CONSTANT STRING FORMAT
C        4 = EXPRESSION ERROR
C
      NBIN(1) = 0
      LLEN = 0
      IF(ICOL-MCOL) 10,10,930
C     CHECK FOR A LITERAL
10    ICOL1 = ICOL+1
      NCHAR = IN(ICOL)
      IFACT = 1
      IF(NCHAR-IQUOT) 15,200,15
15    IF(IN(ICOL1)-IQUOT) 920,20,920
20    ICOL = ICOL1
C     ASCII CONSTANT
60    IFACT = 1
      IF(NCHAR-ICHRA) 70,200,70
C     EBCDIC CONSTANT
70    IFACT = 2
      IF(NCHAR-ICHRE) 930,200,930
C
C     PROCESS ASCII OR EBCDIC CONSTANTS
C
200   ICOL = ICOL+1
      IF(ICOL-MCOL) 202,202,930
C
C     CHECK IF QUOTE IS USED AS CHARACTER
C     I.E. TO USE AS CHARACTER MUST BE USED TWICE IN SUCCESSION
202   IF(IN(ICOL)-IQUOT) 210,204,210
204   ICOL1 = ICOL+1
      IF(IN(ICOL1)-IQUOT) 900,206,900
206   ICOL = ICOL1
210   LLEN = LLEN+1
      DO 220 J=1,62
      IF(IN(ICOL)-IALPH(J)) 220,250,220
220   CONTINUE
      GO TO 930
250   GO TO (260,270),IFACT
C     ASCII CONSTANT
260   NBIN(LLEN) = IASCI(J)
      GO TO 200
C     EBCDIC CONSTANT
270   NBIN(LLEN) = IEBCD(J)
      GO TO 200
C
C     FOUND VALID DATA
900   ICOL = ICOL+1
      IERR = 1
      IF(LLEN) 930,930,950
C     ERROR IN STRING FORMAT - NO QUOTE
920   IERR = 3
      GO TO 950
C     ERROR IN DATA OR NO DATA FOUND
930   IERR = 2
950   IVAL = NBIN(1)
      RETURN
      END
      SUBROUTINE MCDEF
C
C
C     THIS ROUTINE IS USED FOR MACRO DEFINITIONS.  IT SCANS EACH
C     MODEL LINE AND CHECKS FOR MACRO PARAMETERS.  IT PLACES
C     PARAMETER MARKERS AT THESE LOCATIONS SO THEY CAN BE
C     REFERENCED DURING MACRO EXPANSIONS AND REPLACED WITH ACTUAL
C     PARAMETERS.
C
C
      REAL LC,LODLC,IPVAL,ITABV(200)
      DIMENSION MACIN(80)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
      EQUIVALENCE (MACIN(1),NBIN(1))
C
C     *ENTRY PARAMETERS
C     IN    - MACRO DIRECTIVE LINE
C     MSREC - NEXT AVAILABLE RECORD IN MACRO DISK FILE
C
C     *EXIT PARAMETERS
C     MACRO DEFINITION ON DISK FILE
C     MDISK - CONTAINS STARTING RECORD NUMBER OF MACRO
C     IEND  - SET TO 1 IF END FOUND DURING MACRO
C
      ICHK = 0
      IEND = 0
      IPCNT = 1
      MDISK(MCNT) = MSREC
      NERR = 0
      MCALL(82,1) = ISHRP
      MCALL(83,1) = IDOLR
      MCALL(84,1) = ICHRY
      MCALL(85,1) = ICHRM
      MPARP(1,IPCNT) = 82
      MPARP(2,IPCNT) = 85
      DO 5 LL=1,80
      MACIN(LL) = IN(LL)
      MCALL(LL,1) = IN(LL)
5     CONTINUE
C     SCAN PROTOTYPE LINE FOR PARAMETERS AND FORM PARAMETER TABLE
20    IF(IARG-MCOL) 30,30,130
30    ICOL = IARG
40    IF(IN(ICOL)-ISEMI) 100,130,100
100   IF(IN(ICOL)-ISHRP) 920,110,920
110   ICOL1 = ICOL
      ICOL = ICOL+1
      CALL SYMBL(ICOL)
      IF(IERR-3) 120,920,920
C     FOUND VALID PARAMETER, SAVE IN TABLE
120   IPCNT = IPCNT+1
      MPARP(1,IPCNT) = ICOL1
      MPARP(2,IPCNT) = ICOL-1
      ICOL = ICOL+1
      IF(IERR-2) 130,100,130
130   MPARC(MCNT) = IPCNT
      GO TO 550
C     READ NEXT MODEL STATEMENT AND CHECK FOR PARAMETERS
C     SUBSTITUTE A PARAMETER MARKER TO INDICATE RELATIVE
C     POSITION OF PARAMETER FOR MACRO REFERENCE
200   CALL INOUT(1)
      ITYPE = -1
      IERR = 1
      IERRI(1) = IBLNK
      IERRI(2) = IBLNK
      IERRI(3) = IBLNK
      IERRI(4) = 0
      NERR = 0
      DO 210 LL=1,80
      MACIN(LL) = IN(LL)
210   CONTINUE
      DO 360 LL=IFCOL,MCOL
      IF(MACIN(LL)-ISHRP) 360,310,360
C     CHECK IF VALID PARAMETER
310   DO 350 IPC = 1,IPCNT
      ICOL = MPARP(1,IPC)
      ICOL1 = MPARP(2,IPC)
      IF((LL+ICOL1-ICOL)-MCOL) 320,320,350
320   L = LL
      DO 330 K=ICOL,ICOL1
      IF(MACIN(L)-MCALL(K,1)) 350,325,350
325   L = L+1
330   CONTINUE
C     VALID PARAMETER, PUT IN MARKER
      L = LL
      DO 340 K=ICOL,ICOL1
      MACIN(L) = IPC
      L = L+1
340   CONTINUE
350   CONTINUE
360   CONTINUE
C     GET OPCODE TO CHECK FOR END OR ENDM
      ICOL = IFCOL
      IF(IN(ICOL)-IBLNK) 400,450,400
400   IF(IN(ICOL)-IAST) 410,500,410
410   IF(IN(ICOL)-ICTAB) 420,450,420
C     SKIP OVER LABEL FIELD
420   ICOL = ICOL+1
      IF(IN(ICOL)-IBLNK) 425,470,425
425   IF(IN(ICOL)-ICTAB) 430,470,430
430   IF(IN(ICOL)-ICOLN) 440,470,440
440   IF(ICOL-MCOL) 420,500,500
450   CALL OPCOD(ICOL,ICHK)
      IF(IERR-6) 500,460,500
460   ICOL = ICOL+ICNT
470   ICOL = ICOL+1
      CALL OPCOD(ICOL,ICHK)
C
C     THE FOLLOWING STATEMENT WRITES INTO THE MACRO SOURCE FILE
C
500   MCREC = MSREC
      MSREC = MSREC+1
      CALL INOUT(6)
C     WRITE STATEMENT TO INTERMEDIATE FILE FOR USE BY PASS 2
C     SET LINE SO THAT IT LOOKS LIKE A COMMENT FOR PRINTOUT
550   ITYPE = -1
      IERRI(4) = NERR
      LEN = 0
      IMREC = ISN
      ISN = ISN+1
      CALL INOUT(5)
      LISN = LISN+1
C     CHECK FOR ENDM OR END INSTRUCTIONS
      IF(ICHK-1017) 570,590,570
570   IF(ICHK-1006) 200,580,200
580   IEND = 1
590   RETURN
C     ILLEGAL PARAMETER LIST
920   IERRI(2) = ICHRA
      IERRS = IERRS+1
      IERRI(4) = 1
      NERR = 1
      GO TO 130
      END
      SUBROUTINE MCREF
C
C
C     THIS SUBROUTINE IS USED TO EXPAND A MACRO WHENEVER THERE IS A
C     REFERENCE TO IT.  REPLACE PARAMETERS BY ACTUAL CHARACTERS OF
C     CALL PARAMETERS.  THUS TO PASS 1 IT LOOKS AS THOUGH
C     IT IS JUST READING IN ANOTHER CARD
C
C
      REAL LC,LODLC,IPVAL,ITABV(200)
      DIMENSION MACIN(80)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
      EQUIVALENCE (MACIN(1),NBIN(1))
C
C     *ENTRY PARAMETERS
C     MCREC - DISK RECORD NUMBER OF NEXT MACRO DEFINITON LINE
C
C     *EXIT PARAMETERS
C     MCREC - SET TO NEXT RECORD
C     IN    - LINE SET TO PROCESS WITH MACRO PARAMETERS
C             REPLACED BY ACTUAL PARAMETERS
C
      NREC = MCREC
100   INPNT = 1
      MCPNT = 1
C
C     THE FOLLOWING STATEMENT READS FROM THE MACRO SOURCE FILE.
C
      CALL INOUT(3)
      NREC = NREC+1
      MCREC = NREC
      DO 105 LL=1,80
      IN(LL) = MACIN(LL)
105   CONTINUE
C     PLACE ARGUMENTS FROM MACRO CALL INTO MODEL STATEMENTS AND
C     INTO INPUT BUFFER TO BE USED BY PASS 1
110   IF(MACIN(MCPNT)-100) 115,140,140
115   IF(MACIN(MCPNT)) 140,112,112
112   ISAVE = MACIN(MCPNT)
C     GET PARAMETER NUMBER
      IPARN = ISAVE+MPCNT
      IF(IPARN-MXPAR) 118,118,117
117   IPARN = 1
118   ISTA = MPARP(1,IPARN)
      IFIN = MPARP(2,IPARN)
      IF(ISTA-IFIN) 119,119,130
119   IF((INPNT+IFIN-ISTA)-MCOL) 120,120,910
C     SUBSTITUTE ACTUAL PARAMETER FOR PARAMETER MARKERS
120   DO 122 KK=ISTA,IFIN
      IN(INPNT) = MCALL(KK,MCSET)
      INPNT = INPNT+1
122   CONTINUE
C     SCAN OVER PARAMETER MARKER
130   MCPNT = MCPNT+1
      IF(MACIN(MCPNT)-ISAVE) 110,130,110
140   IN(INPNT) = MACIN(MCPNT)
      IF(INPNT-80) 142,170,170
142   IF(MCPNT-80) 144,150,150
144   INPNT = INPNT+1
      MCPNT = MCPNT+1
      GO TO 110
150   ISTA = INPNT+1
      DO 160 INPNT = ISTA,80
      IN(INPNT) = IBLNK
160   CONTINUE
C     MODEL STATEMENT NOW LOOKS LIKE A STANDARD LINE AND CAN
C     BE PROCESSED BY PASS 1
170   RETURN
C     INSERTION OF PARAMETERS TOO LONG FOR CARD IMAGE
910   IERRI(2) = ICHRC
      IERRI(4) = 1
      IERRS = IERRS+1
      RETURN
      END
      SUBROUTINE LOUT(MODE)
C
C
C     THIS SUBROUTINE IS USED TO OUTPUT THE ASSEMBLER LISTING
C
C
      INTEGER OBIN(2,4)
      REAL IVAL
      REAL LC,LODLC,IPVAL,ITABV(200)
      DIMENSION NUMS(16)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
      EQUIVALENCE (NUMS(1),IALPH(1))
C
C     *ENTRY PARAMETERS
C     LISN  - LINE NUMBER
C     MODE  - INDICATES WHETHER REGULAR LINE OR DIRECTIVE
C         1 = NORMAL LINE
C         2 = NOT USED
C         3 = SPAC DIRECTIVE
C         4 = EJEC DIRECTIVE
C
C     *EXIT PARAMETERS
C     LISN  - UPDATED LINE NUMBER
C
      LISN = LISN+1
C     CONVERT VALUES TO HEXADECIMAL FOR OUTPUT
      DO 30 J=1,4
      IF(J-LLEN) 10,10,20
10    NVAL = IBIN(J)
      CALL VHEX(NVAL,NH1,NH2)
      OBIN(1,J) = NH1
      OBIN(2,J) = NH2
      GO TO 30
20    OBIN(1,J) = IBLNK
      OBIN(2,J) = IBLNK
30    CONTINUE
      IMACP = IBLNK
      IEQUI = IBLNK
      IF(MAC-2) 50,40,50
40    IMACP = IPLUS
      LISN = LISN-1
C     CHECK FOR AN ERROR
50    IF(IERRI(4)) 60,60,200
60    IF(LSOR) 700,700,100
100   IF(MAC-1) 110,200,110
C     CHECK FOR OUTPUT OF MACRO EXPANSION
110   IF(LMAC) 200,700,200
C      CHECK OUTPUT LINE COUNT
200   LINE = LINE+1
      IF(LINE-IOLIN) 400,400,210
C     EJECT TO NEXT PAGE AND WRITE HEADER
210   WRITE(IPRT,1001) (LTITL(I),I=1,28),IPAGE
1001  FORMAT(34H1   MOSTEK XFOR-80 CROSS ASSEMBLER,1X,28A1,5H PAGE,I4,
     1  /,44H    ADDR OBJECT   STMT  LABEL   OPCD OPERAND,
     2  6X,7HCOMMENT,/)
      IPAGE = IPAGE+1
      LINE = 4
400   GO TO (410,410,600,700),MODE
C     LEAVE ADDRESS BLANK IF TYPE = -1 EXCEPT FOR EQU OR DEFL
410   IF(ITYPE) 420,440,440
420   IF(IOPVA-100) 460,430,460
430   IEQUI = IGRAT
      IVAL = IPVAL
      GO TO 450
440   IVAL = LC
450   CALL AHEX(IVAL,1)
      GO TO 500
460   DO 470 J=1,4
      IADDR(1,J) = IBLNK
470   CONTINUE
500   CALL FORMT
      WRITE(IPRT,1002) IERRI(1),IERRI(2),IEQUI,(IADDR(1,J),J=1,4),
     1  (OBIN(1,J),OBIN(2,J),J=1,4),LISN,IMACP,(IN(J),J=1,MLCOL)
1002  FORMAT(1X,7A1,1X,8A1,1X,I4,1X,81A1)
      RETURN
C     PROCESS SPAC DIRECTIVE
600   LINE = LINE+1
      IF(LINE-IOLIN) 610,610,200
610   WRITE(IPRT,1003)
1003  FORMAT(1X)
      IARG = IARG-1
      IF(IARG) 700,700,600
700   RETURN
      END
      SUBROUTINE OUT
C
C
C     THIS SUBROUTINE OUTPUTS THE OBJECT MODULE PRODUCED BY THE
C     EACH CARD CONTAINS A RECORD LENGTH OF UP TO 30 BYTES
C
C
      REAL LC,LODLC,IPVAL,ITABV(200)
      REAL IVAL
      DIMENSION NUMS(16)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
      EQUIVALENCE (NUMS(1),IALPH(1))
C
C     *ENTRY PARAMETERS
C     LOBJ  - 0 = DO NOT FORM OBJECT MODULE
C     LC    - ADDRESS OF INSTRUCTION
C     LODLC - ADDRESS OF LAST OBJECT BYTE PROCESSED
C     IBIN  - OBJECT CODE TO PLACE IN OBJECT MODULE
C
C     *EXIT PARAMETERS
C     IOBIN - PARTIAL OBJCT MODULE RECORD
C     LODLC - UPDATED TO ADDRESS OF LAST BYTE PROCESSED
C
      IF(LOBJ) 120,120,10
10    N = 1
C     CHECK FOR GAP IN LOCATION COUNTER
50    IF(LC-LODLC) 60,90,60
60    IF(LODLC) 70,80,80
70    LODLC = LC
      GO TO 300
80    LODLC = LC
      GO TO 200
C     CHECK FOR END OF ASSEMBLY
90    IF(IEND) 100,100,200
C     SET BYTES OF OBJECT CODE INTO HEXADECIMAL OUTPUT RECORD
C     CHECK FOR MAXIMUM RECORD SIZE
100   IF(IRLEN-30) 110,200,200
110   NN = IBIN(N)
      ICKSM = ICKSM+NN
      IRLEN = IRLEN+1
      CALL VHEX(NN,NH1,NH2)
      IOBIN(ICNT) = NH1
      ICNT = ICNT+1
      IOBIN(ICNT) = NH2
      ICNT = ICNT+1
      LODLC = LODLC+1.
      N = N+1
      IF(N-LLEN) 100,100,120
120   RETURN
C     SET RECORD LENGTH AND OUTPUT NEW RECORD
200   CALL VHEX(IRLEN,NH1,NH2)
      ICKSM = ICKSM+IRLEN
      IOBIN(2) = NH1
      IOBIN(3) = NH2
C     SET CHECKSUM
      J = ICKSM/256
      ICKSM = 256-(ICKSM-J*256)
      CALL VHEX(ICKSM,NH1,NH2)
      IOBIN(ICNT) = NH1
      ICNT = ICNT+1
      IOBIN(ICNT) = NH2
      WRITE(IPCH,1000) (IOBIN(J),J=1,ICNT)
1000  FORMAT(72A1)
C     INITIALIZE FOR NEXT RECORD
300   ICKSM = 0
      IRLEN = 0
      ICNT = 10
      DO 350 J=1,72
      IOBIN(J) = IBLNK
350   CONTINUE
C     INITIALIZE COLON INDICATING START OF RECORD
      IOBIN(1) = ICOLN
C     CHECK FOR END CARD
      IF(IEND) 410,410,400
C     SET ADDRESS INTO RECORD
400   LODLC = IPVAL
410   NN = LODLC/256.
      ICKSM = ICKSM+NN
      CALL VHEX(NN,NH1,NH2)
      IOBIN(4) = NH1
      IOBIN(5) = NH2
      IVAL = NN
      NN = LODLC-IVAL*256.
      ICKSM = ICKSM+NN
      CALL VHEX(NN,NH1,NH2)
      IOBIN(6) = NH1
      IOBIN(7) = NH2
      IOBIN(8) = NUMS(1)
      IOBIN(9) = NUMS(1)
      IF(IEND) 100,100,700
C     PUT OUT RECORD TO INDICATE END OF FILE
700   IOBIN(2) = NUMS(1)
      IOBIN(3) = NUMS(1)
      IOBIN(9) = NUMS(2)
      ICKSM = ICKSM+1
      J = ICKSM/256
      ICKSM = 256-(ICKSM-J*256)
      CALL VHEX(ICKSM,NH1,NH2)
      IOBIN(10) = NH1
      IOBIN(11 )= NH2
      WRITE(IPCH,1000) (IOBIN(J),J=1,11)
      RETURN
      END
      SUBROUTINE SYMTA
C
C
C     THIS SUBROUTINE IS USED TO OUTPUT A SYMBOL TABLE
C     OR CROSS REFERENCE TABLE
C
C
      REAL LC,LODLC,IPVAL,ITABV(200)
      REAL IVAL
      DIMENSION LLAB(4,6),IXOUT(600)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
      EQUIVALENCE (LLAB(1,1),IN(1))
      EQUIVALENCE(IXOUT(1),MDISK(1))
C
C     *ENTRY PARAMETERS
C     LREF  - 1 = PRODUCE CROSS REFERENCE TABLE
C     IXT   - NEGATIVE IF CROSS REFERENCE TABLE OVERFLOWED
C
      IDIV = 256**(ICCNT-1)
      MXLAB = 42*IDIV
      ISTA = 1
      IFIN = 1
      IGX = 0
      IF(LREF) 8,8,6
6     IF(IXT) 7,8,8
7     IXT = -IXT
      WRITE(IPRT,1010) IXT
1010  FORMAT(34H CROSS REFERENCE OVERFLOW AT LINE ,I5)
      LINE = 8
      IXT = 0
8     DO 70 L=1,LTAB
      IF(ITAB(1,L)) 10,70,10
10    IF(ISTA) 30,20,30
20    ISTA = L
30    IFIN = L
70    CONTINUE
C     ALPHABETIZE AND OUTPUT SYMBOLS
140   MM = 0
145   NAME(1) = MXLAB
C     GET NEXT SYMBOL
      LIND = 0
      DO 260 L=ISTA,IFIN
      IF(ITAB(1,L)) 210,260,210
210   DO 230 K=1,IWORD
      IF(ITAB(K,L)-NAME(K)) 240,230,260
230   CONTINUE
240   DO 250 K=1,IWORD
      NAME(K) = ITAB(K,L)
250   CONTINUE
      LIND = L
260   CONTINUE
      IF(LIND) 300,270,300
270   IF(MM) 430,430,400
300   ITAB(1,LIND) = 0
      MM = MM+1
      ICNT = 0
C     DECODE VALUE IN TABLE TO FORM OUTPUT CHARACTERS
      DO 310 K=1,IWORD
      ID = IDIV
      DO 310 L=1,ICCNT
      ICNT = ICNT+1
      NN = NAME(K)/ID
      IF(NN) 312,312,314
312   LLAB(MM,ICNT) = IBLNK
      IF (ICNT-MLAB) 316,315,315
314   NAME(K) = NAME(K)-NN*ID
      LLAB(MM,ICNT) = IALPH(NN)
316   ID = ID/256
310   CONTINUE
C     GET SYMBOL VALUE
315   IVAL = ITABV(LIND)
      IF(IVAL-100000.) 330,330,320
320   IVAL = IVAL-100000.
330   CALL AHEX(IVAL,MM)
      IF(LREF) 340,340,500
340   IF(MM-4) 145,400,400
400   LINE = LINE+1
      IF(LINE-IOLIN) 420,420,410
410   WRITE(IPRT,1002)
1002  FORMAT(1H1)
      LINE = 3
C     OUTPUT NEXT LINE OF SYMBOL TABLE
420   WRITE(IPRT,1003) ((LLAB(II,K),K=1,ICNT),
     1  (IADDR(II,L),L=1,4), II=1,MM)
1003  FORMAT(1X,4(6A1,2X,4A1,6X))
      IF(LIND) 430,430,140
430   RETURN
C     FORM CROSS REFERENCE TABLE
C     WRITE LAST RECORD TO FILE IF NECESSARY
500   IF(IGX) 530,510,530
510   IF(IXPNT) 530,530,515
515   IF(IXCNT) 530,530,520
520   CALL XREFT(1,1)
530   IGX = 1
      LEN = 0
      IXOUT(1) = 0
      ITCNT = MXREF*IXCNT+IXPNT
      IF(ITCNT-MXREF) 580,580,540
C     READ PAGE FROM FILE
540   IXT = 1
550   L = MXREF/128
      I1 = 0
      DO 570 I=1,L
      MCREC = IXT
C
C     THE FOLLOWING STATEMENTS READS THE CROSS REFERENCE FILE
C
      CALL INOUT(4)
      IXT = IXT+1
      DO 560 M1=1,128
      M2 = M1+I1
      IXTAB(M2) = MCORE(M1)
560   CONTINUE
      I1 = I1+128
570   CONTINUE
580   LL = MXREF
      IF(ITCNT-MXREF) 590,600,600
590   LL = ITCNT
600   DO 620 I=1,LL,2
      IF(IXTAB(I)-LIND) 620,610,620
610   LEN = LEN+1
      I1 = I+1
      IXOUT(LEN) = IXTAB(I1)
620   CONTINUE
      ITCNT = ITCNT-MXREF
      IF(ITCNT) 630,630,550
C     OUTPUT CROSS REFERENCES
630   M1 = 1
640   M2 = M1+7
      IF(LEN-8) 650,660,660
650   M2 = M1+LEN-1
660   LINE = LINE+1
      IF(LINE-IOLIN) 680,670,670
670   WRITE(IPRT,1002)
      LINE = 3
680   WRITE(IPRT,1005) (LLAB(1,K),K=1,ICNT),(IADDR(1,K),K=1,4),
     1  (IXOUT(K),K=M1,M2)
1005  FORMAT(1X,6A1,4X,4A1,6X,8I6)
      M1 = M1+8
      LEN = LEN-8
      IF(LEN) 140,140,690
690   DO 700 K=1,4
      IADDR(1,K) = IBLNK
      LLAB(1,K) = IBLNK
700   CONTINUE
      LLAB(1,5)=IBLNK
      LLAB(1,6)=IBLNK
      GO TO 640
      END
      SUBROUTINE XREFT(MODE,NCTL)
C
C     THIS SUBROUTINE ACCUMULATES CROSS REFERENCES
C
      REAL LC,LODLC,IPVAL,ITABV(200)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
C     *ENTRY PARAMETERS
C     MODE  - INDICATES DEFINITION (0), OR REFERENCE (1)
C     NCTL  - 1 INDICATES DO ONLY WRITE TO DISK
C     IXPNT - CURRENT POINTER INTO REFERENCE TABLE
C
C     *EXIT PARAMETERS
C     IXPNT - UPDATED FOR NEW ENTRY IN TABLE
C     IXCNT - INCREMENTED BY ONE IF REFERENCE ARRAY IS FULL
C
      IF(NCTL) 5,5,50
5     IF(IXT) 110,10,10
10    IF(IXPNT-MXREF) 100,30,30
30    IF(IXCNT-IXPAG) 50,40,40
40    IXT = -(LISN+MODE)
      RETURN
C     WRITE OUT PAGE TO FILE
50    K = MXREF/128
      I1 = 0
      DO 70 I=1,K
      DO 60 M1 = 1,128
      M2 = I1+M1
      IXTAB(M1) = IXTAB(M2)
60    CONTINUE
      MCREC = IXT
C
C     THE CROSS REFERENCE FILE IS WRITTEN INTO BY
C     THE FOLLOWING STATEMENT
C
      CALL INOUT(7)
      I1 = I1+128
      IXT = IXT+1
70    CONTINUE
      IF(NCTL) 80,80,110
80    IXCNT = IXCNT+1
      IXPNT = 0
      IF(IXCNT-IXPAG) 100,40,40
C     PUT DEFINITION OR REFERENCE IN TABLE
100   IXPNT = IXPNT+1
      IXTAB(IXPNT) = INDEX
      IXPNT = IXPNT+1
      IXTAB(IXPNT) = (LISN+MODE)*(MODE+MODE-1)
110   RETURN
      END
      SUBROUTINE VHEX(NVAL,NH1,NH2)
C
C
C     THIS ROUTINE CONVERTS A VALUE BETWEEN 0 - 255 TO TWO
C     HEXADECIMAL CHARACTERS.  VALUES OUTSIDE THIS RANGE ARE
C     CONVERTED TO ZEROS
C
C
      REAL LC,LODLC,IPVAL,ITABV(200)
      DIMENSION NUMS(16)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
      EQUIVALENCE(NUMS(1),IALPH(1))
C
C
C     *ENTRY PARAMETERS
C     NVAL  - VALUE TO CONVERT
C
C     *EXIT PARAEMTERS
C     NH1   - HIGH ORDER CHARACTER ON RETURN
C     NH2   - LOW ORDER CHARACTER ON RETURN
C
      IF(NVAL-256) 10,30,30
10    IF(NVAL) 30,100,100
30    NVAL = 0
100   NH1 = 1+NVAL/16
      NH2 = NVAL-(NH1-1)*16+1
      NH1 = NUMS(NH1)
      NH2 = NUMS(NH2)
      RETURN
      END
      SUBROUTINE AHEX(IVAL,INDX)
C
C
C     THIS SUBROUTINE CONVERTS A VALUE BETWEEN 0 -65535 INTO 4
C     HEXADECIMAL CHARACTERS.  VALUES OUTSIDE THIS RANGE ARE RETURNED
C     AS ASTERISKS
C
C
      REAL LC,LODLC,IPVAL,ITABV(200)
      REAL IVAL,IHVAL,J1,IVAL2
      DIMENSION NUMS(16)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
      EQUIVALENCE (NUMS(1),IALPH(1))
C
C     *ENTRY PARAMETERS
C     IVAL  - VALUE TO CONVERT
C     INDX  - INDEX FOR STORAGE OF OUTPUT
C
C     *EXIT PARAMETERS
C     IADDR - IADDR(INDX,1-4) CONTAINS CHARACTERS
C
      J1 = 4096.
      IF(IVAL) 20,5,5
5     IF(IVAL-65536.) 10,20,20
10    IHVAL = IVAL
      DO 15 J=1,4
      M1 = IHVAL/J1
      IVAL2 = M1
      IHVAL = IHVAL-IVAL2*J1
      J1 = J1/16.
      M1 = M1+1
      IADDR(INDX,J) = NUMS(M1)
15    CONTINUE
      RETURN
20    DO 25 J=1,4
      IADDR(INDX,J) = IAST
25    CONTINUE
      RETURN
      END
      SUBROUTINE OPRND(ICOL,IVAL)
C
C     THIS ROUTINE IS USED TO OBTAIN THE ARGUMENTS OR OPERANDS
C     FOR THE VARIOUS OPCODES.  AN OPERAND IS EITHER AN ASSEMBLER
C     DEFINED KEYWORD, AN IMMEDIATE OR ADDRESS VALUE.
C
      REAL IVAL
      REAL LC,LODLC,IPVAL,ITABV(200)
      DIMENSION KEYIF(35),KEYWD(35)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
C
C     SET DATA ARRAY FOR ENCODED KEYWORD AND KEYWORD
C     VALUE,TYPE AND PARENTHESIS INDICATOR.
C
      DATA KEYWD( 1),KEYWD( 2),KEYWD( 3),KEYWD( 4) /4630,2816,3072,3328/
      DATA KEYWD( 5),KEYWD( 6),KEYWD( 7),KEYWD( 8) /3584,3840,0,0/
      DATA KEYWD( 9),KEYWD(10),KEYWD(11),KEYWD(12) /4608,4864,0,0/
      DATA KEYWD(13),KEYWD(14),KEYWD(15),KEYWD(16) /5632,4898,4899,7450/
      DATA KEYWD(17),KEYWD(18),KEYWD(19),KEYWD(20) /0,3085,7168,2832/
      DATA KEYWD(21),KEYWD(22),KEYWD(23),KEYWD(24) /0,3599,4898,0/
      DATA KEYWD(25),KEYWD(26),KEYWD(27),KEYWD(28) /6681,9216,6157,4899/
      DATA KEYWD(29),KEYWD(30),KEYWD(31),KEYWD(32) /5888,4630,6671,6656/
      DATA KEYWD(33),KEYWD(34),KEYWD(35)           /0,6180,3328/
      DATA KEYIF( 1),KEYIF( 2),KEYIF( 3),KEYIF( 4) /282,452,4,70/
      DATA KEYIF( 5),KEYIF( 6),KEYIF( 7),KEYIF( 8) /132,196,0,0/
      DATA KEYIF( 9),KEYIF(10),KEYIF(11),KEYIF(12) /260,524,0,0/
      DATA KEYIF(13),KEYIF(14),KEYIF(15),KEYIF(16) /324,14170,16218,410/
      DATA KEYIF(17),KEYIF(18),KEYIF(19),KEYIF(20) /0,26,1036,412/
      DATA KEYIF(21),KEYIF(22),KEYIF(23),KEYIF(24) /0,154,14153,0/
      DATA KEYIF(25),KEYIF(26),KEYIF(27),KEYIF(28) /2080,540,1052,16201/
      DATA KEYIF(29),KEYIF(30),KEYIF(31),KEYIF(32) /3616,389,2592,3104/
      DATA KEYIF(33),KEYIF(34),KEYIF(35)           /0,28,1564/
C
C     * ENTRY PARAMETERS
C     NJMP  - OPCODE TYPE
C        0 = CALL, JUMP AND RETURN INSTRUCTIONS
C        1 = ALL OTHERS
C     ICOL  - STARTING COLUMN OF SCAN
C
C     * EXIT PARAMETERS
C     ICOL  - FINAL COLUMN OF SCAN
C     KWTYP - TYPE OF OPERAND
C        1 = A,B,C,D,E,H,L(HL)
C        2 = (IX+D),(IY+D)
C        3 = (SP),(BC),(DE),I,R
C        4 = N,NN  (IMMEDIATE VALUE)
C        5 = (NN)  (ADDRESS VALUE)
C        6 = BC,DE,HL,IX,IY,SP
C        7 = AF,AF",C,NC,Z,NZ
C        8 = M,P,PE,PO,(C)
C     KWVAL - VALUE OF OPERAND
C     KWIND - INDEX OF KEYWORD IN TABLE, FORMED BY HASH CODE
C     IVAL  - VALUE FOR 4 OR 5 ABOVE
C     IERR  - ERROR CODE, SAME AS FROM SUBROUTINE SCAN
C             EXCEPT FOR 6 = KEYWORD ERROR
C
C
      IVAL = 0
      LPAR = 0
      KWTYP = 0
      KWIND = 0
      KWVAL = 0
      ICOL1 = ICOL
      IF(IN(ICOL)-ILPAR) 20,10,20
C     SET LEADING PARENTHESIS FLAG
10    LPAR = 1
      ICOL = ICOL+1
C     GET AND CHECK FOR KEYWORD
20    CALL SYMBL(ICOL)
      NDIV=256**(ICCNT-2)
      NAME(1)=NAME(1)/NDIV
      IF(IERR-4) 30,500,500
C     VALID SYMBOL CHECK LENGTH
30    IF(LABCT-2) 40,40,500
C     FORM INDEX INTO KEYWORD TABLE AND CHECK VALIDITY
40    NSYSM = INDEX
      IF(NJMP) 80,80,50
50    KWIND = NSYSM+LABCT+LABCT-11
      IF(KWIND-32) 70,70,60
60    KWIND = KWIND-32
70    IF(KWIND-22) 120,120,500
80    IF(NSYSM-53) 100,90,100
90    NSYSM = 49
100   KWIND = 22+NSYSM-(NSYSM/16)*16
      IF(KWIND-35) 110,110,500
110   IF(KWIND-22) 500,500,120
C     CHECK TABLE ENTRY
120   IF(NAME(1)-KEYWD(KWIND)) 500,200,500
C     VALID KEYWORD - GET KEYWORD PARAMETERS
200   KWPAR = KEYIF(KWIND)
      KWVAL = KWPAR/64
      KWTYP = (KWPAR-KWVAL*64)/4
      KWPAR = KWPAR-KWVAL*64-KWTYP*4
      IF(LPAR) 210,210,300
C     NO LEADING PARENTHESIS, CHECK IF PARENTHESIS REQUIRED
210   IF(KWPAR-1) 220,900,220
C     CHECK IF AF"
220   IF(KWIND-20) 610,230,610
230   IF(IN(ICOL)-IQUOT) 610,240,610
240   KWIND = 17
      KWVAL = 10
      GO TO 600
C     LEADING PARENTHESIS, CHECK IF PARENTHESIS NOT ALLOWED
300   IF(KWPAR) 900,900,310
310   IF(IN(ICOL)-IRPAR) 400,320,400
320   IF(NJMP) 600,600,330
C     CHECK FOR (C)
330   KWTYP = 8
      IF(KWIND-4) 340,600,340
C     FORM SPECIAL KEYWORD TYPE - (HL),2,3
340   KWTYP = 3
      IF(KWIND-16) 350,600,600
C     CHECK IF (IX),(IY)
350   KWTYP = 2
      IVAL = 0
      IF(KWIND-14) 360,900,900
C     SET TO (HL)
360   KWTYP = 1
      KWVAL = 6
      GO TO 600
C     CHECK FOR (IX+D),(IY+D)
400   KWTYP = 2
      IF(NJMP) 900,900,410
410   IF(KWVAL-200) 900,900,420
420   IF(IN(ICOL)-IPLUS) 430,440,430
430   IF(IN(ICOL)-IMIN) 900,440,900
C     SET PARENTHESIS FLAG FOR SCAN ROUTINE
440   NSPAR = 1
      GO TO 510
C     GET VALUE FOR INDEXING,IMMEDIATE OR EXTENDED ADDRESSING
500   ICOL = ICOL1
510   CALL SCAN(ICOL,IVAL)
      GO TO(520,1000,520,520,1000),IERR
520   IF(KWTYP-2) 530,1000,530
C     SET TYPE TO IMMEDIATE OR EXTENDED
530   KWTYP = 4+LPAR
      GO TO 1000
C     CHECK THAT OPERAND ENDS WITH VALID DELIMITER
600   ICOL = ICOL+1
610   NCHAR = IN(ICOL)
      IERR = 1
      IF(NCHAR-IBLNK) 620,1000,620
620   IF(NCHAR-ICOMM) 630,910,630
630   IF(NCHAR-ISEMI) 640,1000,640
640   IF(NCHAR-ICTAB) 900,1000,900
C     SET ERROR RETURN FLAG
C     INVALID KEYWORD OR KEYWORD SYNTAX
900   IERR = 6
      GO TO 1000
C     COMMA TERMINATES OPERAND
910   IERR = 4
1000  RETURN
      END
      SUBROUTINE CODEZ(ICOL)
C
C     THIS ROUTINE PROCESSES THE OPCODES FOR THE Z-80
C
      REAL IVAL,IVAL1
      REAL LC,LODLC,IPVAL,ITABV(200)
      DIMENSION IEXV(5),IEXVI(5)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
      EQUIVALENCE (IBIN(1),IBIN1)
      EQUIVALENCE (IBIN(2),IBIN2)
      EQUIVALENCE (IBIN(3),IBIN3)
      EQUIVALENCE (IBIN(4),IBIN4)
      DATA IEXV(1),IEXV(2),IEXV(3),IEXV(4),IEXV(5) /2724,2807,1907,
     1  1920,1921/
      DATA IEXVI(1),IEXVI(2),IEXVI(3),IEXVI(4),IEXVI(5)
     1  /8,235,227,221,253/
C
C     * ENTRY PARAMETERS
C     ICOL  - STARTING COLUMN OF SCAN
C     ITYPE - INSTRUCTION TYPE FROM OPCOD
C
C     * EXIT PARAMETERS
C     ICOL  - FINAL COLUMN OF SCAN
C     LEN   - LENGTH OF INSTRUCTION (BYTES)
C     IBIN  - CONTAINS VALUE OF INSTRUCTION
C     IERR  - ERROR CODE - SAME AS FOR OPROD EXCEPT
C             7 = QUESTIONABLE OPERANDS, 8 = VALUE ERROR
C
      IERR = 1
      IERR1 = 1
      LEN = 4
      IF(ITYPE-4) 8400,8150,4000
4000  NJMP = 0
      KWCNT = 0
C     CHECK FOR RET INSTRUCTION AND 1 OR 2 OPERAND INSTRUCTIONS
      IF(ITYPE-16) 4010,6650,4020
4010  NJMP = 1
4020  CALL OPRND(ICOL,IVAL)
      GO TO  (4030,9000,4030,4030,9000,9000),IERR
4030  IF(ITYPE-9) 4080,4080,4040
C     CHECK IF ADDITIONAL ARGUMENTS
4040  IF(ITYPE-16) 4060,4080,4050
4050  IF(IN(ICOL)-ICOMM) 4080,4070,4080
4060  NN = 2
      IF(IN(ICOL)-ICOMM) 9430,4070,9430
C     GET NEXT OPERAND AND SAVE CURRENT PARAMETERS
4070  ICOL = ICOL+1
      KWTY1 = KWTYP
      KWVA1 = KWVAL
      IVAL1 = IVAL
      KWIN1 = KWIND
      KWCNT = 1
      IERR1 = IERR
      CALL OPRND(ICOL,IVAL)
      GO TO (4080,9000,4080,4080,9000,9000),IERR
C     PROCESS INSTRUCTIONS ACCORDING TO OPCODE
4080  KTYPE = ITYPE-4
      GO TO(4100,4200,4300,4400,4600,4700,6000,6100,6200,
     1  6400,6500,6600,6700,6800,6900),KTYPE
C
C     PROCESS RST,IM
C
4100  LEN = 1
      IF(KWTYP-4) 9150,4105,9150
4105  IF(IOPVA-70) 4110,4150,4110
4110  K = IVAL/8.
      IVAL1 = K
      I = IVAL-IVAL1*8.
      IF(I) 9350,4120,9350
4120  IF(K) 9350,4130,4130
4130  IF(K-8) 4140,9350,4140
4140  IBIN1 = IOPVA+K*8
      GO TO 8400
C     IM
4150  LEN = 2
      IBIN2 = 70
      IF(IVAL) 9350,8160,4160
4160  IBIN2 = 86
      IF(IVAL-2.) 8160,4170,9350
4170  IBIN2 = 94
      GO TO 8160
C
C     PROCESS DJNZ
C
4200  IBIN1 = 16
      GO TO 8000
C
C     PROCESS ROTATE AND SHIFT INSTRUCTIONS
4300  IVAL1 = 0
      GO TO 6110
C
C     PROCESS SUB,AND,XOR,OR,CP,INC,DEC
4400  IF(KWTYP-2) 4410,4420,4430
C     REGISTER ADDRESSING
4410  IBIN1 = IOPVA+KWVAL
C     CHECK IF INC,DEC
      IF(IOPVA-5) 4630,4630,8400
C     INDEXED ADDRESSING
4420  IBIN2 = IOPVA+6
      IF(IOPVA-5) 4425,4425,8100
4425  IBIN2 = IOPVA+48
      GO TO 8100
4430  IF(KWTYP-4) 9100,4440,4460
C     IMMEDIATE ADDRESSING - CHECK IF INC,DEC
4440  IF(IOPVA-5) 9100,9100,4450
4450  IBIN1 = IOPVA+70
      GO TO 8200
C     CHECK FOR 16 BIT INC,DEC
4460  IF(IOPVA-5) 4470,4470,9100
4470  IF(KWTYP-6) 9100,4480,9100
4480  IF(KWVAL-200) 4490,4500,4500
C     SOURCE IS BC,DE,HL
4490  IBIN1 = (IOPVA+KWVAL)*8-29
      GO TO 8400
C     SOURCE IS IX,IY
4500  IBIN2 = IOPVA*8+3
      GO TO 8050
C
C     PROCESS POP,PUSH
C
4600  IF(KWTYP-6) 9100,4610,4610
4610  IF(KWIND-16) 4620,9100,4620
4620  IF(KWVAL-10) 4630,9100,4640
C     SOURCE IS AF,BC,DE,HL
4630  IBIN1 = IOPVA+8*KWVAL
      GO TO 8400
C     SOURCE IS IX,IY
4640  IBIN2 = IOPVA+32
      GO TO 8050
C
C     PROCESS LD
C
4700  GO TO(4800,5000,5200,9100,5400,5600,9100),KWTY1
C     *** DESTINATION IS A-L,(HL)
4800  GO TO(4820,4840,4860,4900,4920,9100,9100,9100),KWTYP
C     SOURCE IS A-L,(HL)
4820  LEN = 1
      IBIN1 = 64+8*KWVA1+KWVAL
C     CHECK FOR LD  (HL),(HL)
      IF(IBIN1-118) 9000,9150,9000
C     SOURCE IS INDEXED
4840  IBIN2 = 70+8*KWVA1
      GO TO 5020
C     SOURCE IS (BC),(DE),I,R - CHECK A IS DESTINATION
4860  IF(KWVA1-7) 9100,4870,9100
4870  IF(KWVAL-6) 4880,9100,4890
4880  IBIN1 = 10+KWVAL*8
      GO TO 8400
C     SOURCE IS I,R
4890  IBIN2 = 79+KWVAL
      GO TO 8160
C     SOURCE IS IMMEDIATE BYTE
4900  IBIN1 = 6+8*KWVA1
      GO TO 8200
C     SOURCE IS EXTENDED ADDRESS - CHECK A IS DESTINATION
4920  IBIN1 = 58
      IF(KWVA1-7) 9100,8250,9100
C     *** DESTINATION IS INDEXED
5000  IF(KWTYP-1) 9100,5010,5050
C     SOURCE IS A-L
5010  IBIN2 = 112+KWVAL
      KWVAL = KWVA1
      IVAL = IVAL1
5020  IF(IBIN2-118) 8100,9100,8100
5050  IF(KWTYP-4) 9100,5060,9100
C     SOURCE IS IMMEDIATE BYTE
5060  LEN = 4
      IBIN1 = KWVA1
      IBIN2 = 54
      IF (IVAL-256.) 5090,5070,5070
5070  IF (IVAL-65280.) 9350,5080,5080
5080  IVAL=IVAL-65280.
5090  IBIN4 = IVAL
      IVAL = IVAL1
      GO TO 8105
C     *** DESTINATION IS (BC),(DE),I,R - CHECK A IS DESTINATION
5200  IF(KWIND-2) 9100,5210,9100
5210  IF(KWVA1-6) 5220,9100,5230
5220  IBIN1 = 2+KWVA1*8
      GO TO 8400
C     DESTINATION IS I,R
5230  IBIN2 = 63+KWVA1
      GO TO 8160
C     *** DESTINATION IS EXTENDED ADDRESS
5400  IVAL = IVAL1
      IF(KWIND-2) 5420,5410,5420
C     SOURCE IS A
5410  IBIN1 = 50
      GO TO 8250
5420  IF(KWTYP-6) 9100,5430,9100
5430  IF(KWVAL-4) 5450,5460,5440
5440  IF(KWVAL-6) 5450,5450,5470
C     SOURCE IS BC,DE,SP
5450  IBIN1 = 237
      IBIN2 = 67+KWVAL*8
      GO TO 8310
C     SOURCE IS HL
5460  IBIN1 = 34
      GO TO 8300
C     SOURCE IS IX,IY
5470  IBIN1 = KWVAL
      IBIN2 = 34
      GO TO 8310
C     *** DESTINATION IS BC,DE,HL,SP,IX,IY
5600  IF(KWTYP-4) 9100,5620,5610
5610  IF(KWTYP-6) 5700,5800,9100
C     SOURCE IS IMMEDIATE VALUE
5620  IF(KWVA1-6) 5630,5630,5640
C     DESTINATION IS BC,DE,HL,SP
5630  IBIN1 = 1+8*KWVA1
      GO TO 8250
C     DESTINATION IS IX,IY
5640  LEN = 4
      IBIN1 = KWVA1
      IBIN2 = 33
      GO TO 8260
C     SOURCE IS EXTENDED ADDRESS
5700  IF(KWVA1-4) 5720,5730,5710
5710  IF(KWVA1-6) 5720,5720,5740
C     DESTINATION IS BC,DE,SP
5720  IBIN1 = 237
      IBIN2 = 75+KWVA1*8
      GO TO 8310
C     DESTINATION IS HL
5730  IBIN1 = 42
      GO TO 8300
C     DESTINATION IS IX,IY
5740  IBIN1 = KWVA1
      IBIN2 = 42
      GO TO 8310
C     CHECK FOR SP AS DESTINATION
5800  IF(KWVA1-6) 9100,5810,9100
5810  IF(KWVAL-4) 9100,5820,5830
C     SOURCE IS HL
5820  IBIN1 = 249
      GO TO 8400
C     SOURCE IS IX,IY
5830  IBIN2 = 249
      IF(KWVAL-200) 9100,8050,8050
C
C     PROCESS EX
C
6000  KWIND = 100*(KWIN1+KWTY1)+KWIND+KWTYP
      LEN = 2
      DO 6010 I=1,5
      IF(KWIND-IEXV(I)) 6010,6020,6010
6010  CONTINUE
      GO TO 9150
6020  IBIN1 = IEXVI(I)
      IBIN2 = 227
      IF(KWVAL-200) 8400,8050,8050
C
C     PROCESS BIT,SET,RES
C
6100  IF(KWTY1-4) 9100,6110,9100
6110  IF(KWTYP-2) 6120,6130,9100
C     SOURCE IS A-L,(HL)
6120  LEN = 2
      IBIN1 = 203
      NN = 2
      GO TO 6140
C     SOURCE IS INDEXED
6130  LEN = 4
      NN = 4
      IBIN1 = KWVAL
      IBIN2 = 203
      KWVAL = 6
6140  IBIN(NN) = IOPVA+KWVAL
      IF(IVAL1) 9350,6150,6150
6150  IF(IVAL1-7.) 6160,6160,9350
6160  KWVAL = IVAL1
      IBIN(NN) = IBIN(NN)+8*KWVAL
      IF(LEN-4) 9000,8105,8105
C
C     PROCESS ADD,ADC,SBC
C
C     CHECK IF A IS FIRST OPERAND
6200  IF(KWIN1-2) 6210,4400,6210
6210  IF(KWTY1-6) 9100,6220,9100
6220  IF(KWTYP-6) 9100,6230,9100
6230  IF(KWVA1-4) 9100,6240,6280
C     HL IS DESTINATION
6240  IF(KWVAL-200) 6250,9100,9100
C     CHECK FOR ADD INSTRUCTION
6250  IF(IOPVA-128) 9100,6260,6270
6260  IBIN1 = 9+KWVAL*8
      GO TO 8400
6270  IBIN2 = 142+KWVAL*8-(IOPVA/2)
      GO TO 8160
6280  IF(KWVA1-200) 9100,9100,6290
C     DESTINATION IS IX,IY
6290  IF(KWVAL-4) 6300,9100,6300
6300  IBIN2 = 9+KWVAL*8
      KWVAL = KWVA1
      IF(IBIN2-256) 8050,6310,6310
6310  IBIN2 = 41
      IF(KWIN1-KWIND) 9100,8050,9100
C
C     PROCESS OUT
C
6400  IVAL = IVAL1
      I = KWTYP
      KWTYP = KWTY1
      KWTY1 = I
      KWIN1 = KWIND
      KWVA1 = KWVAL
      IBIN1 = 211
      GO TO 6510
C
C     PROCESS IN
C
6500  IBIN1 = 219
6510  LEN = 2
      IF(KWTY1-1) 9100,6520,9100
6520  IF(KWIN1-2) 6540,6530,6540
C     CHECK FOR IMMEDIATE ADDRESSING
6530  IF(KWTYP-5) 9100,8200,6540
C     HAVE REGISTER INDIRECT ADDRESSING
6540  IF(KWTYP-8) 9100,6550,9100
6550  IBIN2 = IOPVA+KWVA1*8
      GO TO 8160
C
C     PROCESS RET
C
6600  IF(KWTYP-7) 9100,6610,6610
6610  IBIN1 = IOPVA+KWVAL
      GO TO 8400
C     TEST FOR UNCONDITIONAL RETURN
6650  IBIN1 = 201
      IF(ICOL-MCOL) 6660,8400,8400
6660  IF(IN(ICOL)-ISEMI) 4020,8400,4020
C
C     PROCESS JR
C
6700  IF(KWTYP-4) 9100,6710,9100
6710  IBIN1 = 24
      IF(KWCNT) 8000,8000,6720
C     CONDITIONAL JUMP
6720  IF(KWTY1-7) 9100,6740,9100
6740  IBIN1 = 32+KWVA1
      GO TO 8000
C
C     PROCESS CALL
C
6800  IBIN1 = 205
      IF(KWCNT) 6960,6960,6940
C
C     PROCESS JP
C
6900  IBIN1 = 195
      IF(KWCNT) 6910,6910,6940
C     HAVE UNCONDITIONAL OR REGISTER INDEXED JUMP
6910  IF(KWTYP-2) 6920,6930,6960
6920  IBIN1 = 233
      GO TO 8400
6930  IBIN2 = 233
      GO TO 8050
C     CONDITIONAL JUMP OR CALL
6940  IF(KWTY1-7) 9100,6950,6950
6950  IBIN1 = IOPVA+KWVA1
6960  IF(KWTYP-4) 9100,8300,9100
C
C     FORM AND/OR CHECK ADDRESSING MODE VALUES
C
C     RELATIVE ADDRESS BYTE
8000  LEN = 2
      NN = 2
      IVAL = IVAL-2.
      IF(IVAL) 8010,8110,8110
8010  IVAL = IVAL+65536.
      GO TO 8110
C     2 BYTE INSTRUCTION USING IX OR IY
8050  IBIN1 = KWVAL
      LEN = 2
      GO TO 9000
C     INDEXED ADDRESSING - CHECK DISPLACEMENT
8100  LEN = 3
      IBIN1 = KWVAL
8105  NN = 3
8110  IF(IVAL-128.) 8140,8120,8120
8120  IF(IVAL-65408.) 9350,8130,8130
8130  IVAL = IVAL-65280.
8140  IBIN(NN) = IVAL
      GO TO 9000
C     2 BYTE INSTRUCTION WITH ED(16) AS FIRST BYTE
8150  IBIN2 = IOPVA
8160  IBIN1 = 237
      LEN = 2
      GO TO 9000
C     2 BYTE IMMEDIATE INSTRUCTION
8200  LEN = 2
      IF(IVAL-256.) 8230,8210,8210
8210  IF(IVAL-65280.) 9350,8220,8220
8220  IVAL = IVAL-65280.
8230  IBIN2 = IVAL
      GO TO 9000
C     3 OR 4 BYTE IMMEDIATE INSTRUCTION
8250  LEN = 3
8260  GO TO 8320
C     3 OR 4 BYTE EXTENDED ADDRESSING INSTRUCTION
8300  LEN = 3
      GO TO 8320
8310  LEN = 4
8320  IBIN(LEN) = IVAL/256.
      IVAL1 = IBIN(LEN)
      NN = LEN-1
      IBIN(NN) = IVAL-IVAL1*256.
      GO TO 9000
C     1 BYTE INSTRUCTIONS
8400  LEN = 1
9000  NN=IERR
      GO TO 9400
C     QUESTIONABLE OPERANDS
9100  LEN = 4
9150  NN = 7
      GO TO 9400
C     VALUE ERROR
9350  NN = 8
9400  IF(IERR1-3) 9420,9410,9420
9410  IERR = 3
9420  IF(IERR-3) 9430,9440,9430
9430  IERR = NN
9440  RETURN
      END
      SUBROUTINE FORMT
C
C     THIS ROUTINE IS USED TO FORMAT THE OUTPUT LISTING
C     INTO THE SPECIFIED COLUMNS
C
      DIMENSION NBUF(80)
      REAL LC,LODLC,IPVAL,ITABV(200)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
      EQUIVALENCE (MCALL(1,1),NBUF(1))
C
C     *ENTRY PARAMETERS
C     IN    - CONTAINS LINE TO FORMAT
C
C     *EXIT PARAMETERS
C     IN    - FORMATTED LINE
C
C     SET LABEL,OPCODE,ARGUMENT,COMMENT COLUMNS
      KLABC = 1
      KOPCC = 9
      KARGC = 14
      KCOMC = 27
      DO 100 I=1,80
      NBUF(I) = IBLNK
100   CONTINUE
      NPNT = KLABC
      ICOL = IFCOL
      LABCT = 1
      IF(IN(ICOL)-IAST) 110,900,110
C     GET LABEL FIELD
110   NSPAR = 1
      CALL FIELD(ICOL)
      NSPAR = 0
      IF(IERR-3) 130,120,900
120   ICOL = ICOL+1
      GO TO 140
130   IF(LABCT-IFCOL) 140,140,210
140   ICOL1 = ICOL-1
      DO 150 I=LABCT,ICOL1
      NBUF(NPNT) = IN(I)
      NPNT = NPNT+1
150   CONTINUE
      NPNT = NPNT+1
      LABCT = ICOL+1
C     GET OPCODE FIELD
200   CALL FIELD(ICOL)
210   GO TO(230,230,230,530,500,530),IERR
230   IF(NPNT-KOPCC) 240,250,250
240   NPNT = KOPCC
250   ICOL1 = ICOL-1
      DO 260 I=LABCT,ICOL1
      NBUF(NPNT) = IN(I)
      NPNT = NPNT+1
260   CONTINUE
      NPNT = NPNT+1
      LABCT = ICOL+1
C     GET ARGUMENT FIELD
300   IF(NPNT-KARGC) 310,320,320
310   NPNT = KARGC
C     CHECK IF ARGUMENT EXISTS FOR INSTRUCTION
320   IF(ITYPE) 330,400,350
330   IF(IOPVA-15) 340,500,340
340   IF(IOPVA-17) 400,500,400
350   IF(ITYPE-3) 400,500,360
360   IF(ITYPE-4) 400,500,400
400   CALL FIELD(ICOL)
      IF(IERR-5) 420,500,600
420   ICOL1 = ICOL-1
      DO 430 I=LABCT,ICOL1
      NBUF(NPNT) = IN(I)
      NPNT = NPNT+1
430   CONTINUE
      NPNT = NPNT+1
C     GET COMMENT FIELD
500   IF(NPNT-KCOMC) 510,520,520
510   NPNT = KCOMC
520   CALL FIELD(ICOL)
      IF(IERR-5) 530,530,600
530   DO 550 I=LABCT,80
      IF(NPNT-80) 540,540,600
540   NBUF(NPNT) = IN(I)
      NPNT = NPNT+1
550   CONTINUE
C     PLACE FORMATTED LINE INTO IN
600   DO 610 I=1,80
      IN(I) = NBUF(I)
610   CONTINUE
900   RETURN
      END
      SUBROUTINE FIELD(ICOL)
C
C     THIS ROUTINE OBTAINS THE STARTING AND ENDING COLUMNS
C     OF THE NEXT SOURCE FIELD
C
      REAL LC,LODLC,IPVAL,ITABV(200)
      COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE
      COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR
      COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT
      COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR
      COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50)
      COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80)
      COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC
      COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF
      COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80)
      COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI
      COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL
      COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50)
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL
      COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY
      COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128)
C
C     *ENTRY PARAMETERS
C     ICOL  - STARTING COLUMN OF SCAN
C     NSPAR - 1 = COLON CAN BE USED AS TERMINATOR
C
C     *EXIT PARAMETERS
C     ICOL  - ENDING COLUMN OF SCAN
C     LABCT - COLUMN WHERE FIELD STARTS
C     IERR  - RETURN STATUS
C         1 = SCAN ENDS ON BLANK OR TAB
C         2 = SCAN ENDS WITH SEMICOLON
C         3 = SCAN ENDS WITH A COLON
C         4 = FIELD TERMINATES PAST LAST COLUMN
C         5 = FIRST NON BLANK WAS A SEMICOLON
C         6 = NO FIELD FOUND
C
C     SCAN TO START OF FIELD
100   IF(ICOL-MCOL) 110,110,960
110   NCHAR = IN(ICOL)
      IF(NCHAR-IBLNK) 120,140,120
120   IF(NCHAR-ICTAB) 130,140,130
130   LABCT = ICOL
      IF(NCHAR-ISEMI) 200,950,200
140   ICOL = ICOL+1
      GO TO 100
C     GET END OF FIELD
200   IF(ICOL-MCOL) 210,210,940
210   NCHAR = IN(ICOL)
      IF(NCHAR-IBLNK) 220,910,220
220   IF(NCHAR-ICTAB) 230,910,230
230   IF(NCHAR-ISEMI) 240,920,240
240   IF(NSPAR) 260,260,250
250   IF(NCHAR-ICOLN) 260,930,260
260   IF(NCHAR-IQUOT) 300,270,300
C     GET END OF STRING
270   ICOL = ICOL+1
      IF(IN(ICOL)-IQUOT) 270,280,270
280   ICOL = ICOL+1
      IF(IN(ICOL)-IQUOT) 200,270,200
300   ICOL = ICOL+1
      GO TO 200
C
910   IERR = 1
      GO TO 990
920   IERR = 2
      GO TO 990
930   IERR = 3
      GO TO 990
940   IERR = 4
      GO TO 990
950   IERR = 5
      GO TO 990
960   IERR = 6
990   RETURN
      END
