C 
C 
C     META ASSEMBLER ASSEMBLY PROGRAM  VERSION 5.0
C     FOR AMD 2900, INTEL 3000, ETC.
C     COPYRIGHT 1980
C     MICROTEC
C     P.O. BOX 60337
C     SUNNYVALE, CALIFORNIA 94088 
C 
C     PROGRAM UPDATED  JULY 1980
C 
C 
C     THE VARIABLES PASSED IN COMMON ARE DEFINED BELOW
C 
C 
C     CVAL  = THE VALUE OF A NUMERIC CONSTANT OR LABEL
C     ECOL  = COLUMN IN WHICH ERROR WAS DETECTED
C     FLEN  = LENGTH OF DEFINITION FIELD CURRENTLY BEING SCANNED
C     FTYPE = FIELD TYPE FOR DEFS AND SUBS
C     IADDR = ARRAY TO HOLD HOLLERITH ADDRESS VALUES
C     IALPH = ALPHANUMERIC CHARACTER SET
C     IAMP  = HOST COMPUTER REPRESENTATION OF A HOLLERITH AMPERSAND 
C     IAST  = HOST COMPUTER REPRESENTATION OF A HOLLERITH ASTERISK
C     IATT  = LEGAL FIELD ATTRIBUTES OR MODIFIERS 
C     IBIT  = NUMBER OF BITS PER HOST COMPUTER WORD 
C     IBLNK = HOST COMPUTER REPRESENTATION OF A HOLLERITH BLANK 
C     IBUG  = DEBUG PARAMETER 
C     ICCNT = NUMBER OF CHARACTERS PER HOST COMPUTER WORD 
C     ICHAR = CURRENT CHARACTER POINTED TO IN INPUT BUFFER
C     ICHK  = CURRENT OPCODE VALUE
C     ICNT  = LINE COUNT FOR SPACE DIRECTIVE
C     ICOLN = HOST COMPUTER REPRESENTATION OF A HOLLERITH COLON 
C     ICOMM = HOST COMPUTER REPRESENTATION OF A HOLLERITH COMMA 
C     ICOL  = CURRENT COLUMN NUMBER FOR SCAN
C     ICRD  = LOGICAL UNIT NUMBER OF DEFINITION FILE
C     ICTAB = HOST COMPUTER REPRESENTATION OF A TAB CHARACTER 
C     IDFLE = LOGICAL UNIT NUMBER OF DEFINITION FILE
C     IDIV  = HOST COMPUTER REPRESENTATION OF A HOLLERITH DIVIDE SIGN 
C     IDOLR = HOST COMPUTER REPRESENTATION OF A HOLLERITH DOLLAR SIGN 
C     IDREC = RECORD NUMBER FOR DIFINITION FILE 
C     IDUP  = DELAYED DUP DIRECTIVE COUNT 
C     IEND  = FLAG INDICATING END OF ASSEMBLY SOURCE
C     IERRL = ERROR INDICATOR FOR LABELS
C     IERRI = ERROR INDICATOR FOR OPCODES AND OPERANDS
C     IERR  = ERROR INDICATOR 
C     IERRS = TOTAL NUMBER OF ERRORS
C     IFBIT = MAXIMUM NUMBER OF BITS IN A FIELD 
C     IFCOL = FIRST COLUMN OF SCAN
C     IFCTL = IF CONTROL FLAG 
C     IFLD  = FIELD DEFINITION TABLE
C     IFORM = FORMS CONTROL CHARACTER 
C     IFPAR = ARRAY FOR CONDITIONAL ASSEMBLY INFORMATION DURING NESTING 
C     IFSET = IF NESTING LEVEL
C     IGRAT = HOST COMPUTER REPRESENTATION OF A HOLLERITH GRATER THAN 
C     ILEN  = EXPLICIT FIELD FENGTH FOR EXPRESSIONS AND DON'T CARES 
C     ILESS = HOST COMPUTER REPRESENTATION OF A HOLLERITH LESS THAN 
C     ILPAR = HOST COMPUTER REPRESENTATION OF A LEFT PARENTHESIS
C     IMBU1 - TEMPORARY BUFFER FOR VARIBLES SAVED IN INTERMEDIATE FILE
C     IMFLE = LOGICAL UNIT NUMBER OF OPTIONAL INTERMEDIATE FILE 
C     IMIN  = HOST COMPUTER REPRESENTATION OF A HOLLERITH MINUS SIGN
C     IMREC = RECORD NUMBER FOR OPTIONAL INTERMEDIATE FILE
C     IMULT = HOST COMPUTER REPRESENTATION OF A HOLLERITH MULTIPLY SIGN 
C     IN    = INPUT BUFFER (FOR SCAN) 
C     INB   = INPUT BUFFER (FOR CONTINUATION LINES) 
C     IND   = ARRAY USED TO NOLD LINE TO BE DUPLICATED
C     INDEX = INDEX OF CURRENT SYMBOL INTO SYMBOL TABLE 
C     INDET = INDEX OF LABEL INTO SYMBOL TABLE
C     IOBIN = OBJECT MODULE RECORD BUFFER 
C     IOFLG = FLAG THAT INDICATES NOTHING WRITTEN TO OBJECT MODULE FILE 
C     IOLIN = NUMBER OF LINES PER OUTPUT PAGE 
C     IOPVA = OPCODE VALUE
C     IOREC = RECORD NUMBER FOR OUTPUT OBJECT MODULE FILE 
C     IOVER = INSTRUCTION OVERLAY INDICATOR 
C     IPAGE = CURRENT PAGE NUMBER 
C     IPASS = PASS FLAG, 1=PASS 1, 2=PASS 2 
C     IPCH  = LOGICAL UNIT NUMBER OF OUTPUT OBJECT MODULE 
C     IPDEF = FLAG THAT INDICATES SYMBOL MUST BE DEFINED BEFORE USE 
C     IPLUS = HOST COMPUTER REPRESENTATION OF A HOLLERITH PLUS SIGN 
C     IPRT  = LOGICAL UNIT NUMBER OF OUTPUT LISTING DEVICE
C     IRPAR = HOST COMPUTER REPRESENTATION OF A RIGHT PARENTHESIS 
C     ISEMI = HOST COMPUTER REPRESENTATION OF A HOLLERITH SEMICOLON 
C     ISHRP = HOST COMPUTER REPRESENTATION OF A HOLLERITH SHARP SIGN
C     ISYM  = NUMBER OF SYMBOLS IN SYMBOL TABLE 
C     ITAB  = SYMBOL TABLE
C     ITABS = SYMBOL TYPE, E.G. DEF,SUB,SET, OR ORDINARY SYMBOL 
C     ITABV = NUMERIC VALUE OF SYMBOL 
C     ITYPE = OPCODE TYPE 
C     IQUOT = HOST COMPUTER REPRESENTATION OF A HOLLERITH QUOTE 
C     IUNDR = HOST COMPUTER REPRESENTATION OF A HOLLERITH UNDER BAR 
C     IWORD = NUMBER OF WORDS IN HOST COMPUTER PER LABEL
C     IXCNT = NUMBER OF CROSS REFERENCE PAGES 
C     IXPNT = POINTER INTO CROSS REFERENCE TABLE
C     IXPAG = CROSS REFERENCE TABLE PAGE NUMBER 
C     IXTAB = CORE RESIDENT CROSS REFERENCE ARRAY 
C     IXT   = CROSS REFERENCE DISK RECORD 
C     IYFLD = NEXT INDEX INTO FIELD TABLE 
C     IZFLD = LENGTH OF FIELD TABLE 
C     JATT  = FIELD ATTRIBUTES OR MODIFIERS PRESENT IN A SUBSTIUTION
C     JBASE = DEFAULT BASE INDEX
C     JMAC  = MACRO LEVEL NUMBER OF DUP DIRECTIVE 
C     JCOL  = COLUMN THAT A LABEL ENDS IN 
C     JREAD = FLAG THAT INDICATES NEXT SOURCE LINE HAS ALREADY BEEN READ
C     JTYPE = SYMBOL TYPE 
C     KFILE = FLAG THAT INDICATES WHETHER INTERMEDIATE FILE EXISTS
C     KLEN  = IMPLICIT FIELD LENGTH FOR CONSTANTS 
C     KPCH  = LOGICAL UNIT NUMBER OF ENTRY POINT MAP
C     KTERM = LOGICAL UNIT NUMBER FOR ERROR LINE LISTING
C     KWORD = NUMBER OF BITS IN A WORD
C     LABCT = NUMBER OF CHARACTERS IN SYMBOL JUST SCANNED 
C     LADR  = FLAG TO INDICATE ADDRESS SHOULD BE LISTED FOR COMMENTS
C     LATT  = FIELD ATTRIBUTES PRESENT IN A DEFINITION FIELD
C     LC    = ASSEMBLY PROGRAM COUNTER
C     LCMAX = MAXIMUM ADDRESS ASSEMBLED 
C     LCMIN = MINIMUM ADDRESS ASSEMBLED 
C     LDEF  = FLAG TO INDICATE THAT DEFINITION FILE WILL BE PRODUCED
C     LEN   = LENGTH OF CURRENT ASSEMBLER INSTRUCTION OR DIRECTIVE
C     LEND  = FLAG INDICATING END OF CURRENT SOURCE LINE
C     LEVEL = MACRO LEVEL NUMBER
C     LERR  = FLAG TO INDICATE THAT ERRORS SHOULD BE LISTED ON KTERM
C     LIF   = FLAG TO INDICATE WHETHER IF STATEMENTS WILL BE EXPANDED 
C     LINE  = OUTPUT PAGE LINE COUNT
C     LINEL = LENGTH OF SOURCE LINE WITH TRAILING BLANKS DELETED
C     LINV  = FLAG TO INDICATE OBJECT MODULE BITS ARE TO BE INVERTED
C     LISN  = LINE NUMBER PRINTED ON LISTING
C     LLEN  = EXPLICIT FIELD LENGTH FOR CONSTANTS 
C     LLOC  = FLAG TO INDICATE LOCAL SYMBOLS SHOULD BE INCLUDED IN TABLE
C     LMAC  = FLAG TO INDICATE MACRO CALLS WILL BE EXPANDED ON LISTING
C     LMAC1 = LIST FLAG INDICATING ONLY MACRO CODE LINES BE LISTED
C     LMAP  = FLAG TO INDICATE ENTRY POINT MAP SHOULD BE GENERATED
C     LOBJ  = FLAG TO INDICATE WHETHER OBJECT MODULE IS TO BE PRODUCED
C     LOBJ1 = FLAG TO INDICATE INTERLEAVED LISTING IS TO BE PRODUCED
C     LOBJ2 = FLAG TO INDICATE OBJECT MODULE IS TO BE LISTED IN BLOCK 
C     LOCT  = OCTAL/HEXADECIMAL LIST FLAG 
C     LODLC = ADDRESS OF LAST OBJECT MODULE WORD ASSEMBLED
C     LREF  = FLAG TO INDICATE A CROSS REFERENCE TABLE WILL BE LISTED 
C     LSOR  = FLAG TO INDICATE SOURCE WILL BE LISTED
C     LSYM  = FLAG TO INDICATE THAT A SYMBOL TABLE WILL BE LISTED 
C     LTAB  = SYMBOL TABLE LENGTH 
C     LTBLK = LAST NON-BLANK COLUMN IN INPUT BUFFER 
C     LTITL = TITLE ARRAY 
C     LWORD = LENGTH OF OBJECT MODULE RECORDS 
C     MAC   = FLAG INDICATING CURRENT LINE IS MACRO EXPANSION 
C     MAPAD = ENTRY POINT MAP STARTING ADDRESS
C     MCFLE = LOGICAL UNIT NUMBER OF INTERMEDIATE FILE
C     MCNAM = MACRO NAME TABLE
C     MCNT  = MACRO COUNT (TOTAL NUMBER OF MACROS)
C     MCOL  = LAST COLUMN OF SCAN 
C     MCORE = BUFFER USED TO WRITE TO CROSS REFERENCE DISK FILE 
C     MCREC = RECORD NUMBER FOR INTERMEDIATE FILE 
C     MCEPT = MACRO BUFFER ENDING POINTER 
C     MCSPT = MACRO BUFFER STARTING POINTER 
C     MDISK = TABLE OF STARTING RECORD NUMBERS FOR MACROS 
C     MERR  = ERROR INDICATOR FROM LABEL ROUTINE
C     MLAB  = MAXIMUM LABEL LENGTH
C     MLCOL = LAST COLUMN PRINTED ON OUTPUT LISTING 
C     MOPC  = MAXIMUM OPCODE LENGTH 
C     MPARC = NUMBER OF PARAMETERS IN A MACRO DEFINITION
C     MSIZE = SIZE OF RECORDS WRITTEN TO INTERMEDIATE FILE
C     MSREC = MACRO FILE RECORD NUMBER
C     MWORD = WIDTH OF ENTRY POINT MAPPING ARRAY
C     MXMAC = MAXIMUM NUMBER OF MACROS
C     MXREF = SIZE OF CORE RESIDENT CROSS REFERENCE ARRAY 
C     NAME  = BUFFER THAT HOLDS SYMBOL
C     NARG  = NUMBER OF ARGUMENTS IN CURRENT MACRO CALL 
C     NBASE = DEFAULT BASE FOR NUMBERS
C     NDUP  = DUP DIRECTIVE COUNT 
C     NENT  = NUMBER OF ENTRY POINT SYMBOLS 
C     NERR  = SYMBOL ROUTINE ERROR FLAG 
C     NEST  = MACRO NESTING FLAG
C     NFLAG = SCAN FLAG THAT ALLOWS '3F5H' TYPE CONSTANTS TO BE READ
C     NOPRO = FLAG INDICATING LINE SHOULD NOT BE PROCESSED ON PASS 2
C     ZVAL  = MAXIMUM VALUE OF ANY NUMBER OR CONSTANT 
C 
C 
C     THE MAIN ROUTINE CALLS THE MAJOR SUBROUTINES
C 
      REAL IVAL 
      DIMENSION IBIN(128),LLAB(10)
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
      EQUIVALENCE (ICHRA,IALPH(11)),(ICHRX,IALPH(34)) 
      EQUIVALENCE (IOB1,IOBIN(1)),(IBIN(1),IADDR(1,1))
C 
C     IF POSSIBLE, THE META ASSEMBLER DEFINITION FILE PRODUCED BY 
C     THE DEFINITION PROGRAM SHOULD BE A SEQUENTIAL FILE. 
C     THIS WILL CONSERVE DISK STORAGE.  HOWEVER, IF NECESSARY 
C     THE FILE CAN BE RANDOM ACCESS.  THE FOLLOWING DEFINE FILE 
C     STATEMENT DEFINES THE META ASSEMBLER DEFINITION FILE AND IS 
C     INCLUDED FOR INFORMATION PURPOSES ONLY.  NOTE THE STATEMENT 
C     IS A COMMENT. 
C     THE DEFINITION FILE (SYMBOLIC FILE NUMBER 9) CONSISTS OF
C     500 128-WORD RECORDS.  U INDICATES A BINARY FILE.  THE NAME 
C     IDREC IS THE RECORD INDEX.
C     VARIOUS COMPUTERS DEFINE FILES IN DIFFERENT WAYS.  THIS FILE
C     MIGHT HAVE TO BE DEFINED DIFFERENTLY ON  YOUR COMPUTER. 
C 
C     DEFINE FILE 9(500,128,U,IDREC)
      OPEN(UNIT=9,IOSTAT=IOS,STATUS='OLD',
     + ACCESS='SEQUENTIAL',FILE='DEFFILE.BIN',FORM='UNFORMATTED')
      OPEN(UNIT=8,IOSTAT=IOS,STATUS='SCRATCH',
     + ACCESS='DIRECT',RECL=512,FORM='UNFORMATTED')
      OPEN(UNIT=5,IOSTAT=IOS,STATUS='OLD',
     + ACCESS='SEQUENTIAL',FILE='EXAMPLE.ASM',FORM='FORMATTED')
      OPEN(UNIT=6,IOSTAT=IOS,STATUS='NEW',
     + ACCESS='SEQUENTIAL',FILE='OUTPUT.TXT',FORM='FORMATTED')
C 
C     THE FOLLOWING DEFINE FILE STATEMENT DEFINES AN INTERMEDIATE FILE
C     USED TO HOLD MACRO DEFINITIONS AND TO ACCUMULATE REFERENCES 
C     FOR THE CROSS REFERENCE TABLE.  THIS FILE IS TEMPORARY
C     AND CAN BE DELETED AFTER PROGRAM EXECUTION. 
C     THE DEFINE FILE PARAMETERS ARE SIMILAR TO THE PREVIOUS
C     DEFINE FILE.  HOWEVER, THIS FILE MAY NOT BE A SEQUENTIAL FILE.
C     THE FILE IS TEMPORARY AND MAY BE DELETED AFTER PROGRAM EXECUTION. 
C 
C     DEFINE FILE 8(500,128,U,MCREC) COMMENTED_OUT
C 
C     THE FOLLOWING COMMENTED DEFINE FILE STATEMENT IS INCLUDED FOR 
C     REFERENCE.  IF NECESSARY, IT MAY BE USED TO DEFINE THE
C     INTERMEDIATE FILE THAT THE ASSEMBLY PROGRAM USES AS A 
C     RANDOM ACCESS FILE.  THIS FILE SHOULD BE LEFT AS A SEQUENTIAL 
C     FILE IF POSSIBLE.  THIS FILE HOLDS A COPY OF THE ASSEMBLER
C     SOURCE LINE TO BE READ ON PASS 2 AND SOME VARIABLES 
C     CALCULATED ON PASS 1 THAT ARE REQUIRED ON PASS 2. 
C 
C     DEFINE FILE 7(1000,91,U,IMREC)
      OPEN(UNIT=7,IOSTAT=IOS,STATUS='SCRATCH',
     + ACCESS='SEQUENTIAL',FORM='UNFORMATTED')
C 
C 
C     THE USER MAY WANT TO OPEN A DISK FILE FOR THE OUTPUT OBJECT 
C     MODULE AT THIS POINT.  SEE OPERATION NOTES FOR DETAILS
C 
C     DEFINE 4(200,128,U,IOREC)
      OPEN(UNIT=4,IOSTAT=IOS,STATUS='NEW',
     + ACCESS='SEQUENTIAL',FILE='OBJECT.BIN',FORM='FORMATTED') 
C 
C     INITIALIZE PROGRAM VARIABLES
      CALL INIT 
C     READ DEFINITION FILE
      CALL INOUT(2) 
C     PERFORM PASS 1 OF ASSEMBLY, BUILD SYMBOL TABLE
      IPASS = 1 
      CALL PASS 
C     REWIND INTERMEDIATE FILE
      REWIND IMFLE
C     SET MAXIMUM PROGRAM COUNTER 
      LCMAX = LC
C     INITIALIZE VARIABLES FOR PASS 2 
      CALL INIT 
C     PERFORM PASS 2 OF ASSEMBLY, GENERATE LISTING AND OBJECT MODULE
      IPASS = 2 
      CALL PASS 
C     CHECK TO SEE IF ENTRY SYMBOL FILE IS TO BE GENERATED
      IF(LMAP .EQ. 0) GO TO 200 
      IF(NENT .EQ. 0) GO TO 200 
C     WRITE HEADING TO LISTING
      WRITE(IPRT,1000) IFORM,LTITL,IPAGE
      WRITE(IPRT,1020)
1020  FORMAT(32X,15HENTRY POINT MAP)
      IDIV = 256**(ICCNT-1) 
      LINE = 4
C     SET UP MAP ARRAY STARTING ADDRESS AND LENGTH
      LODLC = -2
      LC = MAPAD
      REAL1 = NENT
      LCMAX = LC+REAL1
C     SET UP PARAMETERS TO PRODUCE MAP FILE 
      IEND = 0
      LEN = 1 
      ISAV = IPCH 
      IPCH = KPCH 
      KSAV = KWORD
      KWORD = MWORD 
      IOREC = 1 
C     INITIALIZE OBJECT WORD TO DONT CARES
      DO 160 I=1,KWORD
      IOBIN(I) = ICHRX
160   CONTINUE
C     FIND ENTRY POINT SYMBOLS AND OUTPUT TO MAP FILE 
      NN = 0
      DO 195 JJ=1,NENT
165   NN = NN+1 
      IF(ITABS(NN) .LT. 0) GO TO 165
      II = ITABS(NN)-(ITABS(NN)/8)*8
      IF(II .EQ. 2) GO TO 170 
      GO TO 165 
C     FOUND NEXT ENTRY POINT SYMBOL, PLACE VALUE IN OBJECT CODE BUFFER
170   IVAL = ITABV(NN)
C     CONVERT ENTRY POINT VALUE TO DISPLAYABLE BINARY 
      CALL AHEX(IVAL,0) 
C     MOVE BITS TO OBJECT CODE BUFFER 
      I = 1 
      J = KWORD-35
      K = 36
      IF(J .GT. 0) GO TO 172
      I = 37-KWORD
      J = 1 
      K = KWORD 
172   DO 175 L=1,K
      IOBIN(J) = IBIN(I)
      I = I+1 
      J = J+1 
175   CONTINUE
C     OUTPUT CURRENT ENTRY POINT SYMBOL 
      CALL OUT
C     DECODE SYMBOL VALUE INTO DISPLAYABLE CHARACTERS 
      ICNT = 0
      DO 190 K=1,IWORD
      ID = IDIV 
      II = ITAB(K,NN) 
      DO 190 I=1,ICCNT
      ICNT = ICNT+1 
      ICHAR = II/ID 
      IF(ICHAR .NE. 0) GO TO 183
C     PAD OUT SYMBOL WITH BLANKS
      LLAB(ICNT) = IBLNK
      GO TO 185 
