*	     ***   A AP16XX TEST PROGRAM   ***
*	     ***   A AP16XX TEST PROGRAM   ***
*
*
       IDENT SAMPLE
       MAG		     SHOULD PRECEED FIRST OBJECT OUTPUT
       M30		     STOULD PRECEED FIRST INSTRUCTION, M30 IS DE
*	     THE NEXT STATEMENT IS A 'SPACE 10'
       SPACE 10
** CONTROL INSTRUCTIONS
START  HLT		     NO OPERAND FIELD FOR CONTROL INSTRUCTIONS
       NOP
** CONDITIONAL JUMP INSTRUCTIONS
CJ     JOV   *+2	     A ZERO DISPLACEMENT ADDRESSES NEXT INST
       JAZ   2		     A NEGATIVE DISPLACEMENT
       NAB CJ		     OPERAND FIELD STARTS AFTER MNEMONIC
       NAX   *+300	     THIS OPERAND ADDRESS IS OUT OF RANGE
       SSS   CJ+2	     ILLEGAL MNEMONIC OPERATION CODE
** SHIFT INSTRUCTIONS
ALPHA  LLA   5
       LLL   -5 	     NEGATIVE OPERANDS ARE NOT ALLOWED FOR SHIFT
       ALA   X'10'	     SHIFT COUNT MAY BE EXPRESSION
ALPHA  ARL   TEN+2	     SYMBOL IN NAME IS MULTI-DEFINED
       ALA   ** 	     ** INDICATES TO BE CHANGED DURING EXECUT.
** INPUT/OUTPUT
BETA   IBS		     NO OPERAND NEEDED FOR SERIAL I/O
       IBA   2,2	     DEVICE ORDER,DEVICE NUMBER
       OBM   4,4,BUF,X	     MEMORY I/O WITH INDEX FLAG - X
** REGISTER OPERATE
       XRA		     NO OPERAND FOR REGISTER INSTRUCTIONS
** NON LITERAL MEMORY REFERENCING INSTRUCTIONS
123456 LDA   *		     MODE 0  SYMBOL IN NAME IS NOT LEGAL
       ORG   256	     ORG ASSEMBLER INSTRUCTION
.DOT   STA   *+2	     MODE 1
       LDX*  OOPS	     MODE 2   SYMBOL IN OPERAND IS UNDEFINED
       LDX*  BUF+5	     MODE 3
A23456 STX-		     MODE 4  NO OPERAND FIELD FOR THIS MODE
       ADV+  30 	     MODE 5
       MUL/  SAM,X	     MODE 6  WITH ADDRESS FLAG
       LDV/  SAM	     MODE 6  NO INDEX FLAG
** FIXED WORD LENGTH LITERAL MODE INSTRUCTIONS	(MODE 7)
       LDA=  H'-1'	     TWO BYTE LITERAL WITH FIRST BYTE ZERO
SPOT   STA=  ** 	     A REG. STORED IN SPOT+1
       MUL=  E'100'	     E AND D TYPES ARE NOT LEGAL IN FIXED WORD
       LDA=  A'ALPHA'	     ADDRESS TYPE WITH NO INDEX FLAG
       LDA=  A'ALPHA,X'      ADDRESS TYPE WITH INDEX FLAG - X
       LDX=  ALPHA	     ADDRESS TYPE LITERAL WITHOUT A'
       CPA=  C'A'	     TWO BYTE LITERAL WITH FIRST BYTE ZEROS
       ANA=  X'FF'	     TWO BYTE LITERAL WITH HEX RIGHT JUSTIFIED
** VARIABLE WORD LENGTH LITERALS (MODE 7)
       LDV=	 SAM	     TWO BYTE ADDRESS LITERAL
       ADV=  D'1023'	     FOUR BYTE INTEGER
       ANV=  X'9ABCDEF'      FOUR BYTE, LENGTH DETERMINED BY COUNT
       CPV=  C'A'	     SINGLE BYTE LITERAL, LENGTH DET. BY COUNT
** ASSEMBLER INSTRUCTIONS
TEN    EQU   8		     SYMBOL IS EQUATED TO 8
TEN    SET   10 	     SET DOES NOT ALLOW MULTI-DEFINED ERROR
       DC    A'TEN+2-1,X'    ADDRESS CONSTANT
       DC    TEN+2-1,X	     ADDRESS CONSTANT
SAM    DC    C'THIS IS A DC'
BUF    DS    4		     FOUR BYTES ARE RESERVED
       DC    ** 	     WORD TO BE CHANGED DURING EXECUTION
** JUMP AND RETURN JUMP INSTRUCTIONS
       JMP/  ALPHA	     MODE 6  TWO BYTE EXTENDED ADDRESS
       JMP=  ALPHA,X	     MODE 7  TWO BYTE INDIRECT EXTENDED ADDRESS
*  820 INSTRUCTION TEST
       LDB   *		     LOAD B REGISTER
       STB*  *+2	     STORE B REGISTER
       RTN		     RETURN
       CAL   1024,X	     CALL
       PLX		     PULL X
       PSX		     PUSH X
       PLA		     PULL A
       PSA		     PUSH A
       PLB		     PULL B
       PSB		     PUSH B
MST    MST   F'512'	     MULTIPLY STEP
       ADX   0-3	     ADD TO X
       JEP   MST	     JUMP EVEN PARITY
       EBX		     EXCHANGE B AND
       MOV		     MOVE
       GCC		     GENERATE CYCLIC CODE
       SCH		     SEARCH
       GAP		     GENERATE ASCII PARITY
*
*			     BIT 32 TEST
       DC    C'ABCDEFGHIJKL'
       LDV=  C'ABCD'
       LDV=  X'FFFFFFFF'
       LDV=  X'80000000'
*			     ORG TEST
       ORG   X'1000'
       NOP
       NOP
       NOP
       ORG   X'2000'
       NOP
       NOP
       ORG   X'3000'
       NOP
*
*	     END OPERAND USES:	0 = RETURN TO LOADER
*			    NOT 0 = EXECUTE ADDRESS
*			NONE, EOF = NO LOAD RACORD
       END   0
*	     A STACKED PROGRAM
       NOP
       END   0
C	      AP16XX CROSS ASSEMBLER	  5 OCT 73     VERSION 3.0
C
C	 P/N  11130
C
C     NOTE:  TO CHANGE TABLE SIZES ALTER --
C
C	ITEM		    VALUE OF -		DIMENSION OF -
C
C	SYMBOL TABLE	    STTOP		ST, STVAL, ROOTS
C	CROSS REFERENCE     REFTOP		REFS
C
      COMMON  A(80),IA,ERRTAB(4),IE,B(14),PC,KA,ST(999),STVAL(999),STMAX
      COMMON  LINE, ECOUNT, ELIST(100)
      COMMON  REFMAX, REFTOP, ROOTS(999), REFS(1111)
      INTEGER REFMAX, REFTOP, ROOTS,	  REFS
      INTEGER  A,ERRTAB,IE,ST,STVAL,STMAX,PC, B, ECOUNT,ELIST
      INTEGER CSET(64),CARD(20),OPCODE(95), ASCII(64)
      DIMENSION MNEM(95)
C * MNEM CONTAINS A CODED VALUE OF ALL MNEMONICS.  OPCODE IS A CORRES-
C	 PONDING ARRAY OF VALUES.  PSEUDO OPS HAVE NEG VALUES.
C	 N*1000 IS ADDED TO INST VALUE, WHERE N IS NUMBER OF BYTES.GT. 1
C	 IN INSTRUCTION
C
C		   COMMON MNEMONICS
C
      DATA MNEM / 39496,23470,45389,29334,23333,45810,23174,
     1			      21325,21965,
     X	      35240,35241,35280,35281,35320,35616,
     2		       28069,47505,23552,      21543,23143,
     3		       44161,44162,44163,44164,45761,45762,45763,45764,
     4		       31391,30835,30875,31755,30823,31743,30811,30833,
     5		       37791,37235,37275,38155,37223,38143,37211,37233,
     6		       34450,34451,34461,34690,34691,34701,
     7		       16850,16851,16861,17090,17091,17101,
     8			     29250,29251,29262,37785,
     9			     38850,38851,38862,
     A		       39490,53890,39491,53891,29753,21313,17313,46113,
     B		       29730,29731,38890,38891,46833,46873,47730,47731,
     C		       31305,44379,30102,22102,34153,45993,
     D		       16530,16551,45250,45271, 	   16930,16951,
     E		       34130,34151,45970,45991/