183   II = II-ICHAR*ID
      LLAB(ICNT) = IALPH(ICHAR) 
185   IF(ICNT .GE. MLAB) GO TO 192
      ID = ID/256 
190   CONTINUE
C     DECODE SYMBOL VALUE 
192   CALL AHEX(IVAL,2) 
C     DECODE ENTRY POINT MAP ADDRESS
      CALL AHEX(LC,1) 
      IF(LINE .LT. IOLIN) GO TO 193 
      IPAGE = IPAGE+1 
      WRITE(IPRT,1000) IFORM,LTITL,IPAGE
      LINE = 3
C     DISPLAY CURRENT ENTRY POINT SYMBOL ON LISTING 
193   WRITE(IPRT,1030) (IADDR(1,K),K=6,12),(LLAB(K),K=1,ICNT),
     1  (IADDR(2,K),K=6,12) 
1030  FORMAT(1X,7A1,2X,8A1,2X,7A1)
      LINE = LINE+1 
      LC = LC+1.
195   CONTINUE
      IEND = 1
      CALL OUT
      IPCH = ISAV 
      KWORD = KSAV
C     CHECK TO SEE IF SYMBOL OR CROSS REFERENCE TABLE IS TO BE CREATED
200   IF((LSYM+LREF) .EQ. 0) GO TO 400
      WRITE(IPRT,1000) IFORM,LTITL,IPAGE
1000  FORMAT(A1,14X,50A1,2X,5HPAGE ,I4,/,/) 
      IF(LREF .GT. 0) GO TO 250 
      WRITE(IPRT,1010)
1010  FORMAT(32X,12HSYMBOL TABLE,/) 
      LINE = 5
      GO TO 300 
250   WRITE(IPRT,1011)
1011  FORMAT(24X,21HCROSS REFERENCE TABLE,//, 
     1  6H LABEL,4X,4HTYPE,3X,5HVALUE,10X,10HREFERENCES)
      LINE = 6
300   CALL SYMTA
C     CHECK FOR OBJECT CODE BLOCK FORMAT
400   IF(LOBJ2 .EQ. 0) GO TO 900
      WRITE (IPRT,1002) IFORM 
1002  FORMAT(A1,15X,13HOBJECT MODULE,/) 
      IF(IOFLG .EQ. 0) GO TO 900
      IOREC = 1 
      REWIND IPCH 
C     SKIP FIRST RECORD 
      I = IOREC 
      CALL INOUT(8) 
      IOREC = IOREC+1 
505   I = IOREC  
      CALL INOUT(8) 
      IOREC = I+1 
C     CHECK FOR END OF OBJECT MODULE
      IF(IOB1 .EQ. IDOLR) GO TO 900 
C     CHECK FOR NEW ORIGIN ADDRESS
      IF(IOB1 .EQ. ICHRA) GO TO 520 
C     INCREMENT ADDRESS 
      IVAL = IVAL+1.
      GO TO 525 
C     READ OBJECT MODULE ADDRESS ON 'A' RECORD
520   ICOL = 3
      NFLAG = 1 
      DO 522 I=1,10 
      IN(I) = IOBIN(I)
522   CONTINUE
      CALL NUMB(0)
      IVAL = CVAL-1.
      GO TO 505 
C     CONVERT ADDRESS TO BINARY HOLLERITH 
525   CALL AHEX(IVAL,1) 
      K = 65
      IF(KWORD .GT. 64) GO TO 540 
      K = 1 
      GO TO 550 
540   WRITE(IPRT,2000) (IADDR(1,I),I=6,12),(IOBIN(I),I=1,64)
2000  FORMAT(1X,7A1,2X,4(16A1,1X))
550   WRITE(IPRT,2000) (IADDR(1,I),I=6,12),(IOBIN(I),I=K,KWORD) 
      GO TO 505 
C     EJECT PAGE
900   WRITE(IPRT,1001) IFORM
1001  FORMAT(A1)
      STOP
      END 
      SUBROUTINE INIT 
C 
C 
C     THIS SUBROUTINE INITIALIZES VARIOUS 
C     VARIABLES USED BY THE ASSEMBLER 
C 
C 
      DIMENSION NALPH(37),NTITL(31),KATT(10)
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
      EQUIVALENCE (NALPH(2),NALP2)
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 UNIQUE VALID CHARACTERS. THE NEW
C     CHARACTERS CAN THEN BE USED IN PLACE OF THE OLD ILLEGAL CHARACTERS
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)                               /1H./
      DATA NBLNK,NPLUS,NMIN,NUNDR,NQUOT /1H ,1H+,1H-,1H_,1H'/ 
      DATA NDOLR,NCOMM,NAST,NSEMI,NCOLN /1H$,1H,,1H*,1H;,1H:/ 
      DATA NSHRP,NAMP,NCTAB,NGRAT,NLESS /1H#,1H&,1H ,1H>,1H</ 
      DATA NMULT,NDIV,NRPAR,NLPAR /1H*,1H/,1H),1H(/ 
      DATA NTITL( 1),NTITL( 2),NTITL( 3),NTITL( 4) /1HM,1HE,1HT,1HA/
      DATA NTITL( 5),NTITL( 6),NTITL( 7),NTITL( 8) /1H ,1HA,1HS,1HS/
      DATA NTITL( 9),NTITL(10),NTITL(11),NTITL(12) /1HE,1HM,1HB,1HL/
      DATA NTITL(13),NTITL(14),NTITL(15),NTITL(16) /1HE,1HR,1H ,1HA/
      DATA NTITL(17),NTITL(18),NTITL(19),NTITL(20) /1HS,1HS,1HE,1HM/
      DATA NTITL(21),NTITL(22),NTITL(23),NTITL(24) /1HB,1HL,1HY,1H /
      DATA NTITL(25),NTITL(26),NTITL(27),NTITL(28) /1HP,1HR,1HO,1HG/
      DATA NTITL(29),NTITL(30),NTITL(31)           /1HR,1HA,1HM/
      DATA KATT(1),KATT(2),KATT(3),KATT(4),KATT(5) /1H*,1H-,1H%,1H:,1H$/
      DATA KATT(6),KATT(7),KATT(8),KATT(9),KATT(10)/1H@,1HB,1HQ,1HH,1HD/
C 
C     SET I/O DEVICE ASSIGNMENTS
C 
      IPCH = 4
      ICRD = 5
      IPRT = 6
      IMFLE = 7 
      MCFLE = 8 
      IDFLE = 9 
      KPCH = 3
      KTERM = 1 
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     ITABS(LTAB) 
C     NAME(IWORD) 
C 
      IBIT = 32 
      MLAB = 8
      ICCNT = IBIT/8
      IWORD = 1+(MLAB-1)/ICCNT
      LTAB = 500
C 
C 
C 
C     TO INCREASE THE PAGE SIZE OF THE CROSS REFERENCE TABLE OR THE 
C     TOTAL NUMBER OF REFERENCE PAGES PRODUCED, THE USER MUST BE AWARE
C     OF THE FOLLOWING VARIABLES. 
C 
C        MXREF = MAXIMUM PAGE SIZE OF CROSS REFERENCE TABLE.
C        IXTAB = ARRAY TO ACCUMULATE CROSS REFERENCES 
C        IXPAG = TOTAL NUMBER OF REFERENCE PAGES OF SIZE MXREF THAT 
C                WILL BE ACCUMULATED. 
C 
C     THE NUMBER OF REFERENCES ON A PAGE IS (MXREF/2).
C     MXREF SHOULD BE DIVISIBLE BY MSIZE (128). 
C     IF IXPAG = 0, THEN THE DISK FILE WILL NOT BE USED AND REFERENCES
C     WILL ONLY BE ACCUMULATED IN MEMORY. 
C 
C     TO INCREASE CROSS REFERENCE PAGE SIZE THE FOLLOWING 
C     VARIABLES SHOILD BE CHANGED 
C 
C     MXREF 
C     IXTAB(MXREF)
C 
C 
      IXPAG = 0
      MXREF = 512 
      MSIZE = 128 
C     INITIALIZE OTHER VARIABLES USED BY CROSS REFERENCE ROUTINE
      IXT = 1 
      IXPNT = 0 
      IXCNT = 0 
C     SET MAXIMUM NUMBER OF ENTRIES IN FIELD TABLE
      IZFLD = 500 
C     SET STARTING AND ENDING COLUMNS FOR LINE SCAN 
      IFCOL = 1 
      MCOL = 72 
C     SET LAST COLUMN NUMBER PRINTED ON OUTPUT LISTING
      MLCOL = 72
C     SET MAXIMUM OPCODE LENGTH 
      MOPC = 6
C     SET MAXIMUM NUMBER OF BITS IN FIELD 
      IFBIT = 20
C     FORM MAXIMUM VALUE CONTAINABLE IN IFBIT BITS
      ZVAL = 1. 
      DO 10 I=1,IFBIT 
      ZVAL = ZVAL+ZVAL
10    CONTINUE
      ZVAL = ZVAL-1.
C     INITIALIZE FILE RECORD NUMBERS
      IMREC = 1 
      IOREC = 1 
      IDREC = 1 
C     SET PAGE NUMBER AND NUMBER OF LINES PER PAGE ON OUTPUT LISTING
      IPAGE = 1 
      IOLIN = 56
      LINE = IOLIN
      LISN = 0
C     SET FORMS CONTROL CHARACTER 
      IFORM = NALP2 
C     SET END FLAG
      IEND = 0
C     SET DEFAULT PROGRAM ORIGIN
      LC = 0. 
C     SET FIRST TIME FLAG FOR OUTPUT ROUTINE
      LODLC = -2. 
C     INITIALIZE LIST FLAGS 
      LSOR = 1
      LSYM = 1
      LREF = 0
      LIF = 0 
      LOBJ = 1
      LOCT = 0
      LOBJ1 = 1 
      LOBJ2 = 0 
      LINV = 0
      LERR = 0
      LMAP = 0
      LMAC = 1
      LLOC = 1
      LADR = 0
      LMAC1 = 1 
      IDUP = 0
      NDUP = 0
      NFLAG = 0 
C     SET MACRO PARAMETERS
      MXMAC = LTAB-1
      MAC = 1 
      MCREC = 1 
      NARG = 0
      NEST = 0
      LEVEL = 0 
      MCSPT = 1 
      MCEPT = 1 
C     SET FLAG THAT INDICATES NOTHING WRITTEN TO OBJECT MODULE
      IOFLG = 0 
C     SET TOTAL ERROR COUNT 
      IERRS = 0 
C     SET READ FLAG 
      JREAD = 0 
C     RESET OVERLAY FLAG
      IOVER = 0 
C     INITIALIZE LEGAL CONSTANT MODIFIERS 
      DO 15 I=1,10
      IATT(I) = KATT(I) 
15    CONTINUE
C     INITIALIZE THE CHARACTER VARIABLES
      DO 40 K=1,37
      IALPH(K) = NALPH(K) 
40    CONTINUE
C 
C     THE CHARACTERS LISTED BELOW ARE CHARACTERS USED INTERNALLY BY 
C     THE ASSEMBLER FOR SYNTAX CHECKING.
C 
      IBLNK = NBLNK 
      IPLUS = NPLUS 
      IMIN = NMIN 
      IDOLR = NDOLR 
      ICOMM = NCOMM 
      IAST = NAST 
      ISEMI = NSEMI 
      ICOLN = NCOLN 
      IMULT = NMULT 
      IDIV = NDIV 
      IRPAR = NRPAR 
      ILPAR = NLPAR 
      ISHRP = NSHRP 
      IAMP = NAMP 
      ICTAB = NCTAB 
      IGRAT = NGRAT 
      ILESS = NLESS 
      IUNDR = NUNDR 
      IQUOT = NQUOT 
C     SET DEFAULT TITLE 
      DO 200 LL=1,50
      LTITL(LL) = IBLNK 
200   CONTINUE
      DO 250 LL=1,28
      KK = LL+10
      LTITL(KK) = NTITL(LL) 
250   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 INFORMTIVE PURPOSES).
C     THE RECORD NUMBER FOR RANDOM ACCESS I/O IS PASSED INTO
C     THE ROUTINE VIA COMMON. 
C 
C     ENTRY PARAMETERS
C        ICTL - I/O CONTROL WORD
C           1 = READ SOURCE 
C           2 = READ DEFINITION FILE
C           3 = READ CROSS REFERENCE RECORD 
C           4 = WRITE CROSS REFERENCE FILE
C           5 = WRITE OBJECT MODULE FILE
C           6 = READ INTERMEDIATE FILE
C           7 = WRITE INTERMEDIATE FILE 
C           8 = READ OBJECT MODULE
C           9 = READ MACRO FILE 
C          10 = WRITE MACRO FILE
C 
C 
      DIMENSION NAMEM(3),NAMED(3),NAMEP(3),NAMEI(3) 
      DIMENSION IDBUF(10),IMBUF(91),MCBUF(80),IMBU2(91) 
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
      EQUIVALENCE(IDBUF(1),REAL1) 
      EQUIVALENCE (INB(7),INB7),(INB(8),INB8),(INB(9),INB9) 
      EQUIVALENCE (IALPH(14),IAL14),(IALPH(15),IAL15),(IALPH(24),IAL24) 
      EQUIVALENCE (IDBUF(1),IDBU1),(IDBUF(2),IDBU2),(IDBUF(3),IDBU3)
      EQUIVALENCE (IDBUF(4),IDBU4),(IDBUF(5),IDBU5),(IDBUF(6),IDBU6)
      EQUIVALENCE (IMBUF(1),IMBU1(1)),(MCBUF(1),INB(1)),(IMBU2(1),IERRI)
      DATA NAMEM(1),NAMEM(2),NAMEM(3) /2HMC,2HFL,2HE /
      DATA NAMED(1),NAMED(2),NAMED(3) /2HID,2HFL,2HE /
      DATA NAMEP(1),NAMEP(2),NAMEP(3) /2HOB,2HFL,2HE /
      DATA NAMEI(1),NAMEI(2),NAMEI(3) /2HIM,2HFL,2HE /
C 
      GO TO (100,200,300,400,500,600,700,800,840,880),ICTL
C 
C     READ SOURCE 
100   READ(ICRD,1000) INB 
C     IF END OF FILE (EOF) CAN BE DETECTED, BRANCH TO STATEMENT 110 
C     ON EOF.  THE FOLLOWING STATEMENT IS VALID ON MOST MACHINES. 
C100   READ(ICRD,1000,END=110) INB 
1000  FORMAT(80A1)
      GO TO 990 
110   DO 120 I=1,80 
      INB(I) = IBLNK
120   CONTINUE
      INB7 = IAL15
      INB8 = IAL24
      INB9 = IAL14
      IEND = 1
      GO TO 990 
C     READ DEFINITION FILE
200   II = IDREC
C     READ MICROWORD AND TABLE SIZES
      READ(IDFLE) (IDBUF(I),I=1,6)
C     IF EOF CAN BE DETECTED, BRANCH TO 970 ON EOF
C     READ(IDFLE,END=970) (IDBUF(I),I=1,6)
C     CALL EXEC(14,1091,IDBUF,6,NAMED,IDREC)
      IDREC = II+1
      ISYM = IDBU1
      IYFLD = IDBU2 
      KWORD = IDBU3 
      MCNT = IDBU4
      MSREC = IDBU5 
      NENT = IDBU6
C     CHECK TO BE SURE SYMBOL AND FIELD TABLE CAN HOLD DEFINITION FILE
      IF(ISYM .GT. LTAB) GO TO 980
      IF(IYFLD .GT. IZFLD) GO TO 980
      IF(ISYM .EQ. 0) GO TO 250 
C     READ SYMBOL TABLE 
      DO 220 I=1,ISYM 
      II = IDREC
      READ(IDFLE) (IDBUF(J),J=1,7)
C     IF EOF CAN BE DETECTED, BRANCH TO 970 ON EOF
C     READ(IDFLE,END=970) (IDBUF(J),J=1,7)
C     CALL EXEC(14,1091,IDBUF,7,NAMED,IDREC)
      IDREC = II+1
      ITABV(I) = REAL1
      ITABS(I) = IDBU3
      L = 4 
      DO 215 J=1,IWORD
      ITAB(J,I) = IDBUF(L)
      L = L+1 
215   CONTINUE
220   CONTINUE
C     READ FIELD TABLE
250   IF(IYFLD .EQ. 0) GO TO 280
      J = 1 
      K = 10
256   IF(IYFLD .GE. K) GO TO 260
      K = IYFLD 
      IF(IYFLD .LT. J) GO TO 280
260   II = IDREC
      READ(IDFLE) (IDBUF(I),I=1,10)
C     IF EOF CAN BE DETECTED, BRANCH TO 970 ON EOF
C     READ(IDFLE,END=970) (IDBUF(I),I=1,10) 
C     CALL EXEC(14,1091,IDBUF,10,NAMED,IDREC) 
      IDREC = II+1
      L = 1 
      DO 265 I=J,K
      IFLD(I) = IDBUF(L)
      L = L+1 
265   CONTINUE
      J = J+10
      K = K+10
      GO TO 256 
C     READ MACRO DEFINITIONS FROM DEFINITION FILE 
280   IF(MCNT .EQ. 0) GO TO 295 
      DO 290 I=1,MSREC
      II = IDREC
      READ(IDFLE) INB 
C     IF EOF CAN BE DETECTED, BRANCH TO 970 ON EOF
C     READ(IDFLE,END=970) INB 
C     CALL EXEC(14,1091,INB,80,NAMED,IDREC) 
      IDREC = II+1
      II = MCREC
      WRITE(MCFLE,REC=MCREC) INB