C
      DATA OPCODE / -2,-3,-4,-5,-6,-7,-8,-9,-10,-11,-12,-13,-14,-15,-16,
     2		       0,1,2,  4,5,    8,9,10,11,12,13,14,15,
     4		       1016,1017,1018,1019,1020,1021,1022,1023,
     5		       1024,1025,1026,1027,1028,1029,1030,1031,
     6		       1032,1033,1034,1036,1037,1038,
     7		       1040,1041,1042,1044,1045,1046,
     8			    1049,1050,3051,52,	   1057,1058,3059,
     A		       64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,
     C		       96,104,112,120,128,136,		160,168,176,184,
     E			       208,216,224,232,240,248/
C
C		   MODEL DEPENDENT MNEMONICS
C
C    COLUMN USE:  1=10 2=11 3=13 4=20 5=21 6=30 7=OP
C
      INTEGER  XMNEM(7,34), DUMMY1(7,17), DUMMY2(7,17)
      EQUIVALENCE  (XMNEM(1,1), DUMMY1(1,1)),
     1		   (XMNEM(1,18),DUMMY2(1,1))
      DATA     DUMMY1 /
     1		   40905, 0,	 0,	0,     0,     40945, 3,
     2		   21909, 0,	 21909, 21909, 21909, 21909, 6,
     3		   23509, 0,	 23509, 23509, 23509, 23509, 7,
     4		   0,	  0,	 0,	0,     0,     47348, 2035,
     5		   0,	  0,	 0,	0,     0,     26018, 1039,
     6		   29268, 29268, 29268, 0,     0,     44393, 1048,
     7		   0,	  0,	 16553, 0,     20052, 20052, 53,
     8		   0,	  0,	 22873, 0,     0,     0,     54,
     9		   0,	  0,	 46105, 0,     0,     0,     55,
     A		   38868, 38868, 38868, 0,     0,     0,     1056,
     B		   0,	  0,	 31583, 0,     21213, 21213, 60,
     C		   0,	  0,	 31595, 0,     21931, 21931, 61,
     D		   0,	  0,	 29787, 0,     36421, 36421, 2062,
     E		   0,	  0,	 53787, 0,     21551, 21551, 2063,
     F		   0,	  0,	 34131, 44383, 44383, 44383, 80,
     G		   0,	  0,	 0,	19621, 19621, 19621, 2081,
     H		   0,	  0,	 0,	40873, 40873, 40873, 82/
      DATA     DUMMY2 /
     I		   0,	  0,	 0,	41153, 41153, 41153, 83,
     J		   0,	  0,	 0,	40850, 40850, 40850, 84,
     K		   0,	  0,	 0,	41130, 41130, 41130, 85,
     L		   0,	  0,	 0,	40851, 40851, 40851, 86,
     M		   0,	  0,	 0,	41131, 41131, 41131, 87,
     N		   0,	  0,	 45971, 36349, 36349, 36349, 2088,
     O		   0,	  0,	 0,	16553, 16553, 16553, 2089,
     P		   0,	  0,	 0,	30985, 30985, 30985, 1090,
     Q		   0,	  0,	 0,	22873, 22873, 22873, 91,
     R		   0,	  0,	 0,	36191, 36191, 36191, 92,
     S		   0,	  0,	 0,	26092, 26092, 26092, 93,
     T		   0,	  0,	 0,	45297, 45297, 45297, 94,
     U		   0,	  0,	 0,	26025, 26025, 26025, 95,
     V		   36421, 0,	 36421, 34131, 34131, 34131, 144,
     W		   21551, 0,	 21551, 45971, 45971, 45971, 152,
     X		   20210, 0,	 20210, 20210, 20210, 20210, 192,
     Y		   20231, 0,	 20231, 20231, 20231, 20231, 200/
C
C * CSET IS A CODE SET USED BY THIS PROGRAM.  THE TRANSLATION IS MADE
C     BY THE UNPACK PROGRAM.  THE 64 CODES ARE ORDER BY THEIR BCD OR
C     DISPLAY CODES
C
      DATA CSET/ 45,10,11,12,13,14,15,16,17,18,48,36,57,
     1			     41,37,55,56,19,20,21,22,23,24,25,26,27,
     2			     47,43,39,42,59,62,38,40,28,29,30,31,32,
     3			     33,34,35,63,46,54,49,58,60,0,1,2,3,4,
     4			     5,6,7,8,9,50,53,61,51,44,52/
C
      DATA ASCII / 176,177,178,179,180,181,182,183,184,185,
     1			      193,194,195,196,197,198,199,200,201,202,
     2			      203,204,205,206,207,208,209,210,211,212,
     3			      213,214,215,216,217,218,
     4			      174,171,173,170,175,168,169,164,189,160,
     5			      172,161,219,223,186,167,162,163,165,
     6			      222,166,188,190,187,191,192,220,255/
      DATA KBLNK /1H  /   , MEOF /0/,  KBLNK4 /4H    /
      INTEGER STTOP
C
      STTOP  = 999
      REFTOP = 1111
C
   50 STMAX = 0
      PC = 0
      IDENT = 0
      KLINE = 57
      KPAGE = 1
      REWIND 10
      REFMAX = 1
      DO 98 K=1,REFTOP
   98	   REFS(K)  = 0
      DO 99 K=1,STTOP
   99	   ROOTS(K) = 0
C		   DEFAULT MACHIN = 6 = 30
      MACHIN = 6
      ECOUNT = 0
C		   DEFAULT OBJECT MEDIA = 0 = CARDS,  NOT 0 = MAG TAPE
      MFLAG = 0
      LINE = 0
      IF (MEOF .NE. 0)	STOP
C
C  START OF PASS ONE
C
C  READ NEXT CARD
  100 CALL ERROR (-1)
      LINE = LINE + 1
      READ(1,102,END=105) (CARD(J),J=1,20)
  102 FORMAT (20A4)
  103 CALL UNPACK (A,CARD,CSET)
      KST = - 1
      INST = 0
      KPC = 0
      KSTOP = 0
      KTYPE = 0
      GO TO 106
  105 IF (IDENT .EQ. 0)  STOP
      MEOF = 1
      GO TO 260
C
C TEST FOR COMMENT CARD, TEST FOR SYMBOL
  106 IF (A(1) .EQ. 39) GO TO 120
      IF (A(1) .EQ. 45) GO TO 200
C GET SYMBOL AND PUT IN SYMBOL TABLE
      IF (A(1) .LT. 10) GO TO 118
      IF (A(1) .GT. 36) GO TO 118
      IA = 1
      CALL SYMBOL (KS)
      IF (A(IA) .NE. 45)  GO TO 118
      IF (STMAX .EQ. 0) GO TO 112
      DO 110 I=1,STMAX
      IF (KS .EQ. ST(I)) GO TO 114
  110 CONTINUE
  112 STMAX = STMAX + 1
      IF (STMAX .GT. STTOP) GO TO 130
      KST = STMAX
      ST(STMAX) = KS
      STVAL(STMAX) = PC
      CALL DEF(STMAX)
      GO TO 200
C SYMBOL ALREADY IN TABLE - THEREFORE DOUBLY DEFINED
  114 CALL ERROR (4)
      KST = I
      GO TO 200
  118 CALL ERROR (2)
      GO TO 200
C
C COMMENT CARD
  120 KTYPE =-1
      GO TO 250
  130 PRINT 131
  131 FORMAT (18H SYMBOL TABLE FULL   )
      IDENT = 0
      GO TO 50
C
C DETERMINE INSTRUCTION
C
  200 KOP = 1600*A(8) + 40 * A(9) + A(10)
  205 KSTAR = A(11)
      KPC = 1
C
C   SEARCH MNEMONIC TABLE
      DO 210 I=1,95
      IF (KOP .EQ. MNEM(I)) GO TO 215
  210 CONTINUE
C		   SEARCH MODEL DEPENDENT TABLE
      DO 201  I=1,34
	 IF  (KOP .EQ. XMNEM(MACHIN,I))  GO TO 202
  201 CONTINUE
C			ABSENT
      GO TO 211
C			PRESENT
  202 INST = XMNEM(7,I)
      GO TO 2215
  211 CALL ERROR (5)
      KPC = 2
      GO TO 250
  215 INST = OPCODE(I)
 2215 CONTINUE
C
C FIND BEGINNING OF OPERAND FIELD
      DO 216 IA=11,20
      IF (A(IA) .EQ. 45)  GO TO 217
  216 CONTINUE
      IA = 14
  217 IS = IA
      DO 218 IA=IS,40
      IF (A(IA) .NE. 45)  GO TO 219
  218 CONTINUE
      IA = 14
  219 IA14 = IA
      IF (INST .GE. 0) GO TO 220
C
C INSTRUCTION IS PSEUDO OP - BRANCH ACCORDINGLY
      KTYPE = INST
      K = - INST
      KPC = 0
      INST = 0
      GO TO (250,300,305,320,330,310,250,250,340,350,360,370,380,
     1		     390,400,410), K
C
C PROCESS MACHIN INST.
C
  220 KPC =  INST/1000 + 1
      INST = INST - (KPC-1)*1000
      K = INST/16
      KTYPE = 0
C		   CHECK FOR	  RTX
      IF (MACHIN .NE. 6) GO TO 228
      IF (INST .EQ. 48) KPC=3
  228 CONTINUE
C			CHECK FOR MST, ADX
      IF (INST .EQ. 88)  GO TO 23
      IF (INST .EQ. 89)  GO TO 23
C			CHECK FOR GAI
      IF (INST .EQ. 39) GO TO 23
C ADDRESS MODE PROCESSING FOR 810
      IF (K .LT. 6) GO TO 250
      KPC = 2
      IF (KSTAR .EQ. 45) GO TO 250
      IF (KSTAR .EQ. 38) GO TO 230
      IF (KSTAR .EQ. 37) GO TO 232
      IF (KSTAR .EQ. 40) GO TO 234
      IF (KSTAR .EQ. 44) GO TO 236
      IF (KSTAR .EQ. 39) GO TO 225
      GO TO 211
C  MODES 2-3
  225 INST = INST + 2
      GO TO 250
C  MODE 4
  230 KPC = 1
      INST = INST + 4
      GO TO 250
C  MODE 5
  232 INST = INST + 5
      GO TO 250
C  MODE 6
  234 KPC = 3
      INST = INST + 6
      GO TO 250
C  MODE 7
  236 INST = INST + 7
      KPC = 3
      IF (K .EQ. 6) GO TO 250
  23  KPC = 1
C			LITERAL LENGTH NOT CHECKED FOR GAI
      IF (INST .EQ. 39) GO TO 24
      KNV = - 1
      IF (K .LT. 10)  GO TO 237
      IF (MSK(INST,16) .EQ. 7)	GO TO 237
  24  KNV = 0
C
C DETERMINE TYPE AND LENGTH OF LITERALS
C
  237 K = A(IA)
      IF (A(IA+1) .EQ. 51)  GO TO 238
C  A TYPE WITHOUT A'
      KTYPE = KTYPE + 8
      KPC = KPC + 2
      GO TO 250
  238 IF (K .EQ. 17)  GO TO 240
      IF (K .EQ. 15)  GO TO 241
      IF (K .EQ. 14)  GO TO 242
      IF (K .EQ. 13)  GO TO 243
      IF (K .EQ. 10)  GO TO 244
      IF (K .EQ. 33)  GO TO 245
      IF (K .EQ. 12)  GO TO 248
  239 CALL ERROR (6)
      KTYPE = 0
      KPC = KPC + 2
      GO TO 250
C  H TYPE
  240 KTYPE = KTYPE + 1
      KPC = KPC + 1
      IF (KNV .LT. 0)  KPC = 3
      GO TO 250
C  F TYPE
  241 KTYPE = KTYPE + 2
      KPC = KPC +2
      GO TO 250
C  E TYPE
  242 KTYPE = KTYPE + 3
      IF (KNV .LT. 0)  GO TO 272
      KPC = KPC + 3
      GO TO 250
C  D TYPE
  243 KTYPE = KTYPE + 4
      IF (KNV .LT. 0)  GO TO 272
      KPC = KPC + 4
      GO TO 250
C  A TYPE
  244 KTYPE = KTYPE + 5
      KPC = KPC + 2
      GO TO 250
C  X TYPE
  245 KTYPE = KTYPE + 6
      IA = IA + 2
      L = IA + 8
      DO 246 I=IA,L
      IF (A(I) .EQ. 51)  GO TO 247
  246 CONTINUE
      GO TO 239
  247 KPC = KPC + (I-IA+1)/2
      GO TO 270
C  C TYPE
  248 KTYPE = KTYPE + 7
      IA = IA + 2
      DO 249 I=IA,72
      IF (A(I) .EQ. 51)  GO TO 270
  249 KPC = KPC + 1
      KPC = 3
      GO TO 239
C
C WRITE TAPE
C
  250 WRITE (10) (CARD(J),J=1,20),INST,PC,KPC,(ERRTAB(J),J=1,4),IE,
     1		  KTYPE,IA14,KST
      IDENT = 1
      PC = PC + KPC
      IF (KSTOP .EQ. 0) GO TO 100
  260 END FILE 10
      REWIND 10
      IF (MFLAG .EQ. 0)  PUNCH 265
  265 FORMAT (80X)
      PRINT 726, KPAGE
      KPAGE = KPAGE + 1
      KSTOP = 0
      LINE = 0
      MACHIN = 6
      GO TO 500
C
C CHECK THAT FIXED WORD LENGTH LITERALS ARE TWO BYTES
C
  270 IF (KNV .EQ. 0)  GO TO 250
      IF (KPC .GT. 3)  GO TO 272
      KPC = 3
      GO TO 250
  272 CALL ERROR (6)
      KTYPE = 0
      KPC = 3
      GO TO  250
C
C PROCESS PSEUDO OPS
C
C  ORG - SET PC TO VALUE OF OPERAND IF IN RANGE
  300 CALL EVAL (32767,0)
      PC = KA
      IF (KST .EQ. STMAX)  GO TO 307
      INST = 0
      GO TO 250
C
C  EQU - SET LAST SYMBOL,IF ANY, TO VALUE IN OPERAND FIELD
  305 CALL EVAL (65535,0)
      IF (KST .LE. 0)  GO TO 250
      IF (STVAL(STMAX) .EQ. PC) GO TO 307
      CALL ERROR (2)
      GO TO 250
  307 STVAL(KST) = KA
      INST = KA
      GO TO 250
C
C  END
  310 KSTOP = 1
      GO TO 250
C
C  SET
  320 IF (KST .LT. 0)  GO TO 250
      IF (ERRTAB(4) .NE. KBLNK)  ECOUNT = ECOUNT -1
      CALL ERROR (-1)
      CALL EVAL (65535,-65536)
      GO TO 307
C
C	 IDENT - VESTIGIAL, FUNCTIONS AS COMMENT
  330 IF (IDENT .NE. 0) GO TO 250
      IDENT = 1
      GO TO 250
C
C  DC TYPE
  340 KTYPE = 10
      KNV = 0
      GO TO 237
C
C  DS TYPE
  350 CALL EVAL (32767,0)
      KPC = KA
      GO TO 250
C			M10
  360 MACHIN = 1
      GO TO 250
C			M11
  370 MACHIN = 2
      GO TO 250
C			M20
  380 MACHIN = 4
      GO TO 250
C			M21
  390 MACHIN = 5
      GO TO 250
C			M30
  400 MACHIN = 6
      GO TO 250
C			MAG, SET FLAG
  410 MFLAG = 1
      GO TO 250
C
C
C START OF PASS TWO	******************************************
C
  500 DO 501 I =1,14
  501 B(I) = KBLNK
      LINE  = LINE + 1
C  READ CARD AND DETERMINE TYPE INST. -  KTYPE NEG FOR PSEUDO OPS,
C	   ZERO FOR NON LITERAL INST, AND POS IF A LITERAL CODE
      READ (10,END=711) (CARD(J),J=1,20),INST,PC,KPC,(ERRTAB(J),J=1,4),
     1	     IE,  KTYPE,IA,KST
      CALL UNPACK  (A,CARD,CSET)
      IF (KTYPE .GE. 10)  GO TO 730
      IF (KTYPE .GE. 0) GO TO 509
      K = -KTYPE
      GO TO (800,703,700,705,710,715,720,725,800,730,
     1		  741,742,743,744,745,800), K