C     WRITE(MCFLE'MCREC) INB
C     CALL EXEC(15,1091,INB,80,NAMEM,MCREC) 
      MCREC = II+1
290   CONTINUE
295   MSREC = MSREC+1 
      GO TO 990 
C 
C     READ CROSS REFERENCE FILE
300   READ(UNIT=MCFLE, REC=MCREC) MCORE 
C300   READ(MCFLE'MCREC) MCORE 
C     CALL EXEC(14,1091,MCORE,MSIZE,NAMEM,MCREC)
      GO TO 990 
C     WRITE CROSS REFERENCE FILE
400   WRITE(MCFLE, REC=MCREC) (IXTAB(J),J=1,128)
C400   WRITE(MCFLE'MCREC) (IXTAB(J),J=1,128) 
C     CALL EXEC(15,1091,IXTAB,MSIZE,NAMEM,MCREC)
      GO TO 990 
C     WRITE OBJECT MODULE FILE
500   I = IOREC 
      LWORD = KWORD 
      K = 65
      IF(KWORD .GT. 71) GO TO 520 
      K = 1 
      IF(KWORD .GE. 24) GO TO 530 
      IF(LODLC .NE. -2.) GO TO 530
      LWORD = 24
      GO TO 530 
520   WRITE(IPCH,5000) (IOBIN(I),I=1,64)
      I = I+1 
      IOREC = I 
530   WRITE(IPCH,5000) (IOBIN(I),I=K,LWORD) 
C     CALL EXEC(15,1091,IOBIN,128,NAMEP,IOREC)
      IOREC = I+1 
5000  FORMAT(128A1) 
      GO TO 990 
C     READ INTERMEDITAE FILE
600   I = IMREC 
      READ (IMFLE) IMBUF
C     CALL EXEC(14,1091,IMBUF,91,NAMEI,IMREC) 
      IMREC = I+1 
      GO TO 990 
C     WRITE INTERMEDIATE FILE 
700   DO 710 I=1,MLCOL
      LTBLK = MLCOL+1-I 
      IF(INB(LTBLK)-IBLNK) 720,710,720
710   CONTINUE
720   DO 725 I=1,11 
      IMBU1(I) = IMBU2(I) 
725   CONTINUE
      WRITE(IMFLE) IMBUF
C     CALL EXEC(15,1091,IMBUF,91,NAMEI,IMREC) 
      IMREC = I+1 
      GO TO 990 
C     READ OBJECT MODULE
800   I = IOREC 
      K = 65
      IF(KWORD .GT. 71) GO TO 820 
      K = 1 
      GO TO 830 
820   READ(IPCH,5000) (IOBIN(I),I=1,64) 
      I = I+1 
      IOREC = I 
830   READ(IPCH,5000) (IOBIN(I),I=K,KWORD)
      IOREC = I+1 
      GO TO 990 
C     READ MACRO FILE 
840   IF(MCREC .GE. MSREC) GO TO 110
      READ(MCFLE,REC=MCREC) MCBUF 
C     READ(MCFLE'MCREC) MCBUF 
C     CALL EXEC(14,1091,MCBUF,80,NAMEM,MCREC) 
      GO TO 990 
C     WRITE MACRO FILE
880   WRITE(MCFLE,REC=MCREC) IN
C880   WRITE(MCFLE'MCREC) IN 
C     CALL EXEC(15,1091,IN,80,NAMEM,MCREC)
      GO TO 990 
C     DISPLAY ERROR MESSAGES
970   CALL MESS(19) 
      GO TO 985 
980   CALL MESS(20) 
985   STOP
990   RETURN
      END 
      SUBROUTINE PASS 
C 
C 
C     THIS SUBROUTINE READS THE ASSEMBLY LANGUAGE DEFINITION AND
C     SAVES THE DEFINITION ON A DISK FILE.  THE ROUTINE 
C     EXECUTES ALL ASSEMBLER DIRECTIVES AND PRODUCES A LISTING ON 
C     THE LIST DEVICE 
C 
C 
      REAL IVAL,IVAL1,ITAB1 
      INTEGER FTYP1 
      DIMENSION ITERM(4),NUMS(10) 
      DIMENSION IBIN(36),JCTYP(4) 
      DIMENSION LISTS(15),LCTL(15),IMBUF(91),IMBU2(91)
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
      EQUIVALENCE (ICHR0,IALPH(1)),(ICHRX,IALPH(34))
      EQUIVALENCE (ITABV(1),ITAB1),(IMBUF(1),IMBU1(1)),(IMBU2(1),IERRI) 
      EQUIVALENCE (IBIN(1),IADDR(1,1))
      EQUIVALENCE (NUMS(1),IALPH(1))
      EQUIVALENCE (LCTL(1),LSOR)
      EQUIVALENCE (JCTYP(1),IATT(7))
      EQUIVALENCE(ITERM(1),IBLNK) 
      DATA LISTS(1),LISTS(2),LISTS(3),LISTS(4) /1HS,1HI,1HT,1HX/
      DATA LISTS(5),LISTS(6),LISTS(7),LISTS(8) /1HD,1HQ,1HO,1HL/
      DATA LISTS(9),LISTS(10),LISTS(11),LISTS(12) /1HB,1HV,1HE,1HM/ 
      DATA LISTS(13),LISTS(14),LISTS(15)          /1HA,1HP,1HC/ 
C 
C     INITIALIZE IF STATEMENT NESTING LEVEL NUMBER
      IFSET = 0 
      IFON = 0
C     INITIALIZE IF STATEMENT CONTROL FLAG
      IFCTL = 2 
C     INITIALIZE CURRENT COLUMN NUMBER
100   ICOL = IFCOL
      JCOL = IFCOL
C     SET LABEL INDICATOR (INDEX) TO ZERO 
      INDET = 0 
      INDEX = 0 
C     SET LABEL DEFINITION FLAG 
      IPDEF = 0 
C     INITIALIZE ERROR INDICATOR
      IERRL = 0 
      IERRI = 0 
      IERR = 0
C     RESET INSTRUCTION LENGTH
      LEN = 0 
C     RESET LINE END FLAG 
      LEND = 0
C     SET DEFAULT NUMBER BASE TO DECIMAL
      JBASE = 4 
C     SET MODE FOR OUTPUT LISTING 
      LMODE = 1 
C     RESET MACRO DEFINITION FLAG 
      NOPRO = 0 
C     SET EXPLICIT LENGTH TO INDICATE NONE
      ILEN = -1 
C     CHECK FOR DUPLICATE DIRECTIVE 
      IF(IDUP .EQ. 0) GO TO 112 
C     CHECK TO SEE IF LINE HAS BEEN SAVED IN DUPLICATION BUFFER 
      IF(NDUP .GE. 0) GO TO 109 
      DO 108 I=1,80 
      IND(I) = INB(I) 
108   CONTINUE
      NDUP = -NDUP
C     ONLY DECREMENT LINE DUPLICATION COUNT AT RIGHT MACRO LEVEL
109   IF(MAC .EQ. 1) GO TO 110
      IF(JMAC .NE. LEVEL) GO TO 112 
110   NDUP = NDUP-1 
C     RESTORE DUPLICATED LINE 
      DO 111 I=1,80 
      INB(I) = IND(I) 
111   CONTINUE
      GO TO 117 
C     CHECK TO SEE IF LINE HAS ALREADY BEEN READ
112   IF(JREAD .NE. 0) GO TO 117
C     READ NEXT SOURCE LINE 
      IF(IPASS .NE. 1) GO TO 116
C     ON PASS 1 READ SOURCE LINE FROM SOURCE OR MACRO FILE
      IF(MAC .LE. 1) GO TO 113
      CALL MCREF
      GO TO 117 
113   CALL INOUT(1) 
C     INCREMENT LINE NUMBER 
      LISN = LISN+1 
      GO TO 117 
C     ON PASS 2 READ SOURCE LINE FROM INTERMEDIATE FILE 
116   CALL INOUT(6) 
C     MOVE NEW LINE TO INPUT BUFFER 
117   J = 12
      IF(IPASS .EQ. 1) GO TO 1175 
      J = 1 
C     SET NUMBER OF MACRO ARGUMENTS FOR PASS 2
      ITAB1 = IMBU1(6)
1175  DO 118 I=J,91 
      IMBU2(I) = IMBUF(I) 
118   CONTINUE
      JREAD = 0 
C     DO NOT PROCESS MACRO DEFINITION LINES ON PASS 2 
      IF(NOPRO .NE. 0) GO TO 805
C     DO NOT PROCESS LINES ON PASS 2 WITH OPCODE OR SYNTAX ERRORS 
      IF(IERRI .EQ. 1) GO TO 921
      IF(IERRI .NE. 0) GO TO 805
      IDUP = NDUP 
C     DETERMINE ASSEMBLER DIRECTIVE 
120   CALL OPCOD
C     CHECK TO SEE IF THIS IS AN IF EXPANSION AND THIS LINE 
C     IS TO BE SKIPPED
      IF(IFCTL .EQ. 2) GO TO 185
      IF(IERR .NE. 2) GO TO 250 
C     SET ICOL TO POINT PAST LABEL
      ICOL = JCOL+1 
      GO TO 120 
185   GO TO (350,200,920,240,187,986),IERR
C     NO OPCODE ON LINE, CHECK IF LABEL PRESENT 
187   IF(INDET) 800,920,800 
C     CHECK TO MAKE SURE THAT TWO LABELS ARE NOT ON LINE
200   IF(IPASS .NE. 1) GO TO 205
      IF(INDET .GT. 0) GO TO 930
C     PROCESS A LABEL 
205   CALL LABEL(0) 
      LABST = 1 
C     CHECK FOR A COLON 
      IF(IN(ICOL) .NE. ICOLN) GO TO 900 
      ICOL = ICOL+1 
C     CHECK FOR DOUBLE COLON
      IF(IN(ICOL) .NE. ICOLN) GO TO 212 
      ICOL = ICOL+1 
      LABST = 2 
      IF(IPASS .NE. 1) GO TO 212
      NENT = NENT+1 
212   IF(IN(ICOL) .EQ. IBLNK) GO TO 213 
      IF(IN(ICOL) .NE. ICTAB) GO TO 214 
213   ICOL = ICOL+1 
      IF(ICOL-MCOL) 212,212,214 
214   IF(IFCTL .NE. 2) GO TO 120
      GO TO (216,220,900,916),MERR
C     LABEL IS IN SYMBOL TABLE, IF PASS 1 THEN LABEL IS A DUPLICATE 
216   IF(IPASS .EQ. 1) GO TO 915
C     ON PASS 2 LABEL IS DUPLICATE IF ALREADY DEFINED 
C     CHECK DEFINED BIT 
      IF(JTYPE .EQ. 6) GO TO 230
      I = ITABS(INDEX)/8
      I = I-(I/2)*2 
      IF(I .NE. 0) GO TO 915
C     SYMBOL NOT PREVIOUSLY DEFINED, MARK SYMBOL DEFINED
      ITABS(INDEX) = ITABS(INDEX) + 8 
      GO TO 230 
C     ON PASS 1 PLACE LABEL IN SYMBOL TABLE, ON PASS 2 TABLE FULL 
220   IF(IPASS .NE. 1) GO TO 916
C     PLACE LABEL IN SYMBOL TABLE 
      DO 225 I=1,IWORD
      ITAB(I,INDEX) = NAME(I) 
225   CONTINUE
      ITABS(INDEX) = LABST
      ITABV(INDEX) = LC 
230   INDET = INDEX 
C     HAVE PROCESSED LABEL, NOW FETCH OPCODE
      GO TO 120 
C     PROCESS A COMMENT 
240   IF(IFCTL-2) 588,805,588 
C     CHECK FOR AN IF CONTROL DIRECTIVE ON PASS 1 
250   IF(IPASS .NE. 1) GO TO 805
      IF(ICHK .EQ. 1010) GO TO 580
      IF(ICHK .EQ. 1009) GO TO 570
      IF(ICHK .EQ. 1008) GO TO 255
      IF(ICHK .LT. 1018) GO TO 254
      IF(ICHK .LE. 1021) GO TO 255
254   IF(ICHK-1011) 588,600,588 
C     CHECK IF NESTING LEVEL
255   IF(IFSET .GE. 16) GO TO 985 
      IFSET = IFSET+1 
      IFPAR(IFSET) = 0
      GO TO 588 
350   IF(IPASS .NE. 1) GO TO 370
C     SET INSTRUCTION LENGTH
      LEN = ITYPE-1 
C     CHECK FOR MACRO REFERENCE 
      IF(ITYPE .EQ. 3) GO TO 520
C     BRANCH TO PROCESS DIRECTIVE ON PASS 1 
      GO TO (805,420,440,460,470,805,805,540,570,580, 
     1  600,620,640,660,805,700,805,550,552,560,562,
     2  500,920,510,510,805,805),IOPVA
C     INITIALIZE OUTPUT BUFFER TO DON'T CARES 
C     IF NOT PROCESSING OVERLAYED INSTRUCTION 
370   IF(IOVER .NE. 0) GO TO 380
      DO 375 I=1,KWORD
      IOBIN(I) = ICHRX
375   CONTINUE
380   IOVER = 0 
      IF(ITYPE .EQ. 3) GO TO 525
C     BRANCH TO PROCESS DIRECTIVE ON PASS 2 
      GO TO (400,420,440,460,470,480,490,800,800,800, 
     1  600,620,640,660,4610,800,720,805,805,800,800, 
     2  800,800,800,800,590,740),IOPVA
C 
C     PROCESS TITLE DIRECTIVE                                -- TITLE 
C 
400   N = 1 
      ICOL1 = ICOL+49 
      DO 405 J=ICOL,ICOL1 
      IF(J .GT. MCOL) GO TO 406 
      LTITL(N) = IN(J)
      N = N+1 
405   CONTINUE
406   IF(N .GT. 50) GO TO 800 
      DO 408 J=N,50 
      LTITL(J) = IBLNK
408   CONTINUE
      GO TO 800 
C 
C     PROCESS LIST DIRECTIVE                                 -- LIST
C 
420   LSET = 1
421   IF(ICOL .GT. MCOL) GO TO 428
C     CHECK FOR LEGAL OPERAND 
      DO 423 I=1,15 
      IF(IN(ICOL)-LISTS(I)) 423,424,423 
423   CONTINUE
C     ILLEGAL LIST OPERAND
      GO TO 925 
C     SET CORRESPONDING LIST CONTROL FLAG 
424   LCTL(I) = LSET
      ICOL1 = ICOL+1
      ICOL = ICOL1+1
C     CHECK FOR END OF ARGUMENT LIST
      DO 425 I=1,3
      IF(IN(ICOL1)-ITERM(I)) 425,800,425
425   CONTINUE
      IF(IN(ICOL1)-ICOMM) 925,421,925 
428   LSOR = LSET 
      GO TO 800 
C 
C     PROCESS NOLIST DIRECTIVE                               -- NOLIST
C 
440   LSET = 0
      GO TO 421 
C 
C     PROCESS EQU DIRECTIVE                                  -- EQU 
C 
460   IPDEF = 1 
C     CHECK FOR EXPLICIT EXPRESSION LENGTH
4610  DO 4611 I=1,10
      IF(IN(ICOL)-NUMS(I)) 4611,4612,4611 
4611  CONTINUE
      GO TO 4619
C     READ EXPLICIT EXPRESSION LENGTH 
4612  ILEN = 0
      LCOL = ICOL 
4613  DO 4614 I=1,10
      IF(IN(ICOL)-NUMS(I)) 4614,4618,4614 
4614  CONTINUE
C     CHECK FOR EXPRESSION SURRONUNDED BY PARENTHESIS 
      IF(IN(ICOL)-ILPAR) 4616,4619,4616 
4616  ICOL = LCOL 
      ILEN = -1 
      GO TO 4619
4618  ILEN = ILEN*10+I-1
      ICOL = ICOL+1 
      GO TO 4613
C     READ VALUE THAT LABEL IS TO BE SET TO 
4619  CALL ESCAN(IVAL)
      IF(IOPVA-15) 4620,680,4620
4620  IF(IERR-1) 462,465,462
C     CHECK FOR DUPLICATE LABEL 
462   IF(IERRL-53) 4625,681,4625
C     SET SYMBOL VALUE TO ZERO IF THERE WAS AN ERROR
4625  IF(INDET) 463,464,463 
463   ITABV(INDET) = 0
      ITABS(INDET) = LABST
464   GO TO 681 
C     CHECK FOR MISSING LABEL 
465   IF(INDET) 466,910,466 
C     CHECK FOR DUPLICATE LABEL 
466   IF(IERRL-53) 467,800,467
C     PLACE SYMBOL'S VALUE IN TABLE 
467   ITABV(INDET) = IVAL 
      ITABS(INDET) = KLEN*16+LABST
      IF(IPASS .EQ. 1) GO TO 800
      ITABS(INDET) = ITABS(INDET)+8 
      GO TO 800 
C 
C     PROCESS SET DIRECTIVE                                  -- SET 
C 
C     CHECK FOR DUPLICATE LABEL 
470   IF(IERRL .NE. 53) GO TO 474 
C     IF LABEL IS DUPLICATE, THEN TYPE MUST BE SET
      JTYPE = ITABS(INDET)
      JTYPE = JTYPE-(JTYPE/8)*8 
      IF(JTYPE .NE. 3) GO TO 800
      IERRL = 0 
474   LABST = 3 
      GO TO 460 
C 
C     PROCESS SPACE DIRECTIVE                                -- SPACE 
C 
480   CALL ESCAN(IVAL)
      IF(IERR .NE. 1) GO TO 681 
      ICNT = IVAL 
      IF(ICNT .LE. IOLIN) GO TO 485 
      ICNT = IOLIN
485   LMODE = 2 
      GO TO 800 
C 
C     PROCESS EJECT DIRECTIVE                                -- EJECT 
C 
490   LMODE = 3 
      IF(LSOR .EQ. 0) GO TO 800 
      LINE = IOLIN
      GO TO 800 
C 
C     PROCESS MACRO DIRECTIVE                                -- MACRO 
C 
C     CHECK FOR MISSING LABEL 
500   IF(INDET .EQ. 0) GO TO 910
C     IF LABEL IS DUPLICATE, TYPE MUST BE MACRO 
      IF(IERRL .EQ. 0) GO TO 501
      I = ITABS(INDET)-(ITABS(INDET)/8)*8 
      IF(I .NE. 6) GO TO 990
C     SET TYPE TO MACRO 
501   ITABV(INDET) = 0
      ITABS(INDET) = 6
      IERRL = 0 
C     MACRO CANNOT BE DEFINED WITHIN ANOTHER MACRO DEFINITION 
      IF(MAC .NE. 1) GO TO 920
C     CHECK FOR MACRO NAME TABLE OVERFLOW 
      IF(MCNT .GE. MXMAC) GO TO 918 
      MCNT = MCNT+1 
C     PLACE MACRO NUMBER AND DISK STARTING RECORD NUMBER IN SYMBOL TAB
      REAL1 = MSREC 
      REAL2 = MCNT
      ITABV(INDET) = REAL2+REAL1*1024.
C     STORE MACRO BODY ON MACRO DEFINITION DISK FILE
      CALL MCDEF
      IF(IEND .EQ. 0) GO TO 100 
      ITYPE = 2 
      GO TO 800 
C 
C     PROCESS ENDM OR EXITM                                -- ENDM,EXITM
C 
C     IF NOT WITHIN A MACRO, THEN OPCODE ERROR EXISTS 
510   IF(MAC .LE. 1) GO TO 920
C     RESTORE IF PARAMETERS BEFORE MACRO CALL 
      J = IFSET 
      IFSET = IFLEV 
      IF(MCSPT .LE. 1) GO TO 515
      MCEPT = MCSPT-1 
      IFCTL = IXTAB(MCEPT)
      IFLEV = IFCTL/16
      IFCTL = IFCTL-IFLEV*16
      MCEPT = MCEPT-1 
C     GET PARAMETERS FROM PREVIOUS MACRO
      ITAB1 = IXTAB(MCEPT)
      NARG = IXTAB(MCEPT) 
      MCEPT = MCEPT-1 
      MCSPT = IXTAB(MCEPT)
      MCEPT = MCEPT-1 
      MCREC = IXTAB(MCEPT)
      MCEPT = MCEPT-1 
      GO TO 516 
515   MCEPT = 1 
      MAC = 1 
      ITAB1 = 0 
      NARG = 0
516   NEST = 0
      IF(IERRL .NE. 0) GO TO 800
      IF(INDET) 100,100,800 
C 
C     PROCESS MACRO REFERENCE                                ---- 
C 
C     SCAN MACRO PARAMETERS AND PLACE IN TABLE
520   CALL MCCAL
      IF(IERR .NE. 1) GO TO 918 
C     SET BYTE COUNT TO ZERO
525   LEN = 0 
      IF(IPASS-1) 805,800,805 
C 
C     PROCESS IF DIRECTIVE                                   -- IF
C 
540   IPDEF = 1 
C     FETCH IF OPERAND
      CALL ESCAN(IVAL)
      IF(IERR-1) 681,542,681
C     IF OPERAND IS ZERO, SET IFCTL SO CODE IS NOT GENERATED
542   IFON = 2
      IF(IVAL) 546,544,546
544   IFON = 1
546   IFCTL = IFON
C     CHECK FOR NESTED IF LEVEL OVERFLOW
      IF(IFSET-16) 548,985,985
548   IFSET = IFSET+1 
      IFPAR(IFSET) = IFON+IFON
      GO TO 800 
C 
C     PROCESS IFC DIRECTIVE                                  -- IFC 
C 
550   IFON = 2
      GO TO 553 
C 
C     PROCESS IFNC DIRECTIVE                                 -- IFNC
C 
552   IFON = 1
553   IF(ICOL .GT. MCOL) GO TO 546
      IFCN2 = -1
      IFCN1 = 1 
      ICNT1 = 0 
      ICNT2 = 0 
      ICOL1 = ICOL-1
C     SCAN TO END OF FIRST STRING 
554   IF(IN(ICOL) .EQ. ICOMM) GO TO 555 
      ICNT1 = ICNT1+1 
      ICOL = ICOL+1 
      IF(ICOL-MCOL) 554,554,559 
C     CHECK SECOND STRING 
555   ICOL2 = ICOL
5555  IBLFL = 0 
556   ICOL = ICOL+1 
      IF(ICOL .GT. MCOL) GO TO 5575 
C     CHECK FOR OPTIONAL CHARACTER RANGE
      IF(IN(ICOL) .NE. ICOMM) GO TO 5568
      ICNT2 = ICNT2+IBLFL 
      ICOL = ICOL+1 
C     READ STRING COMPARE STARTING COLUMN 
      CALL ESCAN(IVAL)
      IF(IERR .NE. 1) GO TO 681 
      IFCN1 = IVAL
      IF(IFCN1 .EQ. 0) GO TO 988
      ICOL = ICOL+1 
C     READ STRING COMPARE ENDING COLUMN 
      CALL ESCAN(IVAL)
      IF(IERR .NE. 1) GO TO 681 
      IFCN2 = IVAL
      IF(IFCN2 .LT. IFCN1) GO TO 988
      GO TO 5575
5568  IF(IN(ICOL) .NE. IBLNK) GO TO 557 
C     HAVE A BLANK
      IBLFL = IBLFL+1 
      GO TO 556 
557   ICNT2 = ICNT2+1+IBLFL 
      GO TO 5555
C     COMPARE STRINGS AND CHECK IF LENGTHS ARE THE SAME 
5575  IF(ICNT1 .EQ. ICNT2) GO TO 5576 
      IF(IFCN2 .LT. 0) GO TO 559
      IF(ICNT1 .LT. IFCN2) GO TO 559
      IF(ICNT2 .LT. IFCN2) GO TO 559
5576  IF(ICNT1 .EQ. 0) GO TO 546
      IF(IFCN2 .GT. 0) GO TO 5577 
      IFCN2 = ICNT1 
5577  DO 558 I=IFCN1,IFCN2
      K1 = ICOL1+I
      K2 = ICOL2+I
      IF(IN(K1) .NE. IN(K2)) GO TO 559
558   CONTINUE
      GO TO 546 
C     STRINGS ARE NOT THE SAME
559   IFON = 3-IFON 
      GO TO 546 
C 
C     PROCESS IFD DIRECTIVE                                  -- IFD 
C 
560   IFON = 2
      GO TO 563 
C 
C     PROCESS IFND DIRECTIVE                                 -- IFND
C 
562   IFON = 1
563   IF(ICOL .GT. MCOL) GO TO 925
C     CALL LABEL TO SEE IF SYMBOL HAS BEEN DEFINED
      CALL LABEL(1) 
      IF(IERR-2) 546,559,925
C 
C     PROCESS ELSE DIRECTIVE                                 -- ELSE
C 
570   IF(IFSET .LE. 0) GO TO 920
      IFON = IFPAR(IFSET)/2 
      IELSE = IFPAR(IFSET)-(IFON+IFON)
      IF(IFON .LE. 0) GO TO 588 
      IF(IELSE .GT. 0) GO TO 920
      IFCTL = 3-IFON
      IFPAR(IFSET) = IFCTL+IFCTL+1
      GO TO 800 
C 
C     PROCESS THE ENDIF DIRECTIVE                            -- ENDIF 
C 
580   IF(IFSET-1) 920,582,584 
582   IFCTL = 2 
      IFSET = 0 
      GO TO 800 
584   IFSET = IFSET-1 
      IFCTL = IFPAR(IFSET)/2
C     CHECK FOR CONDITIONAL ASSEMBLY EXPANSION THAT SHOULD NOT BE LISTED
      IF(IFCTL-1) 588,588,800 
588   IF(LIF) 589,100,589 
589   ITYPE = -1
      GO TO 800 
C 
C     PROCESS MAP DIRECTIVE                                  -- MAP 
C 
C     READ MAP ORIGIN ADDRESS 
590   CALL ESCAN(IVAL)
      IF(IERR .NE. 1) GO TO 681 
      IF(IN(ICOL) .NE. ICOMM) GO TO 925 
      ICOL = ICOL+1 
      MAPAD = IVAL
C     READ MAP WORD LENGTH
      CALL ESCAN(IVAL)
      IF(IERR .NE. 1) GO TO 681 
      IF(IVAL .LT. 8.) GO TO 925
      IF(IVAL .GT. 128.) GO TO 925
      MWORD = IVAL
      LMAP = 1
      GO TO 800 
C 
C 
C     PROCESS THE END DIRECTIVE                              -- END 
C 
600   IEND = 1
      GO TO 800 
C 
C 
C     PROCESS ORG DIRECTIVE                                  -- ORG 
C 
620   IPDEF = 1 
      CALL ESCAN(IVAL)
      IF(IERR-1) 681,622,681
622   IF(IVAL-LC) 988,624,624 
624   IF(IVAL-65536.) 625,980,980 
625   LC = IVAL 
C     CHECK FOR DUPLICATE LABEL 
626   IF(IERRL) 800,627,800 
C     IF LABEL PRESENT, CHANGE ITS VALUE
627   IF(INDET) 628,800,628 
628   ITABV(INDET) = LC 
      GO TO 800 
C 
C     PROCESS ALIGN DIRECTIVE                                -- ALIGN 
C 
640   IPDEF = 1 
      CALL ESCAN(IVAL)
      IF(IERR-1) 681,642,681
642   IF(IVAL-32768.) 644,980,980 
644   FLG = 0.
      J = IVAL
      IF(LC-32768.) 646,645,645 
645   LC = LC-32768.
      FLG = 1.
646   I = LC
      LC = ((I-1)/J+1)*J
      LC = LC+FLG*32768.
      GO TO 626 
C 
C     PROCESS RES DIRECTIVE                                  -- RES 
C 
660   IPDEF = 1 
      CALL ESCAN(IVAL)
      IF(IERR-1) 681,662,681
662   IF(IVAL-32768.) 664,988,988 
664   LEN = IVAL
      GO TO 800 
C 
C     PROCESS DATA DIRECTIVE                                 -- DATA
C 
680   CONTINUE
681   GO TO (682,925,940,930,980,960,988,955,965),IERR
682   IF(KLEN-KWORD) 684,684,980
C     CONVERT NUMBER TO BINARY
684   CALL AHEX(IVAL,0) 
C     MOVE BITS TO OBJECT CODE BUFFER 
      DO 688 I=1,KWORD
      IOBIN(I) = ICHR0
688   CONTINUE
      I = 1 
      J = KWORD-35
      K = 36
      IF(J) 690,690,692 
690   I = 37-KWORD
      J = 1 
      K = KWORD 
692   DO 695 L=1,K
      IOBIN(J) = IBIN(I)
      I = I+1 
      J = J+1 
695   CONTINUE
      GO TO 800 
C 
C     PROCESS DUP DIRECTIVE                                  -- DUP 
C 
700   IF(NDUP .NE. 0) GO TO 920 
      IPDEF = 1 
      CALL ESCAN(IVAL)
      IF(IERR-1) 681,702,681
702   IF(IVAL-32768.) 704,988,988 
704   IF(IVAL) 988,988,710
710   NDUP = -IVAL+1. 
      JMAC = LEVEL
      GO TO 800 
C 
C     PROCESS FF DIRECTIVE                                   -- FF
C 
C     INITIALIZE INSTRUCTION LENGTH 
720   JLEN = 0
      KBIT = 1
C     SET FIELD ATTRIBUTES SO NO ACTION IS TAKEN
      DO 721 I=1,9
      LATT(I) = 0 
721   CONTINUE
C     SCAN NEXT FIELD 
722   CALL SCAN(IVAL) 
      IF(IERR-1) 7715,725,7715
C     UPDATE WORD LENGTH AND CHECK
725   JLEN = JLEN+ILEN
      IF(JLEN-KWORD) 726,726,945
726   GO TO (728,730,735,987,935),FTYPE 
C     PLACE DON'T CARE FIELD IN WORD
728   KBIT = KBIT+ILEN
      GO TO 735 
C     PLACE CONSTANT FIELD IN WORD
730   CALL AHEX(IVAL,0) 
      J = 37-ILEN 
      DO 732 I=1,ILEN 
      IOBIN(KBIT) = IBIN(J) 
      KBIT = KBIT+1 
      J = J+1 
732   CONTINUE
C     FINISHED WITH CURRENT FIELD, PROCESS NEXT FIELD 
735   IF(IN(ICOL)-ICOMM) 737,736,737
736   ICOL = ICOL+1 
      GO TO 722 
737   DO 738 I=1,4
      IF(IN(ICOL)-ITERM(I)) 738,739,738 
738   CONTINUE
      GO TO 987 
739   IF(JLEN-KWORD) 945,800,945
C 
C     PROCESS INSTRUCTION                                    -- DEF 
C 
740   JTYPE = -ITABS(INDEX)/256 
C     SET NUMBER OF FIELDS AND POINTER TO FIELD TABLE 
      KFLD = JTYPE-(JTYPE/64)*64
      INDEF = ITABV(INDEX)
      KBIT = 1
      IGO = 0 
C     INITIALIZE OVERLAY FLAG 
      IOVER = 0 
C 
C     PROCESS NEXT FIELD
C 
C     SET FIELD TYPE, LENGTH, AND ATTRIBUTES
741   JTYPE = IFLD(INDEF) 
      INDEF = INDEF+1 
      FTYPE = JTYPE-(JTYPE/4)*4+1 
      FTYP1 = FTYPE 
C     FTYPE - FIELD TYPE
C        1 = DON'T CARE 
C        2 = CONSTANT 
C        3 = VARIABLE 
C        4 = VARIABLE WITH DEFAULT
      JTYPE = JTYPE/4 
      FLEN = JTYPE
C     ISOLATE FIELD LENGTH
      IF(FTYPE .NE. 1) GO TO 742
C     FIELD LENGTH FOR DONT CARES MAY BE GREATER THAN 32
      FLEN = FLEN+1 
      GO TO 750 
742   FLEN = FLEN-(FLEN/32)*32+1
      JTYPE = JTYPE/32
C     INITIALIZE FIELD ATTRIBUTE ARRAY
      DO 7425 J=1,10
      LATT(J) = 0 
7425  CONTINUE
      IJ = JTYPE-(JTYPE/4)*4+1
      J1 = IJ+6 
      LATT(J1) = 1
      JTYPE = JTYPE/4 
      J1 = 32 
      DO 743 I=1,6
      LATT(I) = JTYPE/J1
      JTYPE = JTYPE-LATT(I)*J1
      J1 = J1/2 
743   CONTINUE
C 
C     BRANCH TO PROCESS FIELD TYPE
C 
      GO TO (750,760,770,770),FTYPE 
C     PROCESS DON'T CARE FIELD
750   KBIT = KBIT+FLEN
      GO TO 790 
C     PROCESS CONSTANT FIELD
760   IVAL = IFLD(INDEF)
      INDEF = INDEF+1 
      IVAL1 = IFLD(INDEF) 
      INDEF = INDEF+1 
      IVAL = IVAL*32768.+IVAL1
      IF(FTYPE-1) 765,787,765 
765   KLEN = FLEN 
      CALL MODFY(IVAL,FLEN,0) 
      GO TO 787 
C     PROCESS VARIABLE FIELD
C     CHECK TO SEE IF NO MORE FIELDS
770   IF(IGO) 780,771,780 
C     SET FIELD DEFAULT NUMBER BASE 
771   JBASE = IJ
      CALL SCAN(IVAL) 
7715  GO TO (772,946,987,940,950,960,980,955,925,930,988,955,965),IERR
C     SKIP OVER COMMA OR AMPERSAND
772   ICOL = ICOL+1 
C     FTYPE NOW REPRESENTS THE FIELD TYPE FOUND ON SCAN 
      GO TO (773,773,780,776,776),FTYPE 
C     SKIP OVER POSSIBLE FIELD DEFAULT VALUE
773   IF(FTYP1-4) 7738,7732,7738
7732  IF(IFLD(INDEF)) 7736,7734,7734
7734  INDEF = INDEF+1 
7736  INDEF = INDEF+1 
7738  IF(FTYPE-1) 785,775,785 
C     SUBSTITUTE DON'T CARES FOR V FIELD
775   IF(ILEN-FLEN) 960,750,960 
C     SET IGO CONTROL SO ALL REMAINING VARIABLE FIELDS
C     WILL BE FILLED WITH THEIR DEFAULTS
776   IGO = 1 
      ICOL = ICOL-1 
C     NULL FIELD, CHECK FOR DEFAULT 
C     RESTORE FIELD TYPE FROM INSTRUCTION DEFINTION 
780   FTYPE = FTYP1 
      IF(FTYPE-4) 975,782,975 
782   IF(IFLD(INDEF)) 783,760,760 
783   INDEF = INDEF+1 
      GO TO 750 
C     SUBSTITUE CONSTANT FOR V FIELD
785   IF(ILEN-FLEN) 960,787,960 
787   CALL AHEX(IVAL,0) 
      J = 37-FLEN 
      DO 788 I=1,FLEN 
      IF(IOBIN(KBIT) .EQ. ICHRX) GO TO 7875 
      IF(LATT(6) .EQ. 1) GO TO 7875 
      IF(JATT(6) .NE. 1) GO TO 970
7875  IOBIN(KBIT) = IBIN(J) 
      J = J+1 
      KBIT = KBIT+1 
788   CONTINUE
C     FINISHED SCANNING CURRENT FIELD 
790   KFLD = KFLD-1 
      IF(KFLD) 741,792,741
C     CHECK FOR OVERLAYED INSTRUCTION 
792   IF(IOVER) 120,793,120 
793   IF(LEND) 800,794,800
C 
C     FINISHED PROCESSING CURRENT INSTRUCTION 
C     CALL SCAN TO CHECK FOR ADDITIONAL INSTRUCTION OVERLAYING
C 
794   CALL SCAN(IVAL) 
      IF(IERR-1) 7715,795,7715
795   GO TO (925,925,935,120,800),FTYPE 
C 
C     CHECK FOR FORMAT ERROR IF NO OTHER ERRORS 
C 
800   IF(IERRI) 805,802,805 
802   IF(ICOL-MCOL) 803,803,805 
803   IF(IN(ICOL)-ICOMM) 805,935,805
805   IF(IPASS .EQ. 1) GO TO 815
C     WRITE LINE TO OUTPUT LISTING AND OBJECT WORD TO OBJECT MODULE FILE
      CALL LOUT(LMODE)
      CALL OUT
      GO TO 820 
C     SAVE SOURCE LINE IN INTERMEDIATE FILE 
815   CALL INOUT(7) 
      IF(MAC .NE. 0) GO TO 820
      MAC = 2 
820   IVAL = LEN
      LC = LC+IVAL
C     DISPLAY ERROR SUMMARY ON PASS 2 
      IF(IEND) 840,100,840
840   IF(IPASS-1) 850,995,850 
850   WRITE(IPRT,1002) IERRS
1002  FORMAT(/,/,26H   TOTAL ASSEMBLY ERRORS =,I5)
      GO TO 995 
C 
C     SET ERROR INDICATOR 
C 
C     LABEL ERROR 
900   IERRL = 51
      GO TO 921 
C     MISSING LABEL 
910   IERRL = 52
      GO TO 990 
C     DUPLICATE LABEL 
915   IERRL = 53
      GO TO 230 
C     SYMBOL TABLE FULL 
916   IERRL = 54
      GO TO 990 
C     MACRO NAME OR PARAMETER TABLE FULL
918   IERRL = 55
      GO TO 990 
C     ILLEGAL DIRECTIVE 
920   IERRI = 1 
921   LEN = 1 
      DO 922 I=1,128
      IOBIN(I) = ICHRX
922   CONTINUE
      ICOL = ICOL+1 
      GO TO 990 
C     ARGUMENT ERROR
925   IERRI = 2 
      GO TO 990 
C     SYNTAX ERROR - ILLEGAL EXPRESSION 
930   IERRI = 3 
      GO TO 990 
C     FORMAT ERROR
935   IERRI = 4 
      GO TO 990 
C     UNDEFINED SYMBOL
940   IERRI = 5 
      GO TO 990 
C     ILLEGAL MICROWORD LENGTH
945   IERRI = 6 
      GO TO 990 
C     ILLEGAL FIELD TYPE
946   IERRI = 15
      GO TO 990 
C     ILLEGAL FIELD LENGTH
950   IERRI = 7 
      GO TO 990 
C     ILLEGAL CONSTANT MODIFIER 
955   IERRI = 8 
      GO TO 990 
C     FIELD LENGTH CONFLICT 
960   IERRI = 9 
      GO TO 989 
C     ADDRESS NOT ON CURRENT PAGE 
965   IERRI = 16
      GO TO 990 
C     OVERLAY ERROR 
970   IERRI = 17
      GO TO 990 
C     NO DEFAULT VALUE
975   IERRI = 18
      GO TO 990 
C     VALUE ERROR, VALUE TOO LARGE FOR A HOST MACHINE REAL NUMBER 
980   IERRI = 10
      GO TO 990 
C     TABLE OVERFLOW ERROR
985   IERRI = 13
      GO TO 990 
C     UNEXPECTED CONTINUATION LINE
986   IERRI = 14
      GO TO 992 
C     ILLEGAL CHARACTER 
987   IERRI = 12
      GO TO 990 
C     ILLEGAL VALUE 
988   IERRI = 11
      GO TO 990 
989   ICOL = ICOL-1 
C     HAVE SET ERROR CODE, NOW OUTPUT LINE
990   ECOL = ICOL-1 
992   GO TO 800 
995   RETURN
      END 
      SUBROUTINE OPCOD
C 
C 
C     THIS ROUTINE CHECKS THE CURRENT ASSEMBLER DIRECTIVE TO
C     SEE IF IT IS LEGAL. 
C 
C     ENTRY PARAMETERS
C       ICOL - POINTS TO COLUMN OPCODE SCAN STARTS IN 
C 
C     EXIT PARAMETERS 
C        ITYPE = OPCODE TYPE
C          -1 = COMMENT STATEMENT 
C           1 = ASSEMBLER DIRECTIVE 
C           2 = DEF NAME, FF, OR DATA STATEMENT 
C           3 = MACRO REFERENCE 
C        IOPVA - OPCODE NUMBER
C        ICHK - OPCODE VALUE
C        ICOL - POINTS TO OPERAND FIELD IF VALID OPCODE FOUND 
C        JCOL - POINTS TO END OF LABEL IF LABEL FOUND 
C        IERR - ERROR STATUS
C           1 = VALID DIRECTIVE 
C           2 = SYMBOL ENDS WITH A COLON - PRESUMED LABEL 
C           3 = OPCODE ERROR
C           4 = COMMENT LINE
C           5 = NO OPCODE ON LINE 
C           6 = CONTINUATION LINE 
C 
      DIMENSION INST(5,17),INSTE(7,9) 
      DIMENSION ITERM(4)
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
      EQUIVALENCE(IBLNK,ITERM(1)) 
C 
C     THE FOLLOWING DATA TABLE DEFINES ALL LEGAL ASSEMBLER
C     DIRECTIVES.  EACH DATA STATEMENT CONSISTS OF FOUR OR SIX
C     CHARACTERS REPRESENTING THE DIRECTIVE, FOLLOWED BY
C     THE DIRECTIVE TYPE AND ITS NUMBER 
C 
C 
      DATA INST(1, 1),INST(2, 1),INST(3, 1),INST(4, 1),INST(5, 1) 
     1  /1HL,1HI,1HS,1HT,1002/
      DATA INST(1, 2),INST(2, 2),INST(3, 2),INST(4, 2),INST(5, 2) 
     1  /1HE,1HQ,1HU,1H ,1004/
      DATA INST(1, 3),INST(2, 3),INST(3, 3),INST(4, 3),INST(5, 3) 
     1  /1HS,1HE,1HT,1H ,1005/
      DATA INST(1, 4),INST(2, 4),INST(3, 4),INST(4, 4),INST(5, 4) 
     1  /1HI,1HF,1H ,1H ,1008/
      DATA INST(1, 5),INST(2, 5),INST(3, 5),INST(4, 5),INST(5, 5) 
     1  /1HE,1HL,1HS,1HE,1009/
      DATA INST(1, 6),INST(2, 6),INST(3, 6),INST(4, 6),INST(5, 6) 
     1  /1HE,1HN,1HD,1H ,1011/
      DATA INST(1, 7),INST(2, 7),INST(3, 7),INST(4, 7),INST(5, 7) 
     1  /1HO,1HR,1HG,1H ,1012/
      DATA INST(1, 8),INST(2, 8),INST(3, 8),INST(4, 8),INST(5, 8) 
     1  /1HR,1HE,1HS,1H ,1014/
      DATA INST(1, 9),INST(2, 9),INST(3, 9),INST(4, 9),INST(5, 9) 
     1  /1HD,1HA,1HT,1HA,2015/
      DATA INST(1,10),INST(2,10),INST(3,10),INST(4,10),INST(5,10) 
     1  /1HD,1HU,1HP,1H ,1016/
      DATA INST(1,11),INST(2,11),INST(3,11),INST(4,11),INST(5,11) 
     1  /1HF,1HF,1H ,1H ,2017/
      DATA INST(1,12),INST(2,12),INST(3,12),INST(4,12),INST(5,12) 
     1  /1HI,1HF,1HC,1H ,1018/
      DATA INST(1,13),INST(2,13),INST(3,13),INST(4,13),INST(5,13) 
     1 /1HI,1HF,1HN,1HC,1019/ 
      DATA INST(1,14),INST(2,14),INST(3,14),INST(4,14),INST(5,14) 
     1 /1HI,1HF,1HD,1H ,1020/ 
      DATA INST(1,15),INST(2,15),INST(3,15),INST(4,15),INST(5,15) 
     1 /1HI,1HF,1HN,1HD,1021/ 
      DATA INST(1,16),INST(2,16),INST(3,16),INST(4,16),INST(5,16) 
     1 /1HE,1HN,1HD,1HM,1024/ 
      DATA INST(1,17),INST(2,17),INST(3,17),INST(4,17),INST(5,17) 
     1  /1HM,1HA,1HP,1H ,1026/
      DATA INSTE(1,1),INSTE(2,1),INSTE(3,1),INSTE(4,1),INSTE(5,1),
     1  INSTE(6,1),INSTE(7,1) /1HN,1HO,1HL,1HI,1HS,1HT,1003/
      DATA INSTE(1,2),INSTE(2,2),INSTE(3,2),INSTE(4,2),INSTE(5,2),
     1  INSTE(6,2),INSTE(7,2) /1HE,1HN,1HD,1HI,1HF,1H ,1010/
      DATA INSTE(1,3),INSTE(2,3),INSTE(3,3),INSTE(4,3),INSTE(5,3),
     1  INSTE(6,3),INSTE(7,3) /1HS,1HP,1HA,1HC,1HE,1H ,1006/
      DATA INSTE(1,4),INSTE(2,4),INSTE(3,4),INSTE(4,4),INSTE(5,4),
     1  INSTE(6,4),INSTE(7,4) /1HE,1HJ,1HE,1HC,1HT,1H ,1007/
      DATA INSTE(1,5),INSTE(2,5),INSTE(3,5),INSTE(4,5),INSTE(5,5),
     1  INSTE(6,5),INSTE(7,5) /1HT,1HI,1HT,1HL,1HE,1H ,1001/
      DATA INSTE(1,6),INSTE(2,6),INSTE(3,6),INSTE(4,6),INSTE(5,6),
     1  INSTE(6,6),INSTE(7,6) /1HA,1HL,1HI,1HG,1HN,1H ,1013/
      DATA INSTE(1,7),INSTE(2,7),INSTE(3,7),INSTE(4,7),INSTE(5,7),
     1  INSTE(6,7),INSTE(7,7) /1HM,1HA,1HC,1HR,1HO,1H ,1022/
      DATA INSTE(1,8),INSTE(2,8),INSTE(3,8),INSTE(4,8),INSTE(5,8),
     1  INSTE(6,8),INSTE(7,8) /1HL,1HO,1HC,1HA,1HL,1H ,1023/
      DATA INSTE(1,9),INSTE(2,9),INSTE(3,9),INSTE(4,9),INSTE(5,9),
     1  INSTE(6,9),INSTE(7,9) /1HE,1HX,1HI,1HT,1HM,1H ,1025/
C 
      NUMOP = 17
      ICHK = 0
      ITYPE = 0 
      IOPVA = 0 
      ICNT = 0
      INSTT = 0 
      MLEN = 4
C     LOOK FOR START OF OPCODE
200   IF(IN(ICOL) .EQ. IBLNK) GO TO 218 
      IF(IN(ICOL) .EQ. ICTAB) GO TO 218 
C     CHECK FOR COMMENT LINE
      IF(IN(ICOL)-ISEMI) 215,920,215
C     CHECK FOR A CONTINUATION LINE 
215   IF(IN(ICOL)-IDIV) 220,950,220 
218   ICOL = ICOL+1 
      IF(ICOL-MCOL) 200,200,930 
C     FOUND START OF OPCODE, NOW FIND END OF OPCODE 
220   J1 = ICOL 
      JCOL = ICOL 
      CALL LABEL(1) 
      GO TO (225,222,910),NERR
C     CHECK FOR OVERLAY SYMBOL
222   IF(IN(ICOL) .EQ. IAMP) GO TO 260
C     CHECK FOR LABEL INDICATOR 
      IF(IN(ICOL) .EQ. ICOLN) GO TO 940 
C     CHECK FOR POSSIBLE MACRO
225   IF(MCNT .EQ. 0) GO TO 260 
      IF(JTYPE .NE. 6) GO TO 260
      ITYPE = 3 
      ICHK = 3000 
      GO TO 600 
260   J2 = LABCT
      IF(J2 .GT. MOPC) GO TO 330
      IF(J2 .LE. 4) GO TO 300 
      MLEN = 6
      INSTT = 1 
      NUMOP = 9 
C     CHECK OPCODE AGAINST ALL LEGAL OPCODES
300   DO 320 L=1,NUMOP
      DO 310 K=1,J2 
      K1 = J1+K-1 
      IF(INSTT) 302,302,304 
302   IF(IN(K1)-INST(K,L)) 320,310,320
304   IF(IN(K1)-INSTE(K,L)) 320,310,320 
310   CONTINUE
      IF(J2-MLEN) 315,500,500 
315   K2 = J2+1 
      IF(INSTT) 316,316,318 
316   IF(INST(K2,L)-IBLNK) 320,500,320
318   IF(INSTE(K2,L)-IBLNK) 320,500,320 
320   CONTINUE
C     CHECK FOR FORMAT NAME 
330   IF(IERR-1) 910,340,910
340   IF(JTYPE-4) 910,350,910 
350   ITYPE = 2 
      IOPVA = 27
      GO TO 600 
C     FETCH INSTRUCTION TYPE AND VALUE
500   ICHK = INST(5,L)
      IF(INSTT) 550,550,510 
510   ICHK = INSTE(7,L) 
550   ITYPE = ICHK/1000 
      IOPVA = ICHK-ITYPE*1000 
C     SCAN TO START OF ARGUMENT FIELD 
600   IERR = 1
      IF(IN(ICOL) .EQ. IBLNK) GO TO 610 
      IF(IN(ICOL) .NE. ICTAB) GO TO 990 
610   ICOL = ICOL+1 
      IF(ICOL-MCOL) 600,600,990 
C     OPCODE ERROR
910   IERR = 3
      GO TO 990 
C     FOUND COMMENT INDICATOR 
920   IERR = 4
      ITYPE = -1
      NOPRO = 1 
      GO TO 990 
C     NO OPCODE ON LINE 
930   IERR = 5
      GO TO 990 
C     PRESUMED LABEL
940   IERR = 2
      JCOL = ICOL 
      ICOL = J1 
      IXPNT = IXPNT-2 
      GO TO 990 
C     CONTINUATION LINE 
950   IERR = 6
990   RETURN
      END 
      SUBROUTINE LABEL(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 
C 
C     ENTRY PARAMETERS
C        MODE - INDICATES WHETHER DEFINITION OR REFERENCE OF LABEL
C           0 = DEFINITION
C           1 = REFERENCE 
C        ICOL - STARTING COLUMN OF SCAN 
C        IPDEF - FLAG INDICATING SYMBOL MUST BE DEFINED BEFORE REFERENCE
C     EXIT PARAMETERS 
C        CVAL - VALUE OF LABEL ON RETURN
C        JTYPE - SYMBOL TYPE
C           1 = REGULAR SYMBOL
C           2 = ENTRY POINT SYMBOL
C           3 = SET SYMBOL
C           4 = DEF NAME
C           5 = SUB NAME
C           6 = MACRO NAME
C        INDEX - INDEX OF SYMBOL IN TABLE 
C        KLEN - IMPLICIT LABEL LENGTH 
C        LLEN - EXPLICIT LABEL LENGTH 
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 
C 
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
C 
      LLEN = 0
      INDEX = 0 
      JTYPE = 1 
      CVAL = 0. 
C     SCAN SYMBOL, PLACE IN NAME BUFFER 
      CALL SYMBL
      IF(IERR-3) 100,920,100
C     CHECK TO SEE IF LABEL IS IN TABLE 
100   IF(ISYM) 120,914,120
120   DO 200 I=1,ISYM 
      DO 150 J=1,IWORD
      IF(ITAB(J,I)-NAME(J)) 200,150,200 
150   CONTINUE
      GO TO 900 
200   CONTINUE
      GO TO 914 
C     CHECK FOR PASS 2
900   INDEX = I 
      IF(IPASS-1) 902,904,902 
902   IF(IPDEF) 903,904,903 
C     CHECK BIT TO SEE IF SYMBOL DEFINED ON PASS 2 YET
903   JTYPE = ITABS(INDEX)
      I = (JTYPE-(JTYPE/16)*16)/8 
      IF(I) 904,914,904 
C     SYMBOL FOUND, GET ITS VALUE AND TYPE
904   IERR = 1
      CVAL = ITABV(INDEX) 
      JTYPE = ITABS(INDEX)
      IF(JTYPE) 905,906,906 
905   JTYPE = -JTYPE/(2**14)+4
      GO TO 9128
C     SET LABEL LENGTH FOR ORDINARY LABELS
906   KLEN = JTYPE/16 
      JTYPE = JTYPE-(JTYPE/8)*8 
C     IF LABEL NOT DEFINED BY EQU OR SET DIRECTIVES, SET LENGTH 
      IF(KLEN) 9128,908,9128
908   DO 912 I=1,IFBIT
C     FORM 2.**(IFBIT-I)
      J = IFBIT-I 
      REAL = 1. 
      IF(J) 909,911,909 
909   DO 910 K=1,J
      REAL = REAL+REAL
910   CONTINUE
911   K = CVAL/REAL 
      IF(K) 9125,912,9125 
912   CONTINUE
      J = -1
9125  KLEN = J+1
9128  IF(LREF+IPASS-3) 990,913,990
913   CALL XREFT(MODE,0)
      GO TO 990 
C     SYMBOL NOT IN TABLE 
914   IERR = 2
      IF(MODE) 990,915,990
915   IF(ISYM-LTAB) 918,940,940 
918   ISYM = ISYM+1 
      INDEX = ISYM
      GO TO 990 
C     SYMBOL ERROR
920   IERR = 3
      GO TO 990 
C     SYMBOL TABLE FULL 
940   IERR = 4
990   MERR = IERR 
      RETURN
      END 
      SUBROUTINE SYMBL
C 
C 
C     THIS SUBROUTINE IS USED TO FORM A SYMBOL AND ITS INDEX
C     INTO THE SYMBOL TABLE 
C 
C 
      DIMENSION ITERM(4)
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
      EQUIVALENCE (ITERM(1),IBLNK)
C 
C     ENTRY PARAMETERS
C        ICOL - STARTING COLUMN OF SCAN 
C     EXIT PARAMETERS 
C        NAME - CONTAINS NUMERIC EQUIVALENT OF SYMBOL 
C        ICOL = COLUMN FOLLOWING SYMBOL 
C        IERR - ERROR STATUS
C           1 = SYMBOL ENDS WITH A BLANK, COMMA, OR SEMICOLON 
C           2 = SYMBOL ENDS WITH OTHER THAN BLANK,COMMA,SEMICOLON 
C           3 = SYMBOL ERROR
C        NERR  - SAME AS IERR 
C        LABCT - NUMBER OF CHARACTERS IN SYMBOL 
C 
      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,37 
      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   DO 122 I=1,4
      IF(IN(ICOL)-ITERM(I)) 122,900,122 
122   CONTINUE
      GO TO 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 
      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 ENDS WITH A BLANK, COMMA, OR SEMICOLON 
900   IERR = 1
      GO TO 990 
C     SYMBOL ENDS WITH OTHER THAN A BLANK, COMMA, OR SEMICOLON
920   IERR = 2
      GO TO 990 
C     SYMBOL ERROR
930   IERR = 3
990   NERR = IERR 
      RETURN
      END 
      SUBROUTINE NUMB(MODE) 
C 
C     THIS ROUTINE CONVERTS A NUMERIC CONSTANT TO BINARY
C 
C     ENTRY PARAMETERS
C        NBASE - BASE OF NUMBERS WITHOUT BASE SPECIFICATIONS
C        ICOL - COLUMN THAT SCAN STARTS IN
C        MODE - CONTROL PARAMETER 
C           0 = DON'T SCAN CONSTANT MODIFIERS 
C           1 = SCAN CONSTANT MODIFIERS 
C        NFLAG = FLAG THAT ALLOWS CONSTANTS OF THE TYPE 025H TO BE READ 
C     EXIT PARAMETERS 
C        IERR - ERROR INDICATOR 
C           1 = NO ERROR, NUMERIC FORM
C           2 = NOT A NUMERIC FORM
C           3 = NUMERIC CONSTANT ERROR
C           4 = NUMERIC CONSTANT TOO LARGE
C           5 = IMPLICIT AND EXPLICIT LENGTH CONFLICT 
C        CVAL - CONTAINS CONSTANT VALUE 
C        ICOL - POINTS TO CHARACTER AFTER CONSTANT
C        KLEN - IMPLICIT LENGTH OF NUMERIC CONSTANT 
C        LLEN - EXPLICIT LENGTH OF NUMERIC CONSTANT 
C 
      REAL IVAL1,IVAL2
      DIMENSION JSYM(16),JCTYP(4),JCVAL(4),JCLEN(4) 
      DIMENSION NUMS(16)
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
      EQUIVALENCE (NUMS(1),IALPH(1))
      EQUIVALENCE (JSYM(1),IBLNK) 
      EQUIVALENCE (IATT(7),JCTYP(1))
      DATA JCVAL(1),JCVAL(2),JCVAL(3),JCVAL(4) /2,8,16,10/
      DATA JCLEN(1),JCLEN(2),JCLEN(3),JCLEN(4) /1,3,4,0/
C 
      CVAL = 0. 
      IFLG = 0
C     SET DEFAULT BASE VALUE AND DIGIT LENGTH 
      NBASE = JCVAL(JBASE)
      LBASE = JCLEN(JBASE)
C     INITIALIZE CONSTANT'S EXPLICIT LENGTH 
      LLEN = 0
      KKEN = 0
C     INITIALIZE CONSTANT'S IMPLICIT LENGTH 
      KLEN = 0
      DO 100 I=1,10 
      IF(IN(ICOL)-NUMS(I)) 100,120,100
100   CONTINUE
C     CHECK FOR A SHARP SIGN INDICATING A CONSTANT TYPE 
      ICOL1 = ICOL+1
      IF(IN(ICOL1)-ISHRP) 910,205,910 
C     CHECK FOR LENGTH SPECIFIED ON CONSTANT, 
C     FIND FIRST NON-DECIMAL NUMBER 
120   N1 = ICOL 
125   DO 140 I=1,10 
      IF(IN(ICOL)-NUMS(I)) 140,150,140
140   CONTINUE
      GO TO 160 
150   KKEN = KKEN*10+I-1
      ICOL = ICOL+1 
      IF(ICOL-MCOL) 125,125,910 
C     CHECK FOR FIELD DESCRIPTOR
160   DO 170 I=1,4
      IF(IN(ICOL)-JCTYP(I)) 170,180,170 
170   CONTINUE
C     NO FIELD DESCRIPTOR FOUND, NUMBER ASSUMED TO BE HEXIDECIMAL 
      GO TO 211 
C     IF NEXT CHARACTER IS A SHARP, THEN NUMBER JUST SCANNED
C     SPECIFIES EXPLICIT FIELD LENGTH 
180   ICOL1 = ICOL+1
      IF(IN(ICOL1)-ISHRP) 211,185,211 
185   LLEN = KKEN 
205   IFLG = 1
      NCHAR = IN(ICOL)
      ICOL = ICOL1+1
C     SKIP OVER BLANKS
207   IF(IN(ICOL)-IBLNK) 210,208,210
208   ICOL = ICOL+1 
      IF(ICOL-MCOL) 207,207,920 
C     SET STARTING COLUMN NUMBER OF CONSTANT
210   N1 = ICOL 
211   IF(ICOL-MCOL) 212,212,920 
C     CHECK FOR NUMERIC TERMINATOR
212   DO 214 I=1,16 
      IF(JSYM(I)-IN(ICOL)) 214,220,214
214   CONTINUE
      IF(IN(ICOL) .EQ. IUNDR) GO TO 220 
      IF(IN(ICOL) .EQ. IQUOT) GO TO 220 
      ICOL = ICOL+1 
      GO TO 211 
C     SET ENDING COLUMN NUMBER OF CONSTANT
220   ICOL1 = ICOL-1
C     IF CONSTANT TYPE NOT SPECIFIED, SET BASE TO DEFAULT 
      IF(IFLG) 300,225,300
225   IF(NFLAG) 235,230,235 
230   IFACT = NBASE 
      JFACT = LBASE 
      GO TO 335 
235   NCHAR = IN(ICOL1) 
      ICOL1 = ICOL1-1 
C     CHECK FOR CONSTANT TYPE 
300   DO 310 I=1,4
      IFACT = JCVAL(I)
      JFACT = JCLEN(I)
      IF(JCTYP(I)-NCHAR) 310,335,310
310   CONTINUE
C 
C     CONVERT HOLLERITH CODED NUMBER TO BINARY
C 
335   IF(ICOL1-N1) 920,338,338
338   DO 350 LL=N1,ICOL1
      DO 340 I=1,IFACT
      IF(IN(LL)-NUMS(I)) 340,345,340
340   CONTINUE
      GO TO 920 
345   IVAL1 = IFACT 
      IVAL2 = I-1 
      CVAL = CVAL*IVAL1+IVAL2 
      KLEN = KLEN+JFACT 
      IF(CVAL-ZVAL) 350,350,930 
350   CONTINUE
      IF(IFACT-10) 870,850,870
C     SET CONSTANT LENGTH FOR DECIMAL NUMBER
850   DO 860 I=1,IFBIT
C     FORM 2.**IFBIT-I
      REAL1 = 1.
      J = IFBIT-I 
      IF(J) 855,857,855 
855   DO 856 K=1,J
      REAL1 = REAL1+REAL1 
856   CONTINUE
857   K = CVAL/REAL1
      IF(K) 865,860,865 
860   CONTINUE
      J = -1
865   KLEN = J+1
C     IF AN EXPLICIT LENGTH IS SPECIFIED, THEN CHECK IMPLICIT LENGTH
870   IF(LLEN) 880,900,880
880   IF(LLEN-KLEN) 940,900,940 
C     FINISHED, NO ERROR
900   IERR = 1
      GO TO 990 
C     NOT A NUMERIC CONSTANT
910   IERR = 2
      GO TO 990 
C     NUMERIC CONSTANT ERROR
920   IERR = 3
      GO TO 990 
C     NUMERIC CONSTANT TOO LARGE
930   IERR = 4
C     EXPLICIT - IMPLICIT LENGTH CONFLICT 
      GO TO 990 
940   IERR = 5
990   RETURN
      END 
      SUBROUTINE SCAN(IVAL) 
C 
C 
C     THIS ROUTINE SCANS A SUBSTITUTION FIELD FOR A DEF NAME OR AN FF 
C     DIRECTIVE.  THE FIELD TYPE AND LENGTH ARE DETERMINED. 
C 
C 
C     ENTRY PARAMETERS
C        ICOL - POINTS TO COLUMN THAT SCAN STARTS IN
C     EXIT PARAMETERS 
C        ICOL - POINTS TO COLUMN THAT SCAN ENDED ON 
C        IVAL - VALUE OF FIELD IF FIELD IS A CONSTANT 
C        ILEN - LENGTH OF FIELD 
C        JATT - ARRAY SPECIFING FIELD ATTRIBUTES
C        FTYPE - FIELD TYPE 
C           1 = X, DONT CARE FIELD
C           2 = C, CONSTANT FIELD 
C           3 = NULL FIELD
C           4 = NEW FORMAT NAME 
C           5 = NO VALID FIELDS OR FORMAT NAMES LEFT
C        IERR - ERROR INDICATOR 
C           1 = NO ERROR
C           2 = ILLEGAL FIELD TYPE
C           3 = ILLEGAL CHARACTER 
C           4 = UNDEFINED SYMBOL
C           5 = ILLEGAL FIELD LENGTH
C           6 = FIELD LENGTH CONFLICT 
C           7 = VALUE ERROR, VALUE TOO LARGE
C           8 = ATTRIBUTE ERROR 
C           9 = ARGUMENT ERROR
C          10 = EXPRESSION ERROR
C          11 = ILLEGAL NEGATIVE VALUE
C          12 = ILLEGAL CONSTANT MODIFIER 
C          13 = ADDRESS NOT ON CURRENT PAGE 
C 
      REAL IVAL 
      DIMENSION NUMS(16),ITERM(4) 
      DIMENSION JCVAL(4),IMBUF(91),IMBU2(91)
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
      EQUIVALENCE (NUMS(1),IALPH(1))
      EQUIVALENCE (ICHRV,IALPH(32)),(ICHRX,IALPH(34)) 
      EQUIVALENCE (ITERM(1),IBLNK),(IMBUF(1),IMBU1(1)),(IMBU2(1),IERRI) 
      DATA JCVAL(1),JCVAL(2),JCVAL(3),JCVAL(4) /2,8,16,10/
C 
      IVAL = 0. 
      FTYPE = 0 
      ILEN = -1 
C     SCAN TO NON-BLANK CHARACTER 
60    IF(ICOL-MCOL) 65,65,75
65    IF(IN(ICOL)-IBLNK) 66,70,66 
66    IF(IN(ICOL)-ICTAB) 72,70,72 
70    ICOL = ICOL+1 
      GO TO 60
C     CHECK FOR A COMMENT LINE
72    IF(IN(ICOL)-ISEMI) 115,75,115 
C     READ NEXT LINE, CHECK FOR CONTINUATION
C     CANNOT DUPLICATE CONTINUED LINES
75    IF(JREAD .NE. 0) GO TO 78 
C     READ FROM SOURCE ON PASS 1 AND INTERMEDIATE FILE ON PASS 2
      IF(IPASS .NE. 1) GO TO 77 
C     CHECK FOR MACRO EXPANSION 
      IF(MAC .LE. 1) GO TO 76 
      CALL MCREF
      GO TO 78
76    CALL INOUT(1) 
      GO TO 78
77    CALL INOUT(6) 
78    LCOL = IFCOL
C     SCAN TO FIRST NON-BLANK CHARACTER 
80    IF(LCOL-MCOL) 85,85,945 
85    IF(INB(LCOL)-IBLNK) 86,87,86
86    IF(INB(LCOL)-ICTAB) 90,87,90
87    LCOL = LCOL+1 
      GO TO 80
90    IF(INB(LCOL)-IDIV) 110,92,110 
92    IF(IDUP .EQ. 0) GO TO 921 
      IDUP = 0
      NDUP = 0
      GO TO 945 
921   LEN = 0 
      IF(IPASS .NE. 1) GO TO 922
      CALL INOUT(7) 
C     INCREMENT LINE NUMBER 
      LISN = LISN+1 
      GO TO 923 
922   CALL LOUT(1)
923   LEN = 1 
C     MOVE NEW LINE TO INPUT BUFFER 
      J = 12
      TEMP = LEN
      IF(IPASS .EQ. 1) GO TO 924
      J = 1 
924   DO 93 I=J,91
      IMBU2(I) = IMBUF(I) 
93    CONTINUE
      LEN = TEMP
      ICOL = LCOL+1 
      IERRI = 0 
C     SCAN TO FIRST NON-BLANK CHARACTER 
      GO TO 60
110   JREAD = 1 
      FTYPE = 5 
      LEND = 1
C     CHECK FOR OVERLAY INDICATOR 
      IF(IOVER) 945,990,945 
115   IF(IOVER) 900,120,900 
C 
C     DETERMINE FIELD TYPE
C 
120   LCOL = ICOL 
C     CHECK FOR A DECIMAL NUMBER INDICATING FIELD LENGTH
      DO 125 I=1,10 
      IF(IN(ICOL)-NUMS(I)) 125,130,125
125   CONTINUE
      GO TO 160 
130   REAL1 = 0 
C     CONVERT FIELD LENGTH TO BINARY
151   DO 152 I=1,10 
      IF(IN(ICOL)-NUMS(I)) 152,155,152
152   CONTINUE
      GO TO 156 
155   REAL2 = I-1 
      REAL1 = REAL1*10.+REAL2 
      ICOL = ICOL+1 
      GO TO 151 
156   ILEN = 0
      IF(REAL1 .GE. 32768.) GO TO 1565
      ILEN = REAL1
C     CHECK FOR A DON'T CARE FIELD                           -- X 
1565  IF(IN(ICOL) .NE. ICHRX) GO TO 1585
      ICOL = ICOL+1 
      DO 158 I=1,4
      IF(IN(ICOL)-ITERM(I)) 158,159,158 
158   CONTINUE
      ICOL = LCOL 
      GO TO 230 
1585  IF(IN(ICOL)-ILPAR) 1587,230,1587
1587  ICOL = LCOL 
      ILEN = -1 
      GO TO 160 
159   FTYPE = 1 
      GO TO 900 
C     CHECK FOR NULL FIELD                                   -- NULL
160   IF(IN(ICOL)-ICOMM) 210,200,210
200   FTYPE = 3 
      GO TO 900 
C     CHECK FOR FORMAT OVERLAY INDICATOR                     -- & 
210   IF(IN(ICOL)-IAMP) 230,220,230 
220   FTYPE = 4 
      IOVER = 1 
      ICOL = ICOL+1 
      GO TO 60
C     CHECK FOR A NUMBER, LABEL, OR EXPRESSION
230   CALL ESCAN(IVAL)
      GO TO (400,945,920,950,935,930,955,960,965),IERR
C 
C     SET FIELD TYPE TO CONSTANT                             -- C 
400   FTYPE = 2 
C 
C     PERFORM ACTIONS ON CONSTANT INDICATED BY
C     FIELD ATTRIBUTES SPECIFIED IN DEFINITION PROGRAM
C 
      CALL MODFY(IVAL,FLEN,0) 
      IF(IERR-1) 965,500,965
C     CHECK TO SEE IF FIELD LENGTH HAS BEEN SPECIFIED 
500   IF(ILEN) 510,520,520
510   ILEN = KLEN 
C     CHECK TO SEE IF ACTUAL FIELD LENGTH EQUALS SPECIFIED FIELD LENGTH 
520   IF(ILEN-KLEN) 930,550,930 
C     SEE IF FIELD LENGTH EXCEEDS MAXIMUM ALLOWABLE 
550   IF(ILEN-IFBIT) 800,800,925
C     CHECK TO SEE IF FIELD LENGTH EXCEEDS WORD LENGTH
800   IF(ILEN-KWORD) 802,802,925
C     CHECK FOR CORRECT TERMINATION CHARACTER 
802   DO 810 I=1,4
      IF(IN(ICOL)-ITERM(I)) 810,900,810 
810   CONTINUE
      GO TO 915 
C 
C     VALID FIELD FOUND 
C 
900   IERR = 1
      GO TO 990 
C 
C     SCAN ERRORS 
C 
C     ILLEGAL FIELD TYPE
910   IERR = 2
      GO TO 990 
C     ILLEGAL CHARACTER 
915   IERR = 3
      GO TO 990 
C     UNDEFINED SYMBOL
920   IERR = 4
      GO TO 990 
C     FIELD LENGTH TOO LARGE
925   IERR = 5
      GO TO 990 
C     FIELD LENGTH CONFLICT 
930   IERR = 6
      GO TO 990 
C     VALUE ERROR 
935   IERR = 7
      GO TO 990 
C     FIELD OR CONSTANT ATTRIBUTE ERROR 
940   IERR = 8
      GO TO 990 
C     ARGUMENT ERROR IN FIELD 
945   IERR = 9
      ICOL = ICOL+1 
      GO TO 990 
C     EXPRESSION ERROR IN FIELD 
950   IERR = 10 
      GO TO 990 
C     VALUE IS NEGATIVE, ILLEGAL
955   IERR = 11 
      GO TO 990 
C     ILLEGAL CONSTANT MODIFIER 
960   IERR = 12 
      GO TO 990 
C     ADDRESS NOT ON CURRENT PAGE 
965   IERR = 13 
990   RETURN
      END 
      SUBROUTINE ESCAN(IVAL)
C 
C 
C     THIS SUBROUTINE SCANS AND EVALUEATES EXPRESSIONS.  THE
C     EXPRESSION SCAN IS ENDED BY A BLANK, COMMA, OR RIGHT
C     PARENTHESIS 
C 
C     ENTRY PARAMETERS
C        ICOL - POINTS TO START OF SCAN 
C        NBASE - BASE OF NUMBERS WITHOUT BASE SPECIFICATIONS
C     EXIT PARAMETERS 
C        IVAL - EXPRESSION VALUE
C        KLEN - EXPRESSION LENGTH 
C        ICOL - POINTS TO COLUMN SCAN ENDED ON
C        IERR - ERROR INDICATOR 
C           1 = NO ERROR, ENDS WITH RIGHT PARENTHESIS,BLANK OR COMMA
C           2 = ARGUMENT ERROR
C           3 = UNDEFINED SYMBOL
C           4 = EXPRESSION ERROR
C           5 = NUMERIC CONSTANT TOO LARGE
C           6 = FIELD LENGTH CONFLICT 
C           7 = EXPRESSION VALUE IS NEGATIVE
C           8 = ILLEGAL CONSTANT MODIFIER 
C           9 = ADDRESS NOT ON CURRENT PAGE 
C 
      REAL IVAL,IVAL1,IVAL2,IVAL3,JVAL,KDIV 
      DIMENSION JSYM(14),ITERM(4),NP(44)
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
      EQUIVALENCE(JSYM(1),IBLNK),(ITERM(1),IBLNK) 
      EQUIVALENCE (JATT(3),JATT3),(JATT(4),JATT4),(JATT(5),JATT5) 
      DATA NP( 1),NP( 2),NP( 3),NP( 4) /1HE,1HQ,1H_,1H /
      DATA NP( 5),NP( 6),NP( 7),NP( 8) /1HN,1HE,1H_,1H /
      DATA NP( 9),NP(10),NP(11),NP(12) /1HG,1HT,1H_,1H /
      DATA NP(13),NP(14),NP(15),NP(16) /1HL,1HT,1H_,1H /
      DATA NP(17),NP(18),NP(19),NP(20) /1HL,1HE,1H_,1H /
      DATA NP(21),NP(22),NP(23),NP(24) /1HG,1HE,1H_,1H /
      DATA NP(25),NP(26),NP(27),NP(28) /1HA,1HN,1HD,1H_/
      DATA NP(29),NP(30),NP(31),NP(32) /1HO,1HR,1H_,1H /
      DATA NP(33),NP(34),NP(35),NP(36) /1HX,1HO,1HR,1H_/
      DATA NP(37),NP(38),NP(39),NP(40) /1HS,1HH,1HL,1H_/
      DATA NP(41),NP(42),NP(43),NP(44) /1HS,1HH,1HR,1H_/
C 
C     SET OPERATOR FLAG TO INDICATE NONE
      IOPER = 0 
C     SET FLAG TO INDICATE NO EXPRESSION
      IFLG = 0
      IVAL = 0. 
      IVAL1 = 0.
      ESIGN = 1 
      IEXP = 3
      KLEN = 0
      MODE = 0
      IF(IN(ICOL)-ILPAR) 10,5,10
5     MODE = 1
      ICOL = ICOL+1 
10    NCHAR = IN(ICOL)
      IERR = 1
C 
C     CHECK FOR SCAN TERMINATION CHARACTER
C 
      DO 12 I=1,4 
      IF(NCHAR-ITERM(I)) 12,600,12
12    CONTINUE
      IF(MODE .EQ. 0) GO TO 20
      IF(NCHAR .EQ. IRPAR) GO TO 600
C 
C     CHECK FOR A PLUS SIGN 
C 
20    IF(NCHAR-IPLUS) 50,28,50
28    NSIGN = 1 
      GO TO 60
C 
C     CHECK FOR A MINUS SIGN
50    IF(NCHAR-IMIN) 70,54,70 
54    NSIGN = -1
C     CHECK FOR TWO OPERATORS IN A ROW
60    IF(IEXP-2) 64,930,64
64    IEXP = 2
      IFLG = 1
      IVAL = IVAL1*ESIGN+IVAL 
      ESIGN = NSIGN 
      IOPER = 0 
      IVAL1 = 0.
      GO TO 900 
C 
C     CHECK FOR MULTIPLY SIGN 
C 
70    IF(NCHAR-IAST) 80,72,80 
72    IOPER = 1 
      GO TO 84
C 
C     CHECK FOR / SIGN
C 
80    IF(NCHAR .NE. IDIV) GO TO 90
      IOPER = 2 
C     CHECK FOR TWO OPERATORS IN A ROW
84    IF(IEXP-2) 86,930,86
86    IEXP = 2
      IFLG = 1
      GO TO 900 
C     CHECK FOR RELATIONAL OR BOOLEAN OPERATOR
90    IF(NCHAR .NE. IUNDR) GO TO 100
      ICOL1 = ICOL
      J = 1 
92    ICOL = ICOL+1 
      IF(IN(ICOL) .EQ. IUNDR) GO TO 94
      J = J+1 
      IF(J .GT. 4) GO TO 910
      GO TO 92
C     CHECK FOR VALID OPERATOR
94    DO 96 LL=1,11 
      NN = (LL-1)*4 
      DO 95 N=1,J 
      L = ICOL1+N 
      NN = NN+1 
      IF(IN(L) .NE. NP(NN)) GO TO 96
95    CONTINUE
C     VALID BOOLEAN OR REALTIONAL OPERATOR FOUND, SET INDEX 
      IOPER = LL+2
      GO TO 84
96    CONTINUE
C 
C     PROCESS THE OPERAND 
C 
100   IF(IEXP-1) 106,930,106
106   IEXP = 1
      JVAL = 0. 
C     CHECK FOR LOCATION COUNTER REFERENCE
      IF(NCHAR .NE. IDOLR) GO TO 300
      JVAL = LC 
      ICOL = ICOL+1 
C     DETERMINE BIT LENGTH OF LOCATION COUNTER
      DO 250 I=1,IFBIT
C     FORM 2**(IFBIT-I) 
      J = IFBIT-I 
      REAL1 = 1.
      IF(J .EQ. 0) GO TO 240
      DO 230 K=I,J
      REAL1 = REAL1+REAL1 
230   CONTINUE
240   K = JVAL/REAL1
      IF(K) 260,250,260 
250   CONTINUE
      J = -1
260   KLEN = J+1
      GO TO 420 
C     CHECK FOR NUMERIC CONSTANT
300   CALL NUMB(1)
      GO TO (410,400,910,940,410),IERR
C     CHECK FOR LEGAL LABEL 
400   CALL LABEL(1) 
      GO TO (410,920,910),IERR
C     CHECK FOR LEGAL LABEL TYPE
410   IF(JTYPE .GE. 4) GO TO 910
      JVAL = CVAL 
C 
C     CHECK FOR CONSTANT MODIFIERS
C 
C     INITIALIZE MODIFIER ARRAY 
420   DO 425 I=1,6
      JATT(I) = 0 
425   CONTINUE
428   DO 430 I=1,6
      IF(IN(ICOL)-IATT(I)) 430,435,430
430   CONTINUE
      GO TO 450 
C     IF JATT BIT ALREADY SET, CHARACTER MUST BE OPERATOR 
435   IF(JATT(I)) 450,440,450 
C     * AND - MAY BE OPERATORS, NOT MODIFIERS 
440   IF(I-2) 441,441,445 
441   ICOL1 = ICOL+1
      DO 442 J=1,14 
      IF(IN(ICOL1)-JSYM(J)) 442,445,442 
442   CONTINUE
C     * OR - IS NOT A CONSTANT MODIFIER 
      GO TO 450 
445   JATT(I) = 1 
      ICOL = ICOL+1 
      GO TO 428 
C     CHECK FOR ILLEGAL MODIFIER COMBINATIONS 
450   IF(JATT(1)+JATT(2)-2) 452,970,452 
C     CHECK FOR $ MODIFIER
452   IF(JATT5 .EQ. 0) GO TO 455
      JATT3 = 1 
      JATT4 = 1 
C     PERFORM OPERATIONS SPECIFIED BY CONSTANT MODIFIERS
C     SET LENGTH FOR MODIFIERS
455   JLEN = LLEN 
      IF(LLEN) 459,456,459
456   JLEN = KLEN 
      IF(MODE-1) 457,459,457
C     FOR DEF'S MAKE LENGTH ACTUAL FIELD LENGTH IF EXPLICIT 
C     LENGTH (LLEN) IS NOT SPECIFIED
457   IF(IOPVA .NE. 27) GO TO 459 
      JLEN = FLEN 
459   CALL MODFY(JVAL,JLEN,1) 
      IF(IERR-1) 980,490,980
490   IF(MODE-2) 497,496,497
496   IVAL = JVAL 
      GO TO 850 
497   IF(IERR-1) 498,500,498
498   IF(KLEN-LLEN) 950,500,950 
C 
C     CHECK TO SEE IF ANY ARITHMETIC OPERATIONS SHOULD BE PERFORMED 
C 
500   I = IOPER+1 
      GO TO (502,504,506,520,525,530,535,540,545,550, 
     1  555,560,565,570),I
502   IVAL1 = JVAL
      GO TO 905 
C     PERFORM MULTIPLICATION
504   IVAL1 = IVAL1*JVAL
      GO TO 905 
506   IF(JVAL) 508,510,508
C     PERFORM DIVISION
508   K = IVAL1/JVAL
      IVAL1 = K 
      GO TO 905 
510   IVAL1 = 0.
      GO TO 905 
C     PROCESS EQUAL OPERATION          .EQ. 
520   IF(IVAL1-JVAL) 595,590,595
C     PROCESS NOT EQUAL OPERATION      .NE. 
525   IF(IVAL1-JVAL) 590,595,590
C     PROCESS GREATER THAN OPERATION   .GT. 
530   IF(IVAL1-JVAL) 595,595,590
C     PROCESS LESS THAN OPERATION      .LT. 
535   IF(IVAL1-JVAL) 590,595,595
C     PROCESS LESS THAN OR EQUAL       .LE. 
540   IF(IVAL1-JVAL) 590,590,595
C     PROCESS GREATER THAN OR EQUAL    .GE. 
545   IF(IVAL1-JVAL) 595,590,590
C     PROCESS AND FUNCTION             .AND.
550   IC1 = 2 
      IC2 = 2 
      GO TO 580 
C     PROCESS OR FUNCTION              .OR. 
555   IC1 = 1 
      IC2 = 2 
      GO TO 580 
C     PROCESS XOR FUNCTION             .XOR.
560   IC1 = 1 
      IC2 = 1 
      GO TO 580 
C     PROCESS SHIFT LEFT FUNCTION      .SHL.
565   REAL1 = IFBIT 
      IF(JVAL .GT. REAL1) GO TO 595 
      IC1 = JVAL
      IVAL2 = 2.**IC1 
      IVAL1 = IVAL1*IVAL2 
      GO TO 905 
C     PROCESS SHIFT RIGHT FUNCTION     .SHR.
570   REAL1 = IFBIT 
      IF(JVAL .GT. REAL1) GO TO 595 
      IC1 = JVAL
      IVAL2 = 2**IC1
      IVAL1 = IVAL1/IVAL2 
      GO TO 905 
C     PERFORM BIT PROCESSING FOR AND, OR, AND XOR 
580   IVAL3 = 0 
      KDIV = 524288.
      DO 588 I=1,20 
      IB1 = IVAL1/KDIV
      IVAL2 = IB1 
      IVAL1 = IVAL1-IVAL2*KDIV
      IB2 = JVAL/KDIV 
      IVAL2 = IB2 
      JVAL = JVAL-IVAL2*KDIV
      IB1 = IB1+IB2 
      IF(IB1-IC1) 586,584,582 
582   IF(IB1-IC2) 586,584,586 
584   IVAL3 = IVAL3+KDIV
586   KDIV = KDIV/2.
588   CONTINUE
      IVAL1 = IVAL3 
      GO TO 905 
C     SET REALATIONAL EXPRESSION TO A TRUE VALUE
590   IVAL = 65535. 
      GO TO 597 
C     SET REALTIONAL EXPRESSION TO A FALSE VALUE
595   IVAL = 0
597   IERR = 1
      GO TO 990 
C 
C     CHECK FOR ILLEGAL GRAMMAR 
C 
600   IF(IEXP-2) 730,930,910
730   IVAL = IVAL+ESIGN*IVAL1 
      IF(IVAL-ZVAL) 740,740,940 
C     CHECK FOR NUMBER OR LABEL ONLY
740   IF(IFLG) 800,825,800
C     SET EXPRESSION LENGTH 
800   DO 810 I=1,IFBIT
C     FORM 2.**(IFBIT-I)
      J = IFBIT-I 
      REAL1 = 1.
      IF (J) 801,805,801
801   DO 802 K=1,J
      REAL1 = REAL1+REAL1 
802   CONTINUE
805   K = IVAL/REAL1
      IF(K) 820,810,820 
810   CONTINUE
      J = -1
820   KLEN = J+1
825   IF(MODE) 830,850,830
830   IF(IN(ICOL)-IRPAR) 910,831,910
C     CHECK FOR CONSTANT MODIFIERS AFTER RIGHT PARENTHESIS
831   ICOL = ICOL+1 
      JVAL = IVAL 
      MODE = 2
      LLEN = 0
      IF(ILEN) 420,835,835
835   LLEN = ILEN 
      GO TO 420 
C     CHECK FOR ILLEGAL NEGATIVE VALUE
850   IF(IVAL) 960,990,990
C 
C     SCAN NEXT TOKEN 
900   ICOL = ICOL+1 
905   IF(ICOL-MCOL) 10,10,910 
C 
C     EXPRESSION ERRORS 
C 
C     ARGUMENT ERROR
910   IERR = 2
      GO TO 990 
C     UNDEFINED SYMBOL
920   IERR = 3
      GO TO 990 
C     EXPRESSION ERROR
930   IERR = 4
      GO TO 990 
C     NUMERIC CONSTANT TOO LARGE
940   IERR = 5
      GO TO 990 
C     IMPLICIT AND EXPLICIT FIELD LENGTH CONFLICT 
950   IERR = 6
      GO TO 990 
C     VALUE IS NEGATIVE, ILLEGAL
960   IERR = 7
      GO TO 990 
C     ILLEGAL MODIFIER
970   IERR = 8
      GO TO 990 
C     ADDRESS NOT ON CURRENT PAGE 
980   IERR = 9
990   RETURN
      END 
      SUBROUTINE MODFY(IVAL,MLEN,MODE)
C 
C 
C     THIS SUBROUTINE MODIFIES A CONSTANT AS SPECIFIED BY 
C     A SET OF MODIFIERS.  THE MODIFIERS CAN BE THOSE SPECIFIED 
C     AT ASSEMBLY TIME OR IN THE CASE OF VARIABLE FIELD SUBSTITUTES,
C     THOSE SPECIFIED AT DEFINITION TIME. 
C 
C 
C     ENTRY PARAMETERS
C        IVAL - CONSTANT VALUE
C        KLEN - CONSTANT LENGTH 
C        MODE - INDICATES WHICH MODIFIER ARRAY TO USE 
C        MLEN - LENGTH THAT MODIFIERS OPERATE ON
C     EXIT PARAMETERS 
C        IVAL - CONSTANT VALUE AFTER MODIFICATION 
C        KLEN - CONSTANT LENGTH AFTER MODIFICATION
C        IERR - ERROR INDICATOR 
C           1 = NO ERROR
C           2 = PAGING ERROR
C 
C 
      REAL IVAL,IVAL2,IVAL3,IVAL4,IVAL5,IVAL6 
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
C 
C     CALCULATE 2**MLEN 
      IVAL2 = 1.
      DO 452 I=1,MLEN 
      IVAL2 = IVAL2+IVAL2 
452   CONTINUE
C     CHECK FOR MODIFIERS 
      DO 500 I=1,5
      IF(MODE) 458,456,458
C     USE MODIFIERS SET IN DEFINITION PROGRAM 
456   IF(LATT(I)) 460,500,460 
C     USE MODIFIERS SET IN ASSEMBLY PROGRAM 
458   IF(JATT(I)) 460,500,460 
C     BRANCH TO PROCESS MODIFIER
460   GO TO (465,470,475,480,490),I 
C     INVERT CONSTANT 
465   IVAL3 = 0.
      GO TO 471 
C     FORM TWOS COMPLEMENT OF LOWER FLEN BITS OF IVAL 
470   IVAL3 =1. 
471   IVAL5 = IVAL
      IF(MLEN-14) 473,474,474 
473   K = IVAL/16284. 
      IVAL6 = K 
      IVAL6 = IVAL6*16284.
      IVAL5 = IVAL-IVAL6
474   K = IVAL5/IVAL2 
      IVAL4 = K 
C     IVAL5 IS LOWER FLEN BITS OF IVAL
      IVAL5 = IVAL5-IVAL4*IVAL2 
      IVAL4 = IVAL2-1.-IVAL5+IVAL3
      IF(IVAL4-IVAL2) 4747,4745,4745
4745  IVAL4 = IVAL4-IVAL2 
4747  IVAL = IVAL-IVAL5+IVAL4 
      GO TO 500 
C     RIGHT JUSTIFY VALUE IN FIELD
475   IF(KLEN-MLEN) 476,500,500 
476   KLEN = MLEN 
      GO TO 500 
C     TRUNCATE THE CONSTANT TO SPECIFIED FIELD LENGTH 
C     FORM 2.**MLEN 
480   IF(KLEN-MLEN) 482,482,481 
481   KLEN = MLEN 
482   IVAL4 = 0.
      IF(MLEN-14) 487,488,488 
487   K = IVAL/16384. 
      IVAL4 = K 
      IVAL4 = IVAL4*16384.
      IVAL = IVAL-IVAL4 
488   K = IVAL/IVAL2
      IVAL5 = K 
      IVAL5 = IVAL5*IVAL2 
      IVAL4 = IVAL4+IVAL5 
      IVAL = IVAL-IVAL5 
      GO TO 500 
C     PERFORM CHECKS FOR PAGED ADDRESSING 
490   K = LC/IVAL2
      IVAL3 = K 
      IVAL3 = IVAL3*IVAL2 
      IF(IVAL3-IVAL4) 950,500,950 
500   CONTINUE
      IERR = 1
      GO TO 990 
950   IERR = 2
990   RETURN
      END 
      SUBROUTINE LOUT(LMODE)
C 
C 
C     THIS SUBROUTINE IS USED TO OUTPUT THE ASSEMBLER LISTING 
C 
C 
C     ENTRY PARAMETERS
C        LMODE - OUTPUT MODE PARAMETER
C           1 = NORMAL LINE 
C           2 = SPACE DIRECTIVE 
C           3 = EJECT DIRECTIVE 
C        LERR - FLAG INDICATING ERRORS SHOULD BE LISTED AT TERMINAL 
C 
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
C 
      IOOUT = IPRT
      JERR = 0
C     SET ADDRESS FIELD TO BLANKS 
      DO 40 I=1,12
      IADDR(1,I) = IBLNK
40    CONTINUE
C     CHECK FOR ADDRESS LIST OPTION 
      IF(LADR .EQ. 1) GO TO 50
      IF(ICHK .EQ. 1012) GO TO 50 
      IF(ICHK .EQ. 1013) GO TO 50 
      IF(LEN .EQ. 0) GO TO 55 
C     CONVERT PROGRAM COUNTER TO HOLLERITH REPRESENTATION 
50    CALL AHEX(LC,1) 
C     SET LIST MODE,  1=ORDINARY LINE, 2,3=ERROR LINES
55    MODE = 1
C     CHECK FOR AN ASSEMBLY ERROR 
      IF((IERRL+IERRI) .NE. 0) GO TO 100
C     CHECK SOURCE AND MACRO LIST FLAGS 
      IF(LSOR .EQ. 0) GO TO 900 
      IF(MAC .NE. 2) GO TO 100
      IF(LMAC .EQ. 0) GO TO 900 
      IF(LMAC1 .NE. 0) GO TO 100
      IF(LEN .EQ. 0) GO TO 900
C     CHECK OUTPUT LINE COUNT PER PAGE
100   LINE = LINE+1 
      IF(LINE-IOLIN) 400,400,200
C     EJECT TO NEXT PAGE AND PRINT TITLE
200   WRITE(IPRT,1001) IFORM,LTITL,IPAGE
1001  FORMAT(A1,4HLINE,4X,4HADDR,3X,50A1,4X,5HPAGE ,I4,/) 
      IPAGE = IPAGE+1 
      LINE = 3
400   GO TO (410,600,900),LMODE 
410   GO TO (412,450,460),MODE
C     CHECK FOR A MACRO EXPANSION 
412   IMACP = IBLNK 
      IF(MAC .NE. 2) GO TO 4127 
      IMACP = IPLUS 
4127  WRITE(IOOUT,1002) LISN,(IADDR(1,I),I=7,12),IMACP,(IN(I),I=1,LTBLK)
1002  FORMAT(1X,I4,2X,6A1,2X,A1,1X,80A1)
      IF(JERR .NE. 0) GO TO 425 
      IF(LEN) 413,425,413 
413   IF(LOBJ1) 4135,425,4135 
4135  LINE = LINE+1 
      IF(KWORD-48) 415,415,420
415   WRITE(IPRT,1005) (IOBIN(I),I=1,KWORD) 
1005  FORMAT(17X,6(8A1,1X)) 
      GO TO 425 
420   LINE = LINE+1 
      WRITE(IPRT,1005) (IOBIN(I),I=1,48)
      IF(KWORD-96) 422,422,423
422   WRITE(IPRT,1005) (IOBIN(I),I=49,KWORD)
      GO TO 425 
423   WRITE(IPRT,1005) (IOBIN(I),I=49,96) 
      WRITE(IPRT,1005) (IOBIN(I),I=97,KWORD)
425   MODE = 2
      IF((JERR*IERRL) .NE. 0) GO TO 450 
      IF(IERRL) 100,430,100 
430   MODE = 3
      IF(IERRI) 100,900,100 
450   CALL MESS(IERRL)
      IF(JERR*LERR) 460,465,460 
460   CALL MESS(IERRI)
465   IF(JERR .NE. 0) GO TO 900 
      IERRS = IERRS+1 
      IF(MODE .NE. 3) GO TO 430 
C     CHECK TO SEE IF ERRORS ARE LISTED AT TERMINAL 
      IF(LERR .EQ. 0) GO TO 900 
      IF(IOOUT .EQ. KTERM) GO TO 900
      IOOUT = KTERM 
      JERR = 1
      GO TO 4127
C     PROCESS SPACE DIRECTIVE 
600   IF(LINE-IOLIN) 610,610,200
610   WRITE(IPRT,1003)
1003  FORMAT(1X)
      ICNT = ICNT-1 
      IF(ICNT) 900,900,620
620   LINE = LINE+1 
      GO TO 600 
C     CLEAR ERROR FLAGS 
900   IERRI = 0 
      IERRL = 0 
      RETURN
      END 
      SUBROUTINE OUT
C 
C     THIS SUBROUTINE CREATES THE OUTPUT OBJECT MODULE
C 
C     ENTRY PARAMETERS
C        LC - CURRENT PROGRAM COUNTER 
C        LODLC - FIRST TIME CALLED SWITCH, EXPECTED LOAD ADDRESS
C 
      REAL IVAL 
      DIMENSION OVAL(3) 
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
      EQUIVALENCE(ICHR0,IALPH(1)),(ICHR1,IALPH(2))
      EQUIVALENCE (ICHRA,IALPH(11)),(ICHRH,IALPH(18)) 
      EQUIVALENCE (ICHRX,IALPH(34)) 
      EQUIVALENCE (OVAL(1),OVAL1),(OVAL(2),OVAL2),(OVAL(3),OVAL3) 
      EQUIVALENCE (IOBIN(1),IOB1),(IOBIN(2),IOB2) 
      EQUIVALENCE (IOBIN(3),IOB3),(IOBIN(4),IOB4) 
      EQUIVALENCE (IOBIN(8),IOB8),(IOBIN(11),IOB11) 
      EQUIVALENCE (IOBIN(18),IOB18) 
C 
C     CHECK TO SEE WHETHER OBJECT CODE SHOULD BE GENERATED
      IF(LOBJ) 20,990,20
C     CHECK FOR FIRST TIME CALLED 
20    IF(LODLC+2.) 25,400,25
25    IF(IEND) 500,28,500 
C     CHECK FOR OBJECT CODE 
28    IF(LEN) 30,990,30 
C     CHECK TO SEE IF ADDRESS RECORD SHOULD BE EMITTED
30    IF(LODLC-LC) 40,100,40
C     OUTPUT NEW ADDRESS RECORD 
40    DO 45 I=1,128 
      MCORE(I) = IOBIN(I) 
      IOBIN(I) = IBLNK
45    CONTINUE
      IOB1 = ICHRA
      LL = LOCT 
      LOCT = 0
      CALL AHEX(LC,1) 
      J = 8 
      DO 50 I=3,7 
      IOBIN(I) = IADDR(1,J) 
      J = J+1 
50    CONTINUE
      IOB3 = ICHR0
      IOB8 = ICHRH
      LOCT = LL 
      CALL INOUT(5) 
C     MOVE OBJECT CODE BACK TO OUTPUT BUFFER
      DO 70 I=1,KWORD 
       IOBIN(I) = MCORE(I)
70    CONTINUE
C     UPDATE LOAD ADDRESS AND OUTPUT DATA RECORD
100   LODLC = LC+1. 
      GO TO 800 
C     OUTPUT FIRST RECORD 
400   IF(LEN) 405,990,405 
405   DO 410 I=1,128
      MCORE(I) = IOBIN(I) 
      IOBIN(I) = IBLNK
410   CONTINUE
      IOB1 = IMULT
      IOB2 = IDOLR
      KCOL = 4
      LL = LOCT 
      LOCT = 0
      OVAL1 = KWORD 
      OVAL2 = LCMAX-LC
      OVAL3 = LC
      DO 430 I=1,3
      IVAL = OVAL(I)
      CALL AHEX(IVAL,1) 
      DO 420 J=8,12 
      IOBIN(KCOL) = IADDR(1,J)
      KCOL = KCOL+1 
420   CONTINUE
      IOBIN(KCOL) = ICHRH 
      KCOL = KCOL+2 
430   CONTINUE
      IOB4 = ICHR0
      IOB11 = ICHR0 
      IOB18 = ICHR0 
      CALL INOUT(5) 
      LODLC = -1. 
C     MOVE OBJECT CODE BACK TO OUTPUT BUFFER
      DO 440 I=1,KWORD
      IOBIN(I) = MCORE(I) 
440   CONTINUE
      LOCT = LL 
      GO TO 25
C     OUTPUT LAST RECORD
500   DO 510 I=1,KWORD
      IOBIN(I) = IBLNK
510   CONTINUE
      IOB1 = IDOLR
      IOB2 = IDOLR
      IOFLG = 1 
      GO TO 850 
C     CHECK TO SEE IF DATA IS TO BE INVERTED
800   IF(LINV) 810,850,810
810   DO 840 I=1,KWORD
      IF(IOBIN(I)-ICHRX) 820,840,820
820   IF(IOBIN(I)-ICHR0) 825,830,825
825   IOBIN(I) = ICHR0
      GO TO 840 
830   IOBIN(I) = ICHR1
840   CONTINUE
850   CALL INOUT(5) 
990   RETURN
      END 
      SUBROUTINE SYMTA
C 
C 
C     THIS SUBROUTINE IS USED TO OUTPUT A SYMBOL TABLE OF ALL 
C     SYMBOL USED IN THE PROGRAM AND DEFINED IN MACROS
C 
C 
      REAL IVAL 
      DIMENSION IXOUT(600)
      DIMENSION MTYPE(4),LISTS(6) 
      DIMENSION LLAB(4,10)
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
      EQUIVALENCE (IXOUT(1),IFLD(1)),(NAME(1),NAME1),(IXOUT(1),IXOU1) 
      EQUIVALENCE (IALPH(37),IQUES) 
      DATA LISTS(1),LISTS(2),LISTS(3),LISTS(4),LISTS(5),LISTS(6)
     1  /1HA,1HE,1HX,1HD,1HS,1HM/ 
C 
      IDIV = 256**(ICCNT-1) 
C     SET MXLAB TO A VALUE GREATER THAN THE LARGEST ENCODED SYMBOL
      MXLAB = 38*IDIV 
      IGX = 0 
C     CHECK FOR CROSS REFERENCE TABLE OVERFLOW
      IF(LREF) 140,140,6
6     IF(IXT) 7,140,140 
7     IXT = -IXT
      WRITE(IPRT,1010) IXT
1010  FORMAT(34H CROSS REFERENCE OVERFLOW AT LINE ,I5)
      LINE = 8
      IXT = 0 
140   MM = 0
C     SET SYMBOL VALUES TO BLANKS 
      DO 142 I=1,4
      DO 142 J=1,12 
      IADDR(I,J) = IBLNK
142   CONTINUE
145   NAME1 = MXLAB 
      IGO = 0 
C     GET NEXT HIGHER SYMBOL IN ALPHABETICAL ORDER
      LIND = 0
      IF(ISYM) 150,990,150
150   DO 260 L=1,ISYM 
C     CHECK FOR EMPTY SYMBOL TABLE POSITION 
      IF(ITAB(1,L)) 220,260,220 
220   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
C     CHECK TO SEE IF A SYMBOL WAS FOUND IN TABLE 
      IF(LIND) 300,270,300
270   IGO = 1 
      IF(MM) 400,990,400
C     DELETE SYMBOL FROM SYMBOL TABLE 
300   ITAB(1,LIND) = 0
      MM = MM+1 
      ICNT = 0
C     DECODE VALUE IN TABLE TO FORM OUTPUT CHARACTERS 
      DO 320 K=1,IWORD
      ID = IDIV 
      DO 320 L=1,ICCNT
      ICNT = ICNT+1 
      NN = NAME(K)/ID 
      IF(NN) 312,312,314
312   LLAB(MM,ICNT) = IBLNK 
      GO TO 3145
314   NAME(K) = NAME(K)-NN*ID 
      LLAB(MM,ICNT) = IALPH(NN) 
3145  IF(ICNT-MLAB) 316,321,321 
316   ID = ID/256 
320   CONTINUE
C     DECODE SYMBOL TYPE
321   NTYPE = ITABS(LIND) 
      IF(NTYPE) 322,323,323 
322   NTYPE = -NTYPE/16384+4
      GO TO 325 
323   NTYPE = NTYPE-((NTYPE/8)*8) 
C     CHECK FOR DEF OR SUB
325   IF(NTYPE-3) 326,326,330 
C     CHECK TO SEE IF LOCAL SYMBOLS SHOULD BE LISTED
C     GET SYMBOL VALUE
326   IF(LLOC .NE. 0) GO TO 327 
      IF(LLAB(MM,1) .NE. IQUES) GO TO 327 
      IF(LLAB(MM,2) .NE. IQUES) GO TO 327 
      GO TO 145 
327   IVAL = ITABV(LIND)
      CALL AHEX(IVAL,MM)
330   MTYPE(MM) = LISTS(NTYPE)
C     CHECK FOR SYMBOL OR CROSS REFERENCE TABLE 
      IF(LREF) 340,340,500
340   IF(MM-4) 145,400,400
C     INCREMENT LINE COUNT AND EJECT PAGE IF NECESSARY
400   LINE = LINE+1 
      IF(LINE-IOLIN) 420,420,410
410   WRITE(IPRT,1002) IFORM
1002  FORMAT(A1)
      LINE = 3
C     OUTPUT NEXT LINE OF SYMBOL TABLE
C     IF IFBIT IS INCREASED, THE IADDR INDEX NEEDS TO BE CHANGED
C     IN THE FOLLOWING WRITE AND FORMAT STATEMENTS TO REFLECT THE 
C     REQUIRED NUMBER OF OCTAL DIGITS NECESSARY FOR A SYMBOL
420   WRITE(IPRT,1003) ((LLAB(II,K),K=1,ICNT),MTYPE(II),
     1  (IADDR(II,L),L=6,12), II=1,MM)
1003  FORMAT(1X,4(8A1,1X,A1,1X,7A1,2X)) 
      IF(IGO) 990,140,990 
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 
      IXOU1 = 0 
      ITCNT = MXREF*IXCNT+IXPNT 
      IF(ITCNT-MXREF) 580,580,540 
C     READ PAGE FROM FILE 
540   IXT = 1 
C     IF CROSS REFERENCE FILE IS SEQUENTIAL INCLUDE REWIND
C     REWIND MCFLE
550   L = MXREF/MSIZE 
      I1 = 0
C     FILL CROSS REFERENCE PAGE BUFFER
      DO 570 I=1,L
      MCREC = IXT 
C 
C     THE FOLLOWING STATEMENTS READS THE CROSS REFERENCE FILE 
C 
      CALL INOUT(3) 
      IXT = IXT+1 
      DO 560 M1=1,MSIZE 
      M2 = M1+I1
      IXTAB(M2) = MCORE(M1) 
560   CONTINUE
      I1 = I1+MSIZE 
570   CONTINUE
580   LL = MXREF
      IF(ITCNT-MXREF) 590,600,600 
590   LL = ITCNT
C     SEARCH CURRENT PAGE BUFFER FOR REFERENCES TO CURRENT SYMBOL 
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 
C     INCREMENT LINE COUNT AND EJECT PAGE IF NECESSARY
660   LINE = LINE+1 
      IF(LINE-IOLIN) 680,670,670
670   WRITE(IPRT,1002) IFORM
      LINE = 3
C     IF IFBIT IS INCREASED, THE IADDR INDEX NEEDS TO BE CHANGED
C     IN THE FOLLOWING WRITE AND FORMAT STATEMENTS TO REFLECT THE 
C     REQUIRED NUMBER OF OCTAL DIGITS NECESSARY FOR A SYMBOL
680   WRITE(IPRT,1005) (LLAB(1,K),K=1,ICNT),MTYPE(1), 
     1  (IADDR(1,K),K=6,12),(IXOUT(K),K=M1,M2)
1005  FORMAT(1X,8A1,2X,A1,3X,7A1,6X,8I6)
      M1 = M1+8 
      LEN = LEN-8 
      IF(LEN) 140,140,690 
C     BALNK OUT CROSS REFERENCE LINE
690   DO 700 K=1,ICNT 
      LLAB(1,K) = IBLNK 
700   CONTINUE
      DO 710 I=1,12 
      IADDR(1,I) = IBLNK
710   CONTINUE
      MTYPE(1) = IBLNK
      GO TO 640 
990   RETURN
      END 
      SUBROUTINE XREFT(MODE,NCTL) 
C 
C     THIS SUBROUTINE ACCUMULATES CROSS REFERENCES
C 
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 
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
C 
      IF(IXT) 110,10,10 
10    IF(IXCNT-IXPAG) 20,40,40
20    IF(NCTL) 30,30,50 
30    IF(IXPNT-MXREF) 100,50,50 
40    IXT = -LISN 
      GO TO 110 
C     WRITE OUT PAGE TO FILE
50    K = MXREF/MSIZE 
      I1 = 0
      DO 70 I=1,K 
      DO 60 M1 = 1,MSIZE
      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(4) 
      I1 = I1+MSIZE 
      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-1) 
110   RETURN
      END 
      SUBROUTINE AHEX(IVAL,INDX)
C 
C 
C     THIS SUBROUTINE CONVERTS A VALUE BETWEEN 0 AND (2**IFBIT-1) 
C     INTO HEXADECIMAL,OCTAL, OR BINARY CHARACGERS. 
C     VALUES OUTSIDE OF THIS RANGE ARE RETURNED AS ASTERISKS. 
C 
C     ENTRY PARAMETERS
C        LOCT - FLAG INDICATING NUMBER BASE 
C           0 = HEXADECIMAL 
C           1 = OCTAL 
C        INDX - INDEX FOR IADDR ARRAY WHERE OUTPUT CHARACTERS ARE PUT 
C               IF INDX=0, BASE IS BINARY AND CHARACTERS ARE PUT IN IBIN
C        IVAL - VALUE TO CONVERT
C     EXIT PARAMETERS 
C        IADDR - ARRAY THAT HOLDS HEXADECIMAL OUTPUT CHARACTERS 
C 
C 
      REAL IVAL,IVAL1,IVAL2 
      DIMENSION JVAL(3) 
      DIMENSION NUMS(16)
      DIMENSION IBIN(128) 
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
      EQUIVALENCE (NUMS(1),IALPH(1))
      EQUIVALENCE (IBIN(1),IADDR(1,1))
      EQUIVALENCE (JVAL(1),JVAL1),(JVAL(2),JVAL2),(JVAL(3),JVAL3) 
C 
C     CHECK FOR LEGAL VALUE 
      IF(IVAL) 900,30,30
30    IF(IVAL-ZVAL) 40,40,900 
C     SET NUMBER BASE 
40    J1 = 256
      J2 = 3
      J3 = 16 
C     INITIALIZE ADDRESS ARRAY INDEX
      K=4 
      IF(INDX) 42,45,42 
42    IF(LOCT) 50,60,50 
45    K = 1 
      J1 = 2048 
      J2 = 12 
      J3 = 2
      GO TO 60
50    J1 = 512
      J2 = 4
      J3 = 8
      K = 1 
C     BREAK 36 BIT REAL NUMBER INTO THREE 12 BIT INTEGERS 
60    IVAL1 = IVAL/4096.
      JVAL1 = IVAL1/4096. 
      IVAL1 = JVAL1 
      IVAL1 = IVAL-IVAL1*4096.*4096.
      JVAL2 = IVAL1/4096. 
      IVAL2 = JVAL2 
      JVAL3 = IVAL1-IVAL2*4096. 
C     FILL ADDRESS ARRAY WITH HOLLERITH ADDRESS 
      DO 80 I=1,3 
      J4 = J1 
      DO 80 J=1,J2
      M1 = JVAL(I)/J4 
      JVAL(I) = JVAL(I)-M1*J4 
      J4 = J4/J3
      M1 = M1+1 
      IF(INDX) 75,70,75 
70    IBIN(K) = NUMS(M1)
      GO TO 78
75    IADDR(INDX,K) = NUMS(M1)
78    K = K+1 
80    CONTINUE
C     SUPPRESS LEADING ZEROS IF LISTING IS IN HEX 
      IF(INDX) 805,990,805
805   IF(LOCT) 990,810,990
810   I = 11-(IFBIT-1)/4
      DO 840 J=1,I
      IADDR(INDX,J) = IBLNK 
840   CONTINUE
      GO TO 990 
C     SET ADDRESS TO ASTERISKS
900   DO 910 J=1,12 
      IADDR(INDX,J) = IAST
910   CONTINUE
990   RETURN
      END 
      SUBROUTINE MCCAL
C 
C 
C     THIS ROUTINE PROCESSES THE MACRO CALL LINE.  ACTUAL 
C     MACRO PARAMETERS ARE SCANNED AND PLACED IN THE
C     PARAMETER TABLE.
C 
C 
C     ENTRY PARAMETERS
C        MAC  - MACRO FLAG
C           0 = PROCESSING MACRO CALL LINE
C           1 = NOT PROCESSING A MACRO
C           2 = PROCESSING A MACRO
C     EXIT PARAMETERS 
C 
C        IERR - ERROR FLAG
C           1 = NO ERROR
C           2 = NESTING ERROR 
C 
C 
      REAL ITAB1
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
      EQUIVALENCE (ITABV(1),ITAB1),(IQUES,IALPH(37))
C 
      IERR = 1
      LEN = 0 
      IF(MAC .LE. 1) GO TO 4020 
      IF(NEST .GT. 0) GO TO 9100
C     NESTED MACRO CALLS - SAVE CURRENT PARAMETERS
      IF(MCEPT .GE. (MXREF-4)) GO TO 9100 
      MCEPT = MCEPT+1 
      IXTAB(MCEPT) = MCREC
      MCEPT = MCEPT+1 
      IXTAB(MCEPT) = MCSPT
      MCEPT = MCEPT+1 
      IXTAB(MCEPT) = ITAB1
      MCEPT = MCEPT+1 
      IXTAB(MCEPT) = 16*IFLEV+IFCTL 
      MCSPT = MCEPT+1 
      MAC = MAC+1 
C     GET PARAMETER COUNT AND SET UP TABLE IF ANY PARAMETERS
4020  MCEPT = MCSPT-1 
      IFLEV = IFSET 
      MAC = MAC-1 
      I = ITABS(INDEX)/16 
      IPCNT = I/40
      NOPAR = I-IPCNT*40
      MM = NOPAR
      NARG = 0
      NEST = 1
      MCREC = ITABV(INDEX)/1024.
      IF(NOPAR) 4400,4400,4100
C     SET UP PARAMETER TABLE
4100  ISTA = ICOL 
      IF(ISTA-MCOL) 4120,4300,4300
4120  MCEPT = MCEPT+1 
      IXTAB(MCEPT) = 0
      CALL MSCAN(NOPAR,2) 
      ICOL1 = ICOL-1
      IF(IN(ISTA)-ILESS) 4150,4130,4150 
4130  IF(IN(ICOL1)-IGRAT) 4150,4140,4150
4140  ISTA = ISTA+1 
      ICOL1 = ICOL1-1 
4150  ID = ICOL1-ISTA 
      IF(ID) 4230,4200,4200 
4200  IF(MCEPT+ID-(MXREF-5)) 4210,4210,4510 
4210  DO 4220 I=ISTA,ICOL1
      MCEPT = MCEPT+1 
      IXTAB(MCEPT) = IN(I)
4220  CONTINUE
      NARG = NARG+1 
C     CHECK FOR ADDITIONAL PARAMETERS 
4230  MM = MM-1 
      IF(MM) 4400,4400,4240 
4240  IF(ICHAR-ICOMM) 4310,4250,4310
4250  ICOL = ICOL+1 
      IF(MCEPT-(MXREF-3)) 4100,4510,4510
C     CHECK IF ANY NULL PARAMETERS
4300  IF(MM) 4400,4400,4310 
4310  IF(IPCNT) 4500,4500,4320
4320  IF(MCEPT-(MXREF-3)) 4330,4510,4510
4330  DO 4340 I=1,MM
      MCEPT = MCEPT+1 
      IXTAB(MCEPT) = 0
4340  CONTINUE
C     CHECK IF ANY LOCAL SYMBOLS DEFINED
4400  IF(IPCNT) 4500,4500,4410
4410  MCEPT = MCEPT+1 
      IXTAB(MCEPT) = -2 
4415  IF(MCEPT-(MXREF-8)) 4420,4510,4510
4420  MCEPT = MCEPT+1 
      IXTAB(MCEPT) = 0
      MCEPT = MCEPT+1 
      IXTAB(MCEPT) = IQUES
      MCEPT = MCEPT+1 
      IXTAB(MCEPT) = IQUES
      ID = 1000 
      L = LEVEL 
      LEVEL = LEVEL+1 
      DO 4430 LL=1,4
      N = 1+L/ID
      MCEPT = MCEPT+1 
      IXTAB(MCEPT) = IALPH(N) 
      L = L-(N-1)*ID
      ID = ID/10
4430  CONTINUE
      IPCNT = IPCNT-1 
      IF(IPCNT) 4500,4500,4415
C     PUT IN LIST TERMINATOR
4500  NEST = 0
4510  MCEPT = MCEPT+1 
      ITAB1 = NARG
      IXTAB(MCEPT) = -1 
      IF(NEST .LE. 0) GO TO 9900
C 
C     SET ERROR FLAG
C 
C     MACRO NESTING ERROR 
9100  IERR = 2
9900  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 
C     ENTRY PARAMETERS
C        MCNT  - MACRO NUMBER 
C        MSREC - NEXT POSITION IN MACRO FILE
C     EXIT PARAMETERS 
C        IEND  - SET TO ONE WHEN AN END DIRECTIVE IS FOUND
C        MDISK - STARTING RECORD NUMBER OF MACRO
C        MSREC - NEXT FREE POSITION IN MACRO FILE 
C        MPARC - MACRO PARAMETER COUNT
C 
C 
      DIMENSION MCPAR(512)
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
      EQUIVALENCE (MCPAR(1),IXTAB(1)) 
      EQUIVALENCE (ICHRA,IALPH(11)),(ICHRT,IALPH(30)) 
C 
      IEND = 0
      ICHK = 0
      IPCNT = 0 
      IPCN1 = 0 
      NCNT = 0
      LOC = 0 
C     SCAN PROTOTYPE LINE FOR PARAMETERS AND FORM PARAMETER TABLE 
      IF(ICOL .GT. MCOL) GO TO 140
100   CALL SYMBL
      IF(IERR .GE. 2) GO TO 130 
C     FOUND VALID PARAMETER, ENTER INTO TABLE 
      IF(NCNT-(MXREF-10)) 110,110,125 
110   IPCNT = IPCNT+1 
      DO 120 LL=1,IWORD 
      NCNT = NCNT+1 
      MCPAR(NCNT) = NAME(LL)
120   CONTINUE
      ICOL1 = ICOL
      ICOL = ICOL+1 
      IF(IN(ICOL1) .EQ. ICOMM) GO TO 100
      GO TO 140 
C     TOO MANY PARAMETERS 
125   IERRL = 55
      GO TO 140 
C     ILLEGAL PARAMETER LIST
130   IERRI = 2 
140   IF(IPCN1) 560,150,560 
150   IPCN1 = IPCNT+1 
      GO TO 560 
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) 
C     INCREMENT LINE NUMBER 
      LISN = LISN+1 
      ITYPE = -1
      IERRI = 0 
      IERRL = 0 
      DO 210 LL=1,80
      IN(LL) = INB(LL)
210   CONTINUE
C     CHECK FOR A COMMENT LINE
      ICOL = IFCOL
      IF(IN(ICOL) .EQ. ISEMI) GO TO 500 
      IF(IPCNT .EQ. 0) GO TO 400
      CALL MSCAN(IPCNT,1) 
C     GET OPCODE FIELD
      ICOL = IFCOL
400   CALL OPCOD
C     IF A LABEL WAS FOUND, CALL OPCODE AGAIN TO GET DIRECTIVE
      IF(IERR .NE. 2) GO TO 475 
      ICOL = ICOL+1 
      CALL OPCOD
C     CHECK FOR LOCAL DIRECTIVE 
475   IF(ICHK .NE. 1023) GO TO 500
      IF(LOC .NE. 0) GO TO 500
      DO 495 LL=1,80
      IN(LL) = INB(LL)
495   CONTINUE
      GO TO 100 
C 
C     THE FOLLOWING STATEMENT WRITES INTO THE MACRO SOURCE FILE 
C 
500   MCREC = MSREC 
      MSREC = MSREC+1 
      LOC = 1 
      CALL INOUT(10)
C     WRITE STATEMENT TO INTERMEDIATE FILE FOR USE BY PASS 2
C     SET LINE SO THAT IT LOOKS LIKE A COMMENT FOR PRINTOUT 
560   LEN = 0 
      IMREC = ISN 
      ISN = ISN+1 
C 
C     THE INTERMEDIATE FILE IS WRITTEN INTO BY THE FOLLOWING STATEMENT
C 
      CALL INOUT(7) 
C     CHECK FOR ENDM OR END INSTRUCTIONS
      NOPRO = 1 
      IF(ICHK .EQ. 1024) GO TO 590
      IF(ICHK .NE. 1011) GO TO 200
      IEND = 1
      NOPRO = 0 
590   IPCN1 = IPCN1-1 
      IPCNT = IPCNT-IPCN1 
      ITABS(INDET) = 16*(40*IPCNT+IPCN1)+6
      INDET = 0 
      RETURN
      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 
C     ENTRY PARAMETERS
C        MCREC - RECORD NUMBER OF MACRO SOURCE
C     EXIT PARAMETERS 
C        MCREC - SET TO NEXT RECORD IN MACRO
C        INB   - LINE TO BE PROCESSED 
C        IERRI - SET EQUAL TO 2 IF LINE OVERFLOW
C 
C 
      DIMENSION MACIN(80) 
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
C 
      INPNT = 1 
      MCPNT = 1 
C 
C     THE FOLLOWING STATEMENT READS FROM THE MACRO SOURCE FILE. 
C 
      NREC = MCREC
      CALL INOUT(9) 
      MCREC = NREC+1
      DO 10 LL=1,80 
      MACIN(LL) = INB(LL) 
10    CONTINUE
C     PLACE ARGUMENTS FROM MACRO CALL INTO MODEL STATEMENTS AND 
C     INTO INPUT BUFFER TO BE USED BY PASS 1
20    IPARN = MACIN(MCPNT)
      ISAVE = IPARN 
      LL = MCSPT-1
      IF(IPARN-255) 25,140,140
25    IF(IPARN) 140,30,30 
30    IF(IPARN-40) 45,32,32 
C     LOOK FOR START OF GENERATED SYMBOLS 
32    LL = LL+1 
      IF(IXTAB(LL)+1) 34,130,34 
34    IF(IXTAB(LL)+2) 32,36,32
36    IPARN = IPARN-40
C     SCAN TO PARAMETER 
45    LL = LL+1 
      IF(IXTAB(LL)) 50,55,45
50    IF(IXTAB(LL)+1) 45,130,45 
55    IPARN = IPARN-1 
      IF(IPARN) 60,60,45
C     GET END OF PARAMETER
60    ISTA = LL 
      IFIN = ISTA 
65    IFIN = IFIN+1 
      IF(IXTAB(IFIN)) 70,75,65
70    IF(IXTAB(IFIN)+2) 65,75,75
75    ISTA = ISTA+1 
      IFIN = IFIN-1 
C     CHECK FOR NULL PARAMETER
      IF(ISTA-IFIN) 100,100,130 
100   IF((INPNT+IFIN-ISTA)-MCOL) 110,110,910
C     SUBSTITUTE ACTUAL PARAMETER FOR PARAMETER MARKERS 
110   DO 120 KK=ISTA,IFIN 
      INB(INPNT) = IXTAB(KK)
      INPNT = INPNT+1 
120   CONTINUE
C     SCAN OVER PARAMETER MARKER
130   MCPNT = MCPNT+1 
      IF(MACIN(MCPNT)-ISAVE) 20,130,20
140   INB(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 20
150   ISTA = INPNT+1
155   DO 160 INPNT=ISTA,80
      INB(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 = 16
      ISTA = INPNT
      GO TO 155 
      END 
      SUBROUTINE MSCAN(IPCNT,NSGO)
C 
C 
C     THIS SUBROUTINE IS USED TO SCAN MODEL STATEMENTS FOR MACRO
C     PARAMETERS AND TO FORM THE PARAMETERS PASSED IN A MACRO 
C     CALL INTO THE MODEL STATEMENTS, ALSO TO CALCULATE THE 
C     NUMBER OF BYTES NEEDED FOR ABS, DATA, AND BYT DIRECTIVES
C 
C 
C     ENTRY PARAMETERS
C        ICOL  - STARTING COLUMN OF SCAN
C        NSGO  - CONTROL PARAMETER
C             1 = SCAN MODEL STATEMENTS AND PUT PARAMETER MARKERS IN
C             2 = SCAN PARAMETER LIST OF MACRO REFERENCE
C        IPCNT - NUMBER OF PARAMETERS IN MACRO PROTOTYPE
C        MCPAR - LIST OF MACRO PARAMETERS IF NSGO=1 
C     EXIT PARAMETERS 
C        ICOL  - ENDING COLUMN OF SCAN
C        ICHAR - FINAL CHARACTER SCANNED
C 
C 
      DIMENSION IOPER(6),ISYX(16),MCPAR(512)
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
      EQUIVALENCE (IOPER(1),IPLUS)
      EQUIVALENCE (ISYX(1),IBLNK),(MCPAR(1),IXTAB(1)) 
C 
      LLEN = 1
      IF(IN(ICOL)-ILESS) 100,10,100 
10    IF(NSGO-2) 100,500,100
100   ICHAR = IN(ICOL)
      IERR = 1
C     CHECK FOR A TERMINATOR
      IF(ICHAR-IBLNK) 110,118,110 
110   IF(ICHAR-ICTAB) 112,118,112 
112   IF(ICHAR-ISEMI) 114,900,114 
114   IF(ICHAR-ICOMM) 160,120,160 
118   IF(NSGO-1) 140,140,900
120   IF(NSGO-2) 130,900,130
130   LLEN = LLEN+1 
140   ICOL = ICOL+1 
150   IF(ICOL-MCOL) 100,900,900 
C     CHECK FOR AN OPERATOR 
160   DO 170 K=1,6
      IF(ICHAR-IOPER(K)) 170,140,170
170   CONTINUE
      IF(ICHAR .EQ. IUNDR) GO TO 140
C     CHECK FOR NUMERICS
      DO 220 K=1,10 
      IF(IN(ICOL)-IALPH(K)) 220,230,220 
220   CONTINUE
C     CHECK FOR NUMERICS WITH DESCRIPTORS 
      DO 225 I=7,10 
      IF(IN(ICOL) .EQ. IATT(I)) GO TO 226 
225   CONTINUE
      GO TO 300 
226   ICOL1 = ICOL+1
      IF(IN(ICOL1) .NE. ISHRP) GO TO 300
      ICOL = ICOL+1 
230   ICOL = ICOL+1 
C     SCAN FOR NUMERIC TERMINATOR 
      DO 240 K=1,16 
      IF(ISYX(K) .EQ. IN(ICOL)) GO TO 100 
240   CONTINUE
      IF(IN(ICOL) .EQ. IQUOT) GO TO 100 
      IF(IN(ICOL) .EQ. IAMP) GO TO 100
      IF(IN(ICOL) .EQ. IUNDR) GO TO 100 
      IF(ICOL-MCOL) 230,900,900 
C     CHECK FOR AND FETCH SYMBOL
300   ISTA = ICOL 
      CALL SYMBL
      IF(IERR .EQ. 3) GO TO 140 
C     CHECK WHETHER PARAMETER MARKERS SHOULD BE PUT IN
      IF(NSGO-1) 150,350,150
C     CHECK IF THIS SYMBOL IS A PARAMETER PASSED IN PROTOTYPE 
350   DO 365 K=1,IPCNT
      LL = (K-1)*IWORD
      DO 360 J=1,IWORD
      LL = LL+1 
      IF(NAME(J)-MCPAR(LL)) 365,360,365 
360   CONTINUE
      GO TO 370 
365   CONTINUE
      GO TO 150 
C     REPLACE SYMBOL BY PARAMETER MARKER
370   IF(ISTA-1) 380,380,372
C     CHECK TO SEE IF QUOTE MARK INDICATING CONCATENATION EXISTS
372   ICOL1 = ISTA-1
      IF(IN(ICOL1)-IQUOT) 380,375,380 
375   ISTA = ICOL1
380   IF(ICHAR-IQUOT) 390,385,390 
385   ICOL = ICOL+1 
390   IFIN = ICOL-1 
      IMARK = K 
      DO 395 K=ISTA,IFIN
      IN(K) = IMARK 
395   CONTINUE
      GO TO 150 
C 
C     GET PARAMETER DELIMITED BY ANGLE BRACKETS 
500   ICOL = ICOL+1 
      IF(IN(ICOL)-ILESS) 520,510,520
510   LLEN = LLEN+1 
      GO TO 500 
C     SCAN FOR CLOSING BRACKET
520   IF(IN(ICOL)-IGRAT) 540,530,540
530   LLEN = LLEN-1 
      IF(LLEN) 540,140,540
540   ICOL = ICOL+1 
      IF(ICOL-MCOL) 520,520,900 
C 
900   RETURN
      END 
      SUBROUTINE MESS(MESSN)
C 
C 
C     THIS SUBROUTINE WRITES ALL PROGRAM ERROR MESSAGES 
C     TO THE LIST FILE
C 
C     ENTRY PARAMETERS
C        MESSN - MESSAGE NUMBER 
C        ECOL  - COLUMN ERROR WAS DETECTED IN FOR OPERAND ERROS 
C        JCOL  - COLUMN ERROR WAS DETECTED IN FOR LABEL ERRORS
C 
C 
      INTEGER FTYPE,FLEN,ECOL 
      REAL ITABV(500),LC,LODLC,LCMAX,MAPAD
      COMMON ICRD,IPRT,IPCH,MCFLE,IMFLE,IDFLE,MCREC,IMREC,IDREC 
      COMMON IOREC,MLAB,MOPC,IBIT,ICCNT,IWORD,IEND,LEND,KTERM,KPCH
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,LOBJ,LOBJ1,LOBJ2,LINV,LERR
      COMMON LMAC,LADR,LLOC,LMAC1,LMAP,LEVEL,IND(80),JMAC 
      COMMON ILEN,KLEN,LLEN,FLEN,KWORD,IFLD(500),IYFLD,IZFLD
      COMMON IDUP,NDUP,NFLAG,IOFLG,LWORD,LINEL,KFILE,IFORM,NERR 
      COMMON IFBIT,ZVAL,CVAL,JREAD,LINE,IPAGE,MERR
      COMMON IERRI,IERRL,ECOL,MAC,LISN,NARG,INDET,IFCTL,NOPRO,LEN 
      COMMON LTBLK,IN(80),IMBU1(11),INB(80),IALPH(37) 
      COMMON IAST,IDOLR,ISHRP,IAMP,ICOLN,IGRAT,ILESS,IUNDR,IQUOT
      COMMON IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(10),JATT(6),LATT(10),IFPAR(16)
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12) 
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG,IOVER 
      COMMON IPASS,LC,IOBIN(128),IPDEF,LODLC,LCMAX,LCMIN,NBASE,JBASE
      COMMON ITAB(4,500),ITABS(500),ITABV,NAME(4),INDEX,ISYM,LTAB 
      COMMON IXTAB(512),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128),MSIZE
      COMMON MCNT,MXMAC,NEST,MSREC,IFLEV
      COMMON MCSPT,MCEPT,ICHK,LABCT,ICHAR,IFSET,MAPAD,NENT,MWORD
C 
      IF(MESSN .GE. 50) GO TO 100 
C     BRANCH TO DISPLAY OPCODE OR OPERAND ERROR 
      GO TO (1100,1200,1300,1400,1500,1600,1700,1800,1900,2000, 
     1  2100,2200,2300,2400,2500,2600,2700,2800,2900,3000),MESSN
C     BRANCH TO DISPLAY LABEL ERROR 
100   MESSN = MESSN-50
      GO TO (5100,5200,5300,5400,5500),MESSN
C 
C     ILLEGAL DIRECTIVE 
1100  WRITE(IPRT,1110) ECOL 
1110  FORMAT(8X,21H***ILLEGAL DIRECTIVE ,1H(,I2,1H))
      GO TO 9900
1200  WRITE(IPRT,1210) ECOL 
1210  FORMAT(8X,18H***ARGUMENT ERROR ,1H(,I2,1H)) 
      GO TO 9900
1300  WRITE(IPRT,1310) ECOL 
1310  FORMAT(8X,16H***SYNTAX ERROR ,1H(,I2,1H)) 
      GO TO 9900
1400  WRITE(IPRT,1410) ECOL 
1410  FORMAT(8X,16H***FORMAT ERROR ,1H(,I2,1H)) 
      GO TO 9900
1500  WRITE(IPRT,1510) ECOL 
1510  FORMAT(8X,20H***UNDEFINED SYMBOL ,1H(,I2,1H)) 
      GO TO 9900
1600  WRITE(IPRT,1610) ECOL 
1610  FORMAT(8X,28H***ILLEGAL MICROWORD LENGTH ,1H(,I2,1H)) 
      GO TO 9900
1700  WRITE(IPRT,1710) ECOL 
1710  FORMAT(8X,24H***ILLEGAL FIELD LENGTH ,1H(,I2,1H)) 
      GO TO 9900
1800  WRITE(IPRT,1810) ECOL 
1810  FORMAT(8X,19H***ATTRIBUTE ERROR ,1H(,I2,1H))
      GO TO 9900
1900  WRITE(IPRT,1910) ECOL 
1910  FORMAT(8X,25H***FIELD LENGTH CONFLICT ,1H(,I2,1H))
      GO TO 9900
2000  WRITE(IPRT,2010) ECOL 
2010  FORMAT(8X,19H***VALUE TOO LARGE ,1H(,I2,1H))
      GO TO 9900
2100  WRITE(IPRT,2110) ECOL 
2110  FORMAT(8X,17H***ILLEGAL VALUE ,1H(,I2,1H))
      GO TO 9900
2200  WRITE(IPRT,2210) ECOL 
2210  FORMAT(8X,21H***ILLEGAL CHARACTER ,1H(,I2,1H))
      GO TO 9900
2300  WRITE(IPRT,2310)
2310  FORMAT(8X,17H***TABLE OVERFLOW) 
      GO TO 9900
2400  WRITE(IPRT,2410)
2410  FORMAT(28H***ILLEGAL CONTINUATION LINE) 
      GO TO 9900
2500  WRITE(IPRT,2510) ECOL 
2510  FORMAT(8X,22H***ILLEGAL FIELD TYPE ,1H(,I2,1H)) 
      GO TO 9900
2600  WRITE(IPRT,2610) ECOL 
2610  FORMAT(8X,31H***ADDRESS NOT ON CURRENT PAGE ,1H(,I2,1H))
      GO TO 9900
2700  WRITE(IPRT,2710) ECOL 
2710  FORMAT(8X,17H***OVERLAY ERROR ,1H(,I2,1H))
      GO TO 9900
2800  WRITE(IPRT,2810) ECOL 
2810  FORMAT(8X,20H***NO DEFAULT VALUE ,1H(,I2,1H)) 
      GO TO 9900
2900  WRITE(IPRT,2910)
2910  FORMAT(28H ***INVALID DEFINITION FIELD) 
      GO TO 9900
3000  WRITE(IPRT,3010)
3010  FORMAT(35H ***SYMBOL OR FIELD TABLE TOO SMALL)
      GO TO 9900
5100  WRITE(IPRT,5110) JCOL 
5110  FORMAT(8X,15H***LABEL ERROR ,1H(,I2,1H))
      GO TO 9900
5200  WRITE(IPRT,5210)
5210  FORMAT(8X,16H***MISSING LABEL)
      GO TO 9900
5300  WRITE(IPRT,5310)
5310  FORMAT(8X,18H***DUPLICATE LABEL)
      GO TO 9900
5400  WRITE(IPRT,5410)
5410  FORMAT(8X,24H***SYMBOL TABLE OVERFLOW)
      GO TO 9900
5500  WRITE(IPRT,5510)
5510  FORMAT(8X,23H***MACRO TABLE OVERFLOW) 
9900  RETURN
      END