C
C PROCESS MACHIN INST.
C
  509 CALL HEX (PC,2,1)
      KPC = KPC - 1
      IF (INST/16 .LT. 6)  GO TO 650
      M = MSK(INST,8) + 1
      GO TO (510,510,510,510,770,540,550,560),M
C
C PROCESS ADDRESS MODES
C  .PAGE ZERO AND RELATIVE MODES
  510 CALL EVAL (32767,0)
      IF (A(IA) .NE. 45)  GO TO 517
      IF (KA .LT. 256) GO TO 780
      INST = INST + 1
  513 KA = KA - PC - 2
      IF (KA .GT. 127) GO TO 515
      IF (KA .LT. (-128))  GO TO 515
      GO TO 780
  515 CALL ERROR (7)
  516 KA = 0
      GO TO 780
  517 CALL ERROR (6)
      GO TO 516
C  INDEX WITH BIAS
  540 CALL EVAL (255,0)
      GO TO 780
C  EXTENDED ADDRESS MODE
  550 CALL EVAL (65535,0)
      IF (A(IA) .NE. 46)  GO TO 780
      IF (A(IA+1) .EQ. 33)  KA = MSK(KA,32768) + 32768
      GO TO 780
C  LITERAL MODE
  560 IF (INST/16 .EQ. 6)  GO TO 550
  564 K = KTYPE
      IF (KTYPE .EQ. 0) GO TO 516
      IF (KTYPE .GE. 10) K = KTYPE - 10
      KA = 0
      IF (K .EQ. 0) GO TO 780
      IA = IA + 2
  565 GO TO (570,580,590,600,610,620,630,640),K
C
C  H TYPE
  570 CALL EVAL (127,-128)
      KA = MSK(KA,256)
      GO TO 780
C
C  F TYPE
  580 CALL EVAL (32767,-32768)
      GO TO 780
C
C  E TYPE
  590 CALL EVAL (8388607,-8388608)
      GO TO 780
C
C  D TYPE
  600 CALL EVAL (2147483647, 2**31)
      GO TO 780
C
C  A TYPE
  610  GO TO 550
C
C  X TYPE
  620 IA = IA - 2
      GO TO (571,621,591,600),KPC
  621 CALL EVAL (65535,0)
      GO TO 780
C
  571 CALL EVAL (255,0)
      KA = MSK(KA,256)
      GO TO 780
C
  591 CALL EVAL(16777216,0)
      GO TO 780
C
C  C TYPE
  630 IF (KTYPE .EQ. 17)  GO TO 632
      CALL HEX (INST,1,5)
      CALL PUNCH (INST,1,PC,MFLAG)
      PC = PC + 1
      IF (A(IA+1) .NE. 51)  GO TO 632
      J = A(IA)
      KA = ASCII(J+1)
      GO TO 790
  632 L = KPC - 1 + IA
      DO 635 I=IA,L
      J = A(I)
      IF (J .EQ. 51)  J = 45
      KA = ASCII (J+1)
      CALL PUNCH (KA,1,PC,MFLAG)
      IF (I .LE. IA+3)	CALL HEX (KA,1,7+2*(I-IA))
  635 PC = PC +1
      GO TO 800
C
C  ADDRESS TYPE WITH NO A'
  640 IA = IA - 2
      GO TO 550
C
C INSTRUCTIONS LESS THAN 6
  650 K = INST/16 + 1
      GO TO (655,657,660,670,770,680),K
C
C UNRECOGNIZABLE MNEMONIC - LEAVE TWO BYTES OF ZERO
  655 IF (KPC .EQ. 0) GO TO 770
      KA = 0
      GO TO 780
C
C CONDITIONAL JUMPS
  657 CALL EVAL (32767,0)
      IF (KA .NE. 0)  GO TO 513
      IF (A(IA-1) .NE. 39)  GO TO 513
      IF (A(IA-2) .NE. 39)  GO TO 513
      GO TO 780
C
C  SHIFTS
C			CHECK FOR TNS
  660 IF  (INST .EQ. 35)  GO TO 550
C			CHECK FOR GAI
  662 IF (INST .EQ. 39)  GO TO 564
      CALL EVAL (127,0)
      GO TO 780
C
C  INPUT/OUTPUT   JUMP OUT IF NOP
C			CHECK FOR RTX
  670 IF (INST .NE. 48)  GO TO 671
      IF (MACHIN .EQ. 6) GO TO 550
  671 CONTINUE
C			CHECK FOR NOP, CLC, DAD, DSB
      IF (INST .EQ. 52)  GO TO 770
      IF (INST .EQ. 53)  GO TO 770
      IF (INST .EQ. 60)  GO TO 770
      IF (INST .EQ. 61)  GO TO 770
C			CHECK FOR MUL, DIV
      IF (INST .EQ. 62)  GO TO 550
      IF (INST .EQ. 63)  GO TO 550
      KA = 0
C			CHECK FOR IBS, OBS
      IF (INST .EQ. 48)  GO TO 780
      IF (INST .EQ. 56)  GO TO 780
      CALL HEX (INST,1,5)
      CALL PUNCH (INST,1,PC,MFLAG)
      CALL EVAL (7,0)
      K = KA
      IA = IA + 1
      CALL EVAL (31,0)
      IA = IA + 1
      KA = KA + 32*K
      CALL HEX (KA,1,7)
      CALL PUNCH (KA,1,PC+1,MFLAG)
      IF (INST .EQ.  51) GO TO 675
      IF (INST .NE. 59)  GO TO 800
C  IBM AND OBM
  675 CALL EVAL (65535,0)
      IF (A(IA) .NE. 46)  GO TO 677
      IF (A(IA+1) .EQ. 33)  KA = MSK (KA,32768) + 32768
  677 CALL PUNCH (KA,2,PC+2,MFLAG)
      CALL HEX (KA,2,9)
      GO TO 800
C
C INST 5
  680 M = MSK(INST,16) + 1
      GO TO (770,550,770,770,770,770,770,770,564,564,657,
     1		       770,770,770,770,770),M
C
C PSEUDO OPS
C
C  EQU TYPE
  700 CALL HEX (INST,2,7)
      GO TO 800
C
C  ORG
  703 IF (INST .NE. 0)	CALL HEX (PC,2,1)
      GO TO 735
C
C  SET
  705 IF (KST .LT. 0)  GO TO 800
      CALL EVAL (65535,-65536)
      INST = KA
      STVAL(KST) = KA
      GO TO 700
C
C  IDENT
  710 GO TO 800
C
C  END
C			ENTRY FORM EOF (NO END CARD)
  711 DO 712 I=1,20
  712	 CARD(I) = KBLNK4
      DO 713 I=1,14
  713	 B(I) = KBLNK
      DO 714 I = 1, 80
  714	 A(I) = 45
  715 KSTOP = 1
      CALL HEX (PC,2,1)
      IF (A(IA) . EQ. 45)  GO TO 800
      CALL EVAL (32767,0)
      CALL PUNCH (0,999,KA,MFLAG)
      INST = KA
      GO TO 700
C
C  SPACE
  720 CALL EVAL (60,0)
      IF (KLINE-KA .LT. 2)  GO TO 725
      IF (KA .GT. 20)  GO TO 725
      IF (KA .EQ. 0)  GO TO 500
      DO 722 I=1,KA
  722 PRINT 723
  723 FORMAT (1H )
      KLINE = KLINE - KA
      GO TO 500
C
C EJECT
  725 PRINT 726, KPAGE
  726 FORMAT (1H1, 9X, 18HAP16XX VERSION 3.0 , 40X, 5HPAGE , I3, /, 1H
     1	   / 3X, 5HFLAGS, 3X, 2HPC,  3X, 6HOBJECT,   9X, 4HLINE,
     2	       2X, 6HSOURCE )
      KLINE = 57
      KPAGE = KPAGE + 1
      GO TO 500
C
C  DC AND DS TYPE
  730 CALL HEX (PC,2,1)
      IF (KTYPE .GE. 10)  GO TO 564
  735 CALL PUNCH (0,0,0,MFLAG)
      GO TO 800
C		   M10
  741 MACHIN = 1
      GO TO 800
C		   M11
  742 MACHIN = 2
      GO TO 800
C		   M20
  743 MACHIN = 4
      GO TO 800
C		   M21
  744 MACHIN = 5
      GO TO 800
C		   M30
  745 MACHIN = 6
      GO TO 800
C
C PLACE INST IN PUNCH AND PRINT BUFFERS
C
  770 CALL HEX (INST,1,5)
      CALL PUNCH (INST,1,PC,MFLAG)
      GO TO 800
C
  780 IF (KTYPE .GE. 10)  GO TO 790
      IF (KTYPE .LT. 0)   GO TO 790
      CALL HEX (INST,1,5)
      CALL PUNCH (INST,1,PC,MFLAG)
      PC = PC + 1
C
C PLACE OPERAND IN PUNCH AND PRINT BUFER
C
  790 CALL HEX (KA,KPC,7)
      CALL PUNCH (KA,KPC,PC,MFLAG)
C
C PRINT LINE OF LISTING
C
  800 PRINT 802,(ERRTAB(I),I=1,4),(B(I),I=1,14),LINE,(CARD(I),I=1,20)
  802 FORMAT (1H ,3X,4A1,2X,4A1,2X,10A1,5X,I4,2X,20A4)
      KLINE = KLINE - 1
      IF (KSTOP .EQ. 0) GO TO 810
  806 REWIND 10
      CALL PUNCH (0,0,PC,MFLAG)
C			IF MAG TAPE, WRITE EOF
      IF  (MFLAG .NE. 0)  END FILE 9
      IF  (STMAX .GT. 0)  CALL LIST
      IF  (ECOUNT .NE. 0)  GO TO 808
      PRINT 807
  807 FORMAT (////, 28H1 NO ERRORS IN THIS ASSEMBLY)
      GO TO 50
C
  808 IF  (ECOUNT .GT. 100)  ECOUNT = 100
      PRINT 809, ECOUNT, (ELIST(I), I=1,ECOUNT)
  809 FORMAT(1H1,//,I4,25H ERRORS IN THIS ASSEMBLY:,  /// 99(2X,20I5//))
      GO TO 50
  810 IF (KLINE .EQ. 0) GO TO 725
      GO TO 500
      END
      SUBROUTINE  PUNCH  (K,M,LC,MFLAG)
C
C **PUNCH ROUTINE CAUSES OUTPUT TO CARDS.  EACH BYTE IS PUNCHED AS
C      TWO HOLLERITH CHARACTERS.  K=BINARY OUTPUT, M= NO. OF BYTES.
C  IF NUMBER  (M) IS GT 99 PUT ONLY LC IN COL 1-4
      COMMON  A(80),IA,ERRTAB(4),IE,B(14),PC,KA,ST(999),STVAL(999),STMAX
      COMMON  LINE, ECOUNT, ELIST(100)
      COMMON  REFMAX, REFTOP, ROOTS(999), REFS(1111)
      INTEGER REFMAX, REFTOP, ROOTS,	  REFS
      INTEGER  A,ERRTAB,IE,ST,STVAL,STMAX,PC, B, ECOUNT,ELIST
      INTEGER	LC,OCT(17)
      DIMENSION KPBUF(120)
      DATA OCT		   / 1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,
     1			     1HA,1HB,1HC,1HD,1HE,1HF,1H /
      DATA  IP/1/
C
      INTEGER  POWER (8)
      DATA     POWER /1, 16, 256, 4096, 65536, 1048576, 16777216,
     1							  268435456/
C
      KK = K
      IF (KK .LT. 0)  KK = KK +2**31
C
C			CHECK FOR MAG TAPE OUTPUT
      IF (MFLAG .NE. 0)  GO TO 1
      IF (M .NE. 0) GO TO 100
      IF (IP .EQ. 1) RETURN
      PUNCH 105,(KPBUF(J),J=1,80)
      IP = 1
      RETURN
  100 IF (IP .EQ. 1)  GO TO 108
      IF (M+M+IP .LE. 81)  GO TO 120
  102 PUNCH  105,(KPBUF(J),J=1,80)
  105 FORMAT (80A1)
  108 DO 110 I=1,80
  110 KPBUF(I) = OCT(17)
      IP = 5
      DO 115 I=1,4
      L = MSK (LC/ POWER(5-I), 16)
  115 KPBUF(I) = OCT(L+1)
      IF (M .GT. 40) RETURN
  120 N = 2*M
      DO 130 I=1,N
      L = MSK (KK/ POWER(N-I+1), 16)
C			ACCOMODATE SIGN BIT
      IF (K .GE. 0) GO TO 125
      IF (N .NE. 8) GO TO 125
      IF (I .EQ. 1)  L = L+8
  125 CONTINUE
      KPBUF(IP) = OCT(L+1)
  130 IP = IP +1
      RETURN
C
C
C		   MAG TAPE OUTPUT
C
C			CHECK FIRST OR LAST ENTRY
1     IF (M .NE. 0)  GO TO 200
      IF (IP .EQ. 1)  RETURN
      CALL MAG (KPBUF,IP)
      IP = 1
      RETURN
C			CHECK FIRST OR FULL
200   IF (IP .EQ. 1)  GO TO 208
      IF (M+IP .LE. 120)  GO TO 220
      CALL MAG (KPBUF,IP)
C			RESET BUFFER
208   DO 210 I = 1,80
210   KPBUF(I) = 0
      IP = 4
      KPBUF(2) = LC/256
      KPBUF(3) = MSK (LC,256)
      IF (M .GT. 40)  RETURN
C			PUT DATA IN BUFFER
220   DO 230 I = 1, M
      L = MSK (KK / POWER (2*(M-I) + 1), 256)
      IF (K .GE. 0)  GO TO 225
      IF (M .NE. 4)  GO TO 225
      IF (I .EQ. 1)  L = L + 128
225   CONTINUE
      KPBUF(IP) = L
230   IP = IP + 1
      RETURN
      END
      SUBROUTINE  HEX  (K,M,JS)
C  HEX SUBROUTINE PLACES K IN HEXADECIMAL IN B FOR PRINTING LISTING
      INTEGER	OCT(17)
      COMMON  A(80),IA,ERRTAB(4),IE,B(14),PC,KA,ST(999),STVAL(999),STMAX
      COMMON  LINE, ECOUNT, ELIST(100)
      COMMON  REFMAX, REFTOP, ROOTS(999), REFS(1111)
      INTEGER REFMAX, REFTOP, ROOTS,	  REFS
      INTEGER  A,ERRTAB,IE,ST,STVAL,STMAX,PC, B, ECOUNT,ELIST
      DATA OCT / 1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,
     1			     1HA,1HB,1HC,1HD,1HE,1HF,1H /
C
      INTEGER  POWER (8)
      DATA     POWER /1, 16, 256, 4096, 65536, 1048576, 16777216,
     1							  268435456/
C
      KK = K
      IF (KK .LT. 0)  KK = KK +2**31
      IF (M .EQ. 0)  RETURN
      IF (M .GT. 4)  RETURN
      N = M + M
      DO 190 I=1,N
      L = MSK (KK/ POWER(N-I+1), 16)
C			ACCOMODATE 32 BIT SIGN
      IF (K .GE. 0) GO TO 9
      IF (N .NE. 8) GO TO 9
      IF (I .EQ. 1)  L = L+8
9     CONTINUE
      J = JS + I - 1
  190 B(J) = OCT (L+1)
      RETURN
      END
      SUBROUTINE  MAG (KPBUF, IP)
C
C	      COMPUTES CHECKSUM AND WRITES REC
C
C     DCL 1 MAG.REC
C	    2 LENGTH   (1)
C	    2 LOCATION (2)
C	    2 DATA     (LENGTH)
C	    2 CHECKSUM (1)
C
      INTEGER  KPBUF(120)
      DATA  K24 /16 777 216/
C
C			INSERT LENGTH
      KPBUF(1) = IP-4
C			COMPUTE CHECKSUM
      K = 0
      IP1 = IP - 1
      DO 99 I=1, IP1
	 K1 = K/128
	 K2 = KPBUF(I)/128
	 K  = K + KPBUF(I)
	 K  = MSK (K,256)
	 K3 = K/128
	 IF (K1 .NE. K2)  GO TO 99
	 IF (K1 .NE. K3)  K = K+1
99	 K = MSK (K,256)
      KPBUF(IP) = K
C			WRITE TAPE
      DO 98  I = 1,IP
98	 KPBUF(I) = KPBUF(I) * K24
      WRITE (9,100)  (KPBUF(K), K=1,IP)
100   FORMAT (120A1)
C			EXIT
      RETURN
      END
      SUBROUTINE EVAL (KH,KL)
C
C** EVAL ROUTINE EVALUATE AN ADDRESS EXPRESSION CONSISTING OF DECIMAL
C      AND HEXADECIMAL NUMBERS, AND DEFINED SYMBOLS, WITH +- OPERATORS.
C  KH IS HIGH LIMIT,  KL IS LOW LIMIT
C
      COMMON  A(80),IA,ERRTAB(4),IE,B(14),PC,KA,ST(999),STVAL(999),STMAX
      COMMON  LINE, ECOUNT, ELIST(100)
      COMMON  REFMAX, REFTOP, ROOTS(999), REFS(1111)
      INTEGER REFMAX, REFTOP, ROOTS,	  REFS
      INTEGER  A,ERRTAB,IE,ST,STVAL,STMAX,PC, B, ECOUNT,ELIST
      INTEGER  DEC
      KA = 0
      KSIGN = 0
C TEST FOR FIRST CHARACTER +-BLANK
      M = A(IA)
      IF (M .EQ. 37) GO TO 110
      IF (M .EQ. 38) GO TO 112
      IF (M .EQ. 45)  GO TO 105
C TEST FOR HEX, DECIMAL, SYMBOL, *, **
  100 M = A(IA)
      IF (M .NE. 33)  GO TO 102
      IF (A(IA+1) .NE. 51)  GO TO 150
      IF (A(IA+2) .LT. 16)  GO TO 120
  102 IF (M .EQ. 39)  GO TO 160
      IF (M .LT. 10)  GO TO 140
      IF (M .LT. 37)  GO TO 150
C ERROR IN ADDRESS EXPRESSION, SKIP TO , OR BLANK
  105 CALL ERROR (6)
  106 IS = IA
      DO 107 I=IS,72
      IA = I
      IF (A(I) .EQ. 45)  GO TO 109
      IF (A(I) .EQ. 46)  GO TO 109
  107 CONTINUE
  109 KA = 0
      RETURN
C
C + SIGN
  110 KSIGN = 0
      IA = IA + 1
      GO TO 100
C - SIGN
  112 KSIGN = -1
      IA = IA + 1
      GO TO 100
C
C HEXADECIMAL NUMBER
  120 IA = IA + 2
      DEC = 0
      L = IA+8
      IS = IA
      DO 122 I=IS,L
      IA = I
      M = A(I)
      IF (M .GT. 15) GO TO 124
  122 DEC = DEC*16 + M
      GO TO 105
C CHECK FOR PROPER TERMINATION OF HEX FIELD
  124 IF (M .NE. 51) GO TO 105
      IA = IA+1
C
C ADD DEC TO KA
  128 KA = KA + DEC
      IF (KSIGN .LT. 0)  KA = KA - 2*DEC
C
C  TEST NEXT CHAR FOR +-',BLANK
C ' , OR BLANK ENDS EXPRESSION
  130 M = A(IA)
      IF (M .EQ. 37)  GO TO 110
      IF (M .EQ. 38)  GO TO 112
      IF (M .EQ. 51)  GO TO 180
      IF (M .EQ. 45)  GO TO 180
      IF (M .EQ. 46)  GO TO 180
      GO TO 105
C
C DECIMAL NUMBER
  140 DEC = 0
      L = IA + 10
      IS = IA
      DO 142 I=IS,L
      IA = I
      IF (A(I) .GT. 9)	GO TO 128
  142 DEC = DEC*10 + A(I)
      GO TO 105
C
C SYMBOL- FIND SYMBOL IN ST AND PUT VALUE IN DEC AND ADD TO KA
  150 CALL SYMBOL(M)
      IF (STMAX .EQ. 0) GO TO 156
      DO 154 I=1,STMAX
      DEC = STVAL(I)
      IF  (ST(I) .NE. M)  GO TO 154
	  CALL REF(I)
	  GO TO 128
  154 CONTINUE
C SYMBOL NOT IN SYMBOL TABLE
  156 CALL ERROR(3)
      GO TO 106
C
C * OR ** SYMBOL
  160 IA = IA + 1
      DEC = PC
      IF (A(IA) .NE. 39) GO TO 128
      IA = IA + 1
      DEC = 0
      GO TO 128
C
C  CHECK THAT VALUE IS IN RANGE
C
  180 IF (KA .GT. KH) GO TO 105
      IF (KA .LT. KL) GO TO 105
C
C*** FIX TO TWOS COMPLEMENT NUMBER IF ONES COMP MACHINE
C
C     IF (KA .LT. 0)  KA = MSK (KA, 2**32) + 1
C
      RETURN
      END
      SUBROUTINE  SYMBOL (KS)
C
C** SYMBOL ROUTINE ACCUMULATES A SYMBOL AND ASSIGNS A NUMERIC IDENTIFIER
C
      COMMON  A(80),IA,ERRTAB(4),IE,B(14),PC,KA,ST(999),STVAL(999),STMAX
      COMMON  LINE, ECOUNT, ELIST(100)
      COMMON  REFMAX, REFTOP, ROOTS(999), REFS(1111)
      INTEGER REFMAX, REFTOP, ROOTS,	  REFS
      INTEGER  A,ERRTAB,IE,ST,STVAL,STMAX,PC, B, ECOUNT,ELIST
      KS = 0
      L = IA + 5
      IS = IA
      DO 110 I=IS,72
      IA = I
      IF (A(I)	.GE. 37)  GO TO 120
      IF (I .LE. L) KS = 37*KS+A(I)
  110 CONTINUE
  120 RETURN
      END
      SUBROUTINE  ERROR (KD)
C
C ** ERROR ROUTINE PLACES AN ERROR FLAG IN ERRTAB
C		AND BUILDS ELIST, BUMPS ECOUNT
C
      COMMON  A(80),IA,ERRTAB(4),IE,B(14),PC,KA,ST(999),STVAL(999),STMAX
      COMMON  LINE, ECOUNT, ELIST(100)
      COMMON  REFMAX, REFTOP, ROOTS(999), REFS(1111)
      INTEGER REFMAX, REFTOP, ROOTS,	  REFS
      INTEGER  A,ERRTAB,IE,ST,STVAL,STMAX,PC, B, ECOUNT,ELIST
      INTEGER EFT(7)
      DATA EFT		  / 1H ,1HN,1HU,1HM,1HO,1HA,1HR /
C
      IF (KD .GE. 0) GO TO 100
      DO 50 I=1,4
   50 ERRTAB(I) = EFT(1)
      IE = 4
      RETURN
  100 ERRTAB(IE) = EFT(KD)
      IF (IE .GT. 1) IE = IE - 1
      ECOUNT = ECOUNT + 1
      IF  (ECOUNT .LE. 100)  ELIST(ECOUNT) = LINE
      RETURN
      END
C					    ***   LIST	 ***
      SUBROUTINE  LIST
C
      COMMON  A(80),IA,ERRTAB(4),IE,B(14),PC,KA,ST(999),STVAL(999),STMAX
      COMMON  LINE, ECOUNT, ELIST(100)
      COMMON  REFMAX, REFTOP, ROOTS(999), REFS(1111)
      INTEGER REFMAX, REFTOP, ROOTS,	  REFS
      INTEGER  A,ERRTAB,IE,ST,STVAL,STMAX,PC, B, ECOUNT,ELIST
C
      INTEGER  CHRBUF(12), REFBUF(18), CONVRT(37), FIRST, SYM, BIAS, DEC
      DATA  K64  /65536/,  K37X5 /69 343 957/
      DATA  CONVRT /1H0, 1H1, 1H2, 1H3, 1H4, 1H5, 1H6, 1H7, 1H8, 1H9,
     A	  1HA, 1HB, 1HC, 1HD, 1HE, 1HF, 1HG, 1HH, 1HI, 1HJ, 1HK, 1HL,
     B	  1HM, 1HN, 1HO, 1HP, 1HQ, 1HR, 1HS, 1HT, 1HU, 1HV, 1HW, 1HX,
     C	  1HY, 1HZ, 1H./
      DATA  CHRBUF /1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H /
C					    INITIALIZE
      KPAGE = 0
      LINE  = 55
      FIRST = 0
C					    INSERT INDEX IN ROOT TABLE
      DO 1 K=1,STMAX
    1	   ROOTS(K) = ROOTS(K) + K * K64
C					    SORT ROOT TABLE
C
      I = STMAX/2
    2 IF  (I .LT. 2)  GO TO 3
	  CALL SIFTUP(I,STMAX)
	  I = I-1
	  GO TO 2
C
C
    3 I = STMAX
    4 IF  (I .LT. 2)  GO TO 5
	  CALL SIFTUP(1,I)
	  JUNK	   = ROOTS(1)
	  ROOTS(1) = ROOTS(I)
	  ROOTS(I) = JUNK
	  I	   = I-1
	  GO TO 4
    5 CONTINUE
C					    PROCESS WARNING MESSAGE
C
       IF  (REFMAX .GT. REFTOP-2)  PRINT 101
  101	   FORMAT (////, 49H   ***   WARNING:  REFERENCE TABLE OVERFLOW
     X	***)
C					    BEGIN MAIN PRINT LOOP
C
      DO 99 INDEX = 1, STMAX
      LINE = LINE + 1
C					    PROCESS TITLE
C
       IF  (LINE .LE. 55)  GO TO 8
	   LINE = 1
	   KPAGE = KPAGE + 1
	   PRINT 102, KPAGE
  102	   FORMAT (84H1  ****	 A P 1 6 X X	 C R O S S     R E F E R
     A E N C E	   L I S T I N G    ****, 15X, 4HPAGE, I3,
     B	     //    37H SYMBOL	 VALUE	  DEFN * REFERENCES, / )
C					    CONVERT SYMBOL TO CHARACTERS
C
    8 SYM = ST(ROOTS(INDEX) / K64)
      DO 98 BIAS=1,37
C	 PRINT 100, INDEX,BIAS,SYM
	   IF  (SYM .GE. 0)  GO TO 10
	   SYM =SYM - K37X5
   98	   CONTINUE
   10 DO 97 K=1,6
	   CHRBUF(7-K)= MOD(SYM,37)
   97	   SYM	      =     SYM/37
      CHRBUF(1) = CHRBUF(1) + BIAS - 1
      DO 96 K = 1,6
   96	   CHRBUF(K) = CONVRT(CHRBUF(K)+1)
C					    PROCESS NEW FIRST CHARACTER
C
      DO 91 LEAD=1,6
	   IF  (CHRBUF(LEAD) .NE. CONVRT(1))  GO TO 15
   91	   CONTINUE
   15 LEAD6 = LEAD + 5
      IF  (FIRST .EQ. CHRBUF(LEAD))  GO TO 20
	  LINE = LINE + 1
	  FIRST = CHRBUF(LEAD)
	  PRINT 111
  111	  FORMAT (1H )
C					    FETCH VALUE IN DEC, HEX
C
   20 DEC = STVAL(ROOTS(INDEX)/K64)
      CALL HEX(DEC,2,1)
C					    FETCH DEF
C
      LINK = MSK(ROOTS(INDEX),K64)
      KDEF = 0
      IF  (LINK .NE. 0)  KDEF = REFS(LINK)/K64
      LINK = MSK(REFS(LINK),K64)
C					    PROCESS CASE OF NO REFS
C
      IF  (LINK .NE. 0) GO TO 25
	  PRINT103, (CHRBUF(K), K=LEAD,LEAD6), DEC, (B(K), K=1,4), KDEF
  103	  FORMAT (1X, 6A1, I7, 1X, 4A1, I5, 15H *     - NONE -)
	  GO TO 99
C					    TRANSFER FIRST 18 REFS
C
   25 DO 95 KBUF=1,18
	  IF (LINK .EQ. 0)  GO TO 30
	  REFBUF(KBUF) =     REFS(LINK)/K64
   95	  LINK	      = MSK(REFS(LINK),K64)
C					    PRINT FIRST LINE OF SYMBOL
C
      KBUF = KBUF + 1
   30 KBUF = KBUF - 1
      PRINT 104,    (CHRBUF(K), K=LEAD,LEAD6), DEC, (B(K), K=1,4), KDEF,
     A		    (REFBUF(K), K=1,KBUF)
  104 FORMAT	 (1X, 6A1, I7, 1X, 4A1, I5, 2H * , 18I5)
C					    PROCESS NEXT 18 REFS
C
   35 IF  (LINK .EQ. 0)  GO TO 99
      DO 94 KBUF=1,18
	  IF  (LINK .EQ. 0)  GO TO 40
	  REFBUF(KBUF) =     REFS(LINK)/K64
   94	  LINK	       = MSK(REFS(LINK),K64)
C					    PRINT NEXT LINE
C
      KBUF = KBUF + 1
   40 KBUF = KBUF - 1
      PRINT 105, (REFBUF(K), K=1,KBUF)
  105 FORMAT (24X, 2H * , 18I5)
      LINE = LINE + 1
      IF  (LINE .LE. 55)  GO TO 35
	    LINE  = 0
	    KPAGE = KPAGE + 1
	    PRINT 102, KPAGE
	    GO TO 35
C					    END MAIN PRINT LOOP
C
   99 CONTINUE
C					    PRINT SUMMARY
C
      K = REFMAX - STMAX -1
      PRINT 109, STMAX, K
  109 FORMAT (///// 24H NUMBER OF SYMBOLS    = , I5, //,
     A		    24H NUMBER OF REFERENCES = , I5)
      RETURN
C
C
      END
C					    ***   SIFTUP   ***
      SUBROUTINE  SIFTUP(INDEX, MAX)
C
C	 INDEX, MAX = INDICIES TO ROOT TABLE
C
      COMMON  A(80),IA,ERRTAB(4),IE,B(14),PC,KA,ST(999),STVAL(999),STMAX
      COMMON  LINE, ECOUNT, ELIST(100)
      COMMON  REFMAX, REFTOP, ROOTS(999), REFS(1111)
      INTEGER REFMAX, REFTOP, ROOTS,	  REFS
      INTEGER  A,ERRTAB,IE,ST,STVAL,STMAX,PC, B, ECOUNT,ELIST
C
      DATA  K64 /65536/
      K    = INDEX
      KOPY = ROOTS(K)
      ITEM = ST(KOPY/K64)
C
    1 J = 2*K
      IF  (J .GT. MAX)	GO TO 9
	  IF  (J .GE. MAX)  GO TO 2
	      IF  (KOMPAR(ST(ROOTS(J+1)/K64),
     A			 ST(ROOTS(J  )/K64) ) .GT. 0)  J=J+1
    2	  IF  (KOMPAR(ST(ROOTS(J  )/K64), ITEM) 	.LE. 0)  GO TO 9
	      ROOTS(K) = ROOTS(J)
	      K       = J
	      GO TO 1
C
    9 ROOTS(K) = KOPY
      RETURN
C
      END
C					    ***   KOMPAR   ***
      INTEGER FUNCTION	KOMPAR(I,J)
C
C	 I,J = INDICIES TO ROOT TABLE
C
      COMMON  A(80),IA,ERRTAB(4),IE,B(14),PC,KA,ST(999),STVAL(999),STMAX
      COMMON  LINE, ECOUNT, ELIST(100)
      COMMON  REFMAX, REFTOP, ROOTS(999), REFS(1111)
      INTEGER REFMAX, REFTOP, ROOTS,	  REFS
      INTEGER  A,ERRTAB,IE,ST,STVAL,STMAX,PC, B, ECOUNT,ELIST
C
      DATA  K37X5 /  69 343 957 /
C
C					    NORMALIZE VALUES, SAVING LEN
      LOCALI = I
      DO 99 K=1,6
	  IF  (LOCALI .LT. 0	)  GO TO 1
	  IF  (LOCALI .GE. K37X5)  GO TO 1
	  LOCALI = LOCALI * 37
   99	  CONTINUE
    1 LENI = 7-K
C
      LOCALJ = J
      DO 98 K=1,6
	  IF  (LOCALJ .LT. 0	)  GO TO 2
	  IF  (LOCALJ .GE. K37X5)  GO TO 2
	  LOCALJ = LOCALJ * 37
   98	  CONTINUE
    2 LENJ = 7-K
C					    DETERMINE CASE
      IF  (LOCALI .GE. 0)  GO TO 3
	  IF  (LOCALJ .LT. 0)  GO TO 5
	      GO TO 30
    3 IF  (LOCALJ .LT. 0)  GO TO 10
C					    CASE OF BOTH SAME SIGN
    5 IF  (LOCALI-LOCALJ)  10, 9,30
C					    CASE OF SAME
    9 IF  (LENI  -LENJ	)  10,20,30
C					    LT=-1, CASE OF SECOND NEG
   10 KOMPAR = -1
      RETURN
C					    EQ= 0
   20 KOMPAR =	0
      RETURN
C					    GT=+1, CASE OF FIRST  NEG
   30 KOMPAR = +1
      RETURN
C
      END
C					    ***   DEF	***
      SUBROUTINE  DEF(INDEX)
C
      COMMON  A(80),IA,ERRTAB(4),IE,B(14),PC,KA,ST(999),STVAL(999),STMAX
      COMMON  LINE, ECOUNT, ELIST(100)
      COMMON  REFMAX, REFTOP, ROOTS(999), REFS(1111)
      INTEGER REFMAX, REFTOP, ROOTS,	  REFS
      INTEGER  A,ERRTAB,IE,ST,STVAL,STMAX,PC, B, ECOUNT,ELIST
C
      DATA  K64 /65536/
C					    CHECK FOR NO ROOM
      IF  (REFMAX .GE. REFTOP)	RETURN
C					    PROCESS NEW SYMBOL
      IF  (ROOTS(INDEX) .NE. 0) GO TO 1
	  ROOTS(INDEX) = REFMAX
	  REFS(REFMAX) = LINE * K64
	  REFMAX       = REFMAX + 1
C					    PROCESS OLD SYMBOL
    1 LINK	 = ROOTS(INDEX)
      REFS(LINK) = MSK(REFS(LINK), K64) + LINE * K64
      RETURN
C
      END
C					    ***   REF	***
      SUBROUTINE  REF(INDEX)
C
      COMMON  A(80),IA,ERRTAB(4),IE,B(14),PC,KA,ST(999),STVAL(999),STMAX
      COMMON  LINE, ECOUNT, ELIST(100)
      COMMON  REFMAX, REFTOP, ROOTS(999), REFS(1111)
      INTEGER REFMAX, REFTOP, ROOTS,	  REFS
      INTEGER  A,ERRTAB,IE,ST,STVAL,STMAX,PC, B, ECOUNT,ELIST
C
      DATA  K64 /65536/
C					    CHECK FOR NO ROOM
      IF  (REFMAX .GT. REFTOP-2)  RETURN
C					    PROCESS NEW SYMBOL
      IF  (ROOTS(INDEX) .NE. 0)   GO TO 1
	  ROOTS(INDEX	) = REFMAX
	  REFS (REFMAX	) = REFMAX+1
	  REFS (REFMAX+1) = LINE * K64
	  REFMAX	   = REFMAX + 2
	  RETURN
C					    PROCESS OLD SYMBOL; SEARCH
C						 CHAIN TO DETERMINE CASE
    1 LINK0 = ROOTS(INDEX)
      LINK00= LINK0
      LINK1 = MSK(REFS(LINK0),K64)
C
    2 IF  (LINK1 .EQ. 0)  GO TO 3
	  LINERF = REFS(LINK1)/K64
	  IF  (LINERF .EQ. LINE)  GO TO 4
	  IF  (LINERF .GT. LINE)  GO TO 5
	      LINK0 = LINK1
	      LINK1 = MSK(REFS(LINK1),K64)
	      GO TO 2
C					    CASE OF TRAILING REF
    3 REFS(LINK0)  = REFS(LINK0) + REFMAX
      REFS(REFMAX) = LINE	 * K64
      REFMAX	   = REFMAX	 + 1
      RETURN
C					    CASE OF DUPLICATE REF
    4 IF  (LINK00 .NE. LINK0)  RETURN
C					    CASE OF INSERTED REF
    5 REFS(LINK0)  = REFS(LINK0) - LINK1 + REFMAX
      REFS(REFMAX) = LINE * K64  + LINK1
      REFMAX	   = REFMAX + 1
      RETURN
      END
      INTEGER FUNCTION	MSK(M,N)
C
C	 EXTRACTS CONSECUTIVE LOW ORDER BITS
C
      INTEGER  SIGN
      DATA  SIGN /0/
C			EVALUATE SIGN JUST ONCE
      IF (SIGN .EQ. 0)	SIGN = 2 ** 31
      MM = M
C
C	 TURN OFF SIGN BIT
C
      IF  (MM .LT. 0)  MM = MM + SIGN
C
      MSK = MM - N * (MM/N)
C
      RETURN
      END
      SUBROUTINE  UNPACK (A,CARD,CSET)
C
C	 UNPACKS CARD(80) VIA CSET(64) INTO A(80)
C
      INTEGER  A(80), CARD(20), CSET(64), POWER(4),  SIGN, IMAGE
      DATA  POWER /16777216,65536,256,1/
C
      SIGN = 2**31
      I = 1
      DO 100 K = 1,20
      IMAGE = CARD(K)
      IF  (IMAGE .LT. 0)  IMAGE = IMAGE + SIGN
      DO  50 J = 1,4
      II = MSK (IMAGE / POWER(J),  64)
      A(I) = CSET(II+1)
   50 I = I+ 1
  100 CONTINUE
C
      RETURN
      END
*			      ***   UNPACK   ***
*
*
*	       DIM   ARRAY(80), CARD(20), CSET(64)
*
*	       CALL UNPACK  (ARRAY, CARD, CSET)
*
*
*	 UNPACKS  CARD	INTO  ARRAY  VIA  CSET TRANSLATION TABLE
*
*
*
*			      ENTRY
UNPACK	 CSECT
	 B     12(15)
	 DC    AL1(7)
	 DC    CL7'UNPACK'
	 STM   14,8,12(13)
	 BALR  3,0		   3 = BASE REG
	 USING *,3
	 LM    4,6,0(1) 	   LOAD ARG ADDRESSES
	 LA    8,80		   8 = 80 COUNTER
*
*			      PROCESS
LOOP	 IC    7,0(5)		   5 = CARD
	 N     7,=XL4'3F'	   7 = LOW 6 BITS OF CHAR
	 SLL   7,2		   WORD ALIGN
	 L     7,0(6,7) 	   6 = CSET
	 ST    7,0(4)		   4 = ARRAY
	 LA    5,1(5)		   BUMP CARD PTR BY 1
	 LA    4,4(4)		   BUMP ARRAY PTR BY 4
	 BCT   8,LOOP
*
*			      EXIT
	 LM    2,8,28(13)
	 MVI   12(13),X'FF'
	 BR    14
	 EJECT
*			      ***   MSK   ***
*
*
*
*	       X = MSK (DATA, MASKCODE)
*
*
*	 MASKS DATA WITH MASKCODE-1
*
*
*
*			      ENTRY
MSK	 CSECT
	 B     8(15)
	 DC    AL1(3)
	 DC    C'MSK'
	 STM   14,3,12(13)
	 BALR  3,0
	 USING *,3
*			      PROCESS
	 LM    2,3,0(1)
	 L     0,0(3)		   0 = MASKCODE
	 BCTR  0,0			       -1
	 N     0,0(2)		   AND WITH DATA = 2
*				   RESULT IN 0
*
*			      EXIT
	 LM    2,3,28(13)
	 MVI   12(13),X'FF'
	 BR    14
*
	 END
@
$
*
*
*			      ENTRY
MSK	 CSECT
	 B     8(15)
	 DC    AL1(3)
	 DC    C'MSK'
	 STM   14,3,12(13)
	 BALR  3,0
	 USING *,3
*			      PROCESS
	 LM    2,3,0(1)
	 L     0,0(3)		   0 = MASKCODE