SUBROUTINE	CLIST
C
C	SUBROUTINE TO COMPILE A COMMAND LIST
C
	BYTE	IBLANK,IUNDER		! Characters for print
	INTEGER	IMOVE(31)		! Defines permissible move statemnts
	INCLUDE	'CLCOMMON.FTN'		! Common blocks
	DATA	IBLANK/' '/	, IUNDER	/'_'/
	DATA	IMOVE/	31,105,"100002,"066000, 106,"104006,"060000,
	1	302,"110006,"060000, 306,"100006,"060000,
	2	405,"110002,"066000,
	3	502,"100001,"064000, 504,"110001,"064000,
	4	602,"112006,"060000, 605,"100004,"066000,
	5	606,"102006,"060000/
	DATA	NORFLG/"060000/				!NORMAL FLAGS ALLOWED (FAST,WHENLAM)

C
C	FUNCTIONS DIVIDE INTO 4 CLASSES
C
C	1-4	NUMBERS OR FCNA
C	4-IVERB	STATEMENT TYPES
C	IVERB+1-IFLG	MODIFIERS
C	IFLG+1....	FLAGS
C
C
C
C
C	STACK INDICATORS
C
C	1	READ LIST EXPECTED (AFTER MOVE FROM LIST)
C	2	WRITE LIST EXPECTED (AFTER MOVE TO LIST)
C	3	CTRL FUNCTION LIST EXPECTED (AFTER EXECUTE LIST)
C	4	ENDDO EXPECTED (AFTER DO )
C			4,RETURN ADDRESS,BACK POINTER (0 IGNORED)
C	5	ELSE,ELSEIF,ENDIF	EXPECTED (AFTER IF)
C	6	ELSE,ELSEIF,ENDIF	EXPECTED (AFTER ELSE,ELSEIF)
C	7	BEGINBLOCK, ENDBLOCK	EXPECTED (AFTER DO)
C			7,STACK COUNT,STATEMENT#,ADDRESS,#,ADD2,.....
C			STATEMENT#< 0 OR =0
C			IF = 0 THEN POINTS TO ENDBLOCK
C
C	MOST ENTRIES:
C		INDICATOR,ADDRESS
C
C	CLIST FORMAT
C
C	WORD 1	RTN	PC
C	WORD 2	000000
C	WORD 3	MINIMUM BUFFER SIZE (BYTES)
C	WORD 4	OFFSET TO EXTRA DATA (0 IF NO EXTRA DATA)
C	WORD 5	BITS 0-7	= CRATE MASK (CRATES USED)
C	WORD 6	CLIST SIZE (BYTES)
C	WORD 7	CLIST (MIOP EXECUTABLE CODE)
C	WORD 8....... ( "      "        "  )
C	WORD N	EXTRA INFORMATION
C

C
C	SET UP INITIAL VALUES
C
	JERR	= 0					!ERROR COUNT (NUMBER OF ERRORS)
	LERR	= 0
	ICMASK	= 0					!CRATE MASK
	EQUTBL(2)	= IEQMAX			!RESET EQUIVALENCE TABLE
	IKMAX	= KEYMAX				!RESET TOP OF SYMBOL TABLE
	IB(1)	= IEQMAX				!RESET NUMBER OF SYMBOLS
	ILINE	= 0					!LINES OF CODE PROCESSED
	IEND	= 0
	IS	= 1					!CURRENT LOCATION IN THE STACK
	ITSTAK(1)	= -1				!START TYPE STACK
	ISTACK(1)	= 0
	INDENT	= 1					!INDENTATION OF LISTING
	INDSAV	= 1					!NEXT INDENTATION
	IC(1)	= "104777				!RTN PC IS FIRST WORD
	DO 3 J	= 2,ICMAX				!CLEAR THE CLIST ARRAY
3	IC(J)	= 0
	IADD	= 6					!LAST WORD OF HEADER=6
	GO TO 2

C
C	PRINT PREVIOUS LINE OF CODE
C
1	CONTINUE
	ILINE	= ILINE + 1				!LINE NUMBER FOR LISTING
	IF(IEXCL .EQ. 1) IEXCL	= 81			!LOCATION OF EXCLAMATION PT. (COMMENT)
	I	= 65 - (IEXCL +INDENT) + ISTRT0		!INDENTATION CHAR COUNT
	IF(I .LT. 5) I	= 5
	J	= INDENT + I + 80 - ISTRT0		!NUMBER OF CHAR TO PRINT
	MAX	= 81					!MAX NUMBER OF CHAR TO PRINT
	IF(J .GT. 120) MAX	= MAX - (J - 120)
	WRITE(6,9501) ILINE,IADD1,(IBLANK,J=1,INDENT),
	1	(IA(J),J	= ISTRT0,IEXCL-1),
	2	(IBLANK,J	= 1,I),
	3	(IA(J),J	= IEXCL,MAX)
	INDENT	= INDSAV
C
C	START PROCESSING NEW LINE OF CODE
C
2	IF(IEND .NE. 0) GO TO 9000			!END OF THE PROGRAM
	IFSTAK(1)	= -1				!END OF FUNC STAK
	IFSTAK(2)	= -1
	IFSTAK(3)	= -1
	IFSTAK(4)	= -1
	LERR	= 0					!ERROR TYPE
	IFSTAT	= 0					!COMMAND STATUS
	IFSAVE	= 0					!SAVED DATA
	ISRC	= 0					!SOURCE VALUE
	IDST	= 0					!DESTINATION VALUE
	ICNT	= 0					!COUNT (NUMBER OF TIMES TO DO)
	IFCNA	= 0					!<F,C,N,A> VALUE
	MASK	= "77777777				!DATA MASK
	IMSK	= 0					!NO MASKING REQUIRED
	IFCNT	= 0					!PREV. FUNC COUNT
	NUMBER	= 0					!STATEMENT NUMBER
	VALUE1	= 0
	VALUES	= 0
	VALUE2	= 0
	ITYPE	= 0					!TYPE OF STATEMENT
	READ(1,9500,END=9000) IA			!GET THE LINE OF COMMAND LIST
	IA(81)	= ' '					!LAST CHAR BLANK ALWAYS
	DO 7 I	= 1,80					!SCAN LINE FOR NON PRINTING CHAR
	IEXCL	= I					!ENDS UP AS LOCATION OF '!'
	IF(IA(I) .LE. ' ') IA(I)	= ' '		!SUBSTITUTE BLANKS
	IF(IA(I) .EQ. '!') GO TO 8			!REST IS COMMENT
	IF(IA(I) .EQ. "177) IA(I)	= ' '		!TURN 'RUB OUT' TO BLANK
	IF(IA(I) .NE. '=') GO TO 7			!NOT ASSIGNMENT STATEMENT
	ITYPE	= 15					!ASSIGNMENT STATEMENT
	IFSAVE	= I					!LOCATION OF '='
7	CONTINUE
8	CONTINUE
	DO 9 I	= 1,80
	ISTRT	= I
	IF(IA(I) .NE. ' ') GO TO 10			!LOOK FOR FIRST NON BLANK CHAR
9	CONTINUE
10	CONTINUE
	ISTRT0	= ISTRT					!FIRST NON BLANK CHAR
	IADD1	= IADD + 1				!ADDRESS TO LIST
11	IF(ISTACK(IS) .LE. 3 .AND. ISTACK(IS) .GT. 0) GO TO 60	!FCNA EXPECTED
9501	FORMAT(2I5,122A1)
9500	FORMAT(132A1)
12	ISTOLD	= ISTRT					!CONTINUE HERE AFTER LIST
	IF(ITYPE .EQ. 15) GO TO 1500			!PROCESS DEFINE STATEMENT (ASSIGNMENT)
	CALL SYMFND(IB,EQUTBL,IA,80,ISTRT,ITYPE,VALUE)
	IFUNC	= ITYPE					!FUNCTION AND TYPE THE SAME FOR NOW
	IERR	= VALUE
	IF(ITYPE .EQ. -1) GO TO 55			!*** BAD CHAR STRING

	DO 15 J	= 1,16
15	IFLAG(J)	= IPFLAG(J)
	IF(ITYPE .EQ. -2) GO TO 1			!NOT EXECUTABLE
	IF(ITYPE .GT. 4 ) GO TO 69			!EXECUTABLE STATEMENT
	IERR	= 20					!*** INDECIPHERABLE STATEMENT
	IF(ITYPE .NE. 4) GO TO 55			!NOT STATEMENT NUMBER
C
C	HERE WE HANDLE STATEMENT NUMBERS
C
	IERR	= 21					!*** STATEMENT NUMBER TOO BIG,Z,OR NEG.
	IF(VALUE .GT. 9999) GO TO 55			!TOO BIG
	IF(VALUE .LE. 0) GO TO 55			!TOO SMALL
	IERR	= 20					!*** UNDECIPHERABLE STATEMENT
	IF(NUMBER .NE. 0) GO TO 55			!MORE THAN 1 NUMBER
	NUMBER	= VALUE
	GO TO 11					!PROCESS REST OF STATEMENT
C
C	HERE WE HANDLE ERROR PRINT OUT
C
55	CONTINUE
	CALL	CLERR					! Print error message
	GO TO 1						!NEXT STATEMENT

C
C	HERE FCNA LIST IS EXPECTED
C
60	CONTINUE
	ITYPE	= 0
	ISTOLD	= ISTRT
	CALL SYMFND(IB,EQUTBL,IA,80,ISTRT,IFUNC,VALUE)	! DECODE FCNA LIST
	IF(IFUNC .EQ. -2) GO TO 1			! NEXT LINE
	IERR	= VALUE
	IF(IFUNC .EQ. -1) GO TO 55			! BAD ENTRY
	IF(ISTACK(IS) .EQ. IFUNC) GO TO 65		! CORRECT FCNA
	IERR	= 60					! *** ILLEGAL FUNCTION IN LIST
	IF(IFUNC .GE. 1 .AND. IFUNC .LE. 3) GO TO 55	! ILLEGAL FUNCTION
	IERR	= 61					! *** INDECIPHERABLE ELEMENT IN LIST
	IF(ISTOLD .NE. ISTRT0) GO TO 55			! ERROR IF NOT FIRST TIME
61	CALL POP(I,1)					! UNSTACK STATUS
	J	= 0					! ZERO IF CONTROL FUNC
	IF( I .NE. 3 ) J	= 1			! IF NOT CONTROL FUNC
	CALL POP(I,1)					! GET ADDRESS COUNT
	ISTRT	= 1					! START ALL OVER
	IC(I)	= IADD - I				! PUT COUNT
	IADD1	= IADD					! Address to print
	J	= 2 * J * IC(I)				! J = BYTES TRANSFERRED
	IF(IAND(IC(I-1),"004000) .NE. 0) J	= 2*J	! DOUBLE WORD TRANSFER
	IF(IC(3) .LT. J ) IC(3)	= J			! SAVE MAX COUNT
	CALL LIST(0,1)					! DUMMY ENTRY AT LIST END
	IERR	= 62					! *** MISSING LIST
	IF(IC(I) .LE. 0) GO TO 55			! NO LIST FOUND
	IF(IFUNC .EQ. -2) GO TO 1			! NOT LIST
	GO TO 12					! New statement
65	CONTINUE
	CALL	CLFCNA(VALUE)
	IF(IFUNC .EQ. -2) GO TO 61			! TERMINATE LIST
	GO TO 60					! MORE THAN 1 FCNA PER LINE OK! 

C
C	PROCESS MODIFIERS OF THE INITIAL COMMAND
C
69	ITYPE	= ITYPE - 4
	DO 68 J	= 6,2,-1				!PUSH DOWN TYPE STACK
68	ITSTAK(J)	= ITSTAK(J-1)
	ITSTAK(1)	= ITYPE				!CURRENT TYPE ON STACK
70	CONTINUE
	IERR	= 22					!*** UNDECIPHERABLE
	ISTOLD	= ISTRT
	CALL SYMFND(IB,EQUTBL,IA,80,ISTRT,IFUNC,VALUE)
	IF(IFUNC .GT. 0 .AND. IFUNC .LE. 3)
	1	ICMASK	= IOR( ICMASK,ISHFT(1,IAND(VALUE,"7000)/"1000) )
	IERR	= VALUE
	IF(IFUNC .EQ. -1) GO TO 55			!BAD ENTRY
	IF(IFUNC .LE. IFLG) GO TO 72
	I	= IFUNC - IFLG
	IFLAG(I)	= 1
D	WRITE(6,9970) I
D9970	FORMAT(' IFLAG'I5)
	GO TO 70					!PROCESS MORE FLAGS
72	CONTINUE
	IF(IFUNC .EQ. -2) GO TO 85			!END OF STATEMENT
	IF(IFUNC .GT. 4) IFUNC	= IFUNC - IVERB+4
	IMAX	= IFTABL(1)
	J	= 2
	DO 75 I	= 1,IMAX
	ITEST	= IFTABL(J)
	J	= J + 1
	KMAX	= IFTABL(J)
	J	= J + 1
	IF(ITEST .EQ. ITYPE) GO TO 76			!MATCHED TYPE
75	J	= KMAX + J
	GO TO 55					!TYPE NOT LOCATED
76	DO 80 K	= 1,KMAX
	IF(IFTABL(J) .NE. IFUNC) GO TO 80		!FUNCTION NOT LOCATED
	IFUNC	= K
	GO TO 90
80	J	= J + 1
	GO TO 55					!BAD FUNCTION
C
C	WAIT OPTIMIZATION
C
85	IF(ITSTAK(2) .NE. 4) GO TO 90			!LAST STATEMENT NOT WAIT
	IWAIT	= 0
	IF(IFLAG(1) .EQ. 0 .AND. IPFLAG(1) .EQ. 0) GO TO 90	!NO WAIT THIS STATEMENT
	IADD	= IADD-3				!REMOVE SUPERFLUOUS WAIT STATEMENT
90	CONTINUE
	DO 91 J	= 6,2,-1
	IFSTAK(J)	= IFSTAK(J-1)			!PUSH NEW FUNCTION DOWN  STAK
91	VSTAK(J)	= VSTAK(J-1)			!PUSH NEW VALUE
	IFSTAK(1)	= IFUNC
	VSTAK(1)	= VALUE
	IF(IFUNC .GT. 0) IERR	= ITYPE*100 - IFUNC	!*** DEFAULT ERROR TYPE
D	WRITE(6,9999) IFUNC,IFSTAT,ISRC,IDST,ICNT,IFCNA,VALUE,VALUE1,
D	1	VALUE2,VALUES
C
C	NOW PROCESS ACCORDING TO TYPE OF STATEMENT (MOVE,GOTO, ETC.)
C
	GO TO(	 100, 200, 300, 400, 500, 600, 700, 800, 900,1000,
	1	1100,1200,1300,1400,1500,1600,1700,1800,1900,2000)ITYPE
	GO TO 1

C
C	MOVE INSTRUCTION
C
C	IFSTAT=	0	NO VALUES EXPECTED
C		1	VALUE STORED, NO MORE EXPECTED
C		2	SOURCE EXPECTED
C		3	DESTINATION EXPECTED
C
C	IFUNC=	-2	TERMINATE PROCESSING
C		1	READ
C		2	WRITE FCNA
C		3	CONSTANT DATA
C		4	LIST OF FCNA
C		5	BUFFER
C		6	REGISTER
C		7	FROM
C		8	TO
C		9	TIMES
C		10	AND
C
100	CONTINUE
	IERR	= 102					!*** INDECIPHERABLE
	IFCNT	= IFCNT + 1				!NUMBER OF FUNC TO PROCESS
	IF(IFCNT .GT. 2) GO TO 55
	IF(IFUNC .LT. 1 .OR. IFUNC .GT. 2) GO TO 101	!NOT FCNA
	IF(IAND(VALUE,"37777600000) .NE. 0) IFUNC	= 4	!REALLY IS LIST
	IFSTAK(1)	= IFUNC				! Save function on stack
	IFCNA	= VALUE					!SAVE FCNA
101	GO TO (140,150,160,170) IFUNC-6			!PROCESS KEYWORD OPS.
	GO TO (110,120,130) IFSTAT			!PROCESS EXPECTED DATA
	IF(IFCNT .GT. 1) GO TO 55			!BAD SYNTAX
	IF(IFUNC .EQ. -2) GO TO 190			!FINAL PROCESS
	GO TO 70					!MORE KEY WORDS
110	CONTINUE
	IMSK	= IFUNC
	MASK	= VALUE
	IF(IMSK .EQ. 3) GO TO 70			!MASK IS CONSTANT
	MASK	= VALUES
	IMSK	= ISRC
	IF(IMSK .NE. 3) GO TO 55			!MSK MUST BE CONSTANT
120	CONTINUE					!PROCESS SOURCE
	IFCNT	= 0
	IFSTAT	= 0
121	IF(IFUNC .EQ.2 ) GO TO 55			!CAN'T READ <WRITE>
	IERR	= 105					!*** DUPLICATE SOURCE
	IF(ISRC .NE. 0) GO TO 55
	ISRC	= IFUNC					!SAVE SRC TYPE
	VALUES	= VALUE					!SAVE SRC DATA
	GO TO 70
130	CONTINUE					!PROCESS DESTINATION
	IERR	= 106					!*** DUPLICATE DESTINATION
	IF(IDST .NE. 0) GO TO 55
	IDST	= IFUNC
	VALUED	= VALUE
	GO TO 165
140	CONTINUE
	IFSTAT	= 2					!NOW SOURCE IS EXPECTED
	GO TO 70
150	CONTINUE
	IFSTAT	= 3					!DESTINATION EXPECTED
155	IF(IFCNT .EQ. 1) GO TO 70			!NO IMPLIED SOURCE
	IFCNT	= 1
	IFUNC	= IFSTAK(2)
	VALUE	= VSTAK(2)
	GO TO 121
160	CONTINUE					!ICNT ALREADY AVAILABLE??
	IF(IFCNT .NE. 2) GO TO 55			!NO
	IF(IFSTAK(2) .NE. 3) GO TO 55			!SAVED VALUE IS NOT DATA
	IERR	= 103					!*** DUPLICATE COUNT IN MOVE
	IF(ICNT .NE. 0) GO TO 55			!ANOTHER COUNT IS ERROR
	IERR	= 104					!*** COUNT TOO BIG,ZERO,OR NEG.
	IF(VSTAK(2) .LE. 0 .OR. VSTAK(2) .GT. 10000) GO TO 55	!BAD COUNT
	ICNT	= VSTAK(2)				!SAVED VALUE IS COUNT
165	IFSTAT	= 0
	IFCNT	= 0
	GO TO 70
170	CONTINUE					!KEYWORD AND
	IFSTAT	= 1					!NEXT IS MASK
	IF(IFCNT .EQ. 2) GO TO 155			!IMPLIED FROM
	IF(IFSTAK(3) .NE. 7) GO TO 55
	GO TO 70
190	CONTINUE
	IF(ISRC .NE. 3) GO TO 185
	IF(IDST .EQ. 2) GO TO 185
	IF(IDST .NE. 5) GO TO 185
	CALL LIST("100006,1)				!MOVE CON TO REG OP. CODE
	CALL LIST(VALUES,2)				!CONSTANT INTO LIST
	CALL LIST(0,1)					!DUMMY
	ISRC	= 6					!NOW SOURCE IS REGISTER
185	CONTINUE
	IERR	= 107					!*** ILLEGAL COMBINATION  SRC + DST
	IF(IMSK .NE. 0 .AND. IDST .NE. 6) GO TO 55	!IF MASK USED DST MUST BE REGISTER
	IF(IMSK .NE. 0 .AND. ISRC .EQ. 3) GO TO 55	!IF MASK, SRC IS NOT CONSTANT
	ISAVE	= ISRC*100+IDST				!DEFINE SRC,DST TO SEARCH FOR
	DO 191	I	= 2,IMOVE(1),3			!SEARCH FOR CORRECT OPERATION
	IF(ISAVE .EQ. IMOVE(I))GO TO 192		!FOUND OPERATION
191	CONTINUE
	GO TO 55					!BAD COMBINATION OF SRC,DST
192	ICODE	= IMOVE(I+1)
	CALL GETFLG(IMOVE(I+2),ICODE)			!TEST IF FLAG APPROPRIATE
	IERR	= 120					!*** ILLEGAL FLAGS
	IF(LERR .NE. 0) GO TO 55			!BAD FLAGS
	CALL LIST(ICODE,1)				!FUNCTION INTO LIST
	IERR	= 101					!*** ILLEGAL COUNT ERROR
	IF(ISRC .NE. 4 .AND. IDST .NE. 4) GO TO 193	!NOT LIST
	IF(ICNT .NE. 0) GO TO 55
	CALL LIST(ICNT,1)				!COUNT TO LIST
	ICNT	= IADD
	CALL PUSH(IADD,1)
	I	= 1					!POSSIBLE READ LIST?
	IF(IDST .EQ. 4) I	= 2			!NO! WRITE INSTEAD
	CALL PUSH(I,1)					!PUSH FUNCTION ONTO STACK
	VALUE	= IFCNA
	IF(IFCNA .EQ. 0) GO TO 1			!IS REALLY VECTOR
	CALL	CLFCNA(IFCNA)				! Set up vector list
	GO TO 61
193	CONTINUE
	IF(ISAVE .EQ. 302) GO TO 197			!CONSTANT TO CAMAC
	IF(IDST .EQ. 6) GO TO 198			!DST IS REGISTER
	IF(ISAVE .EQ. 602) GO TO 196			!REG TO CAMAC
	IF(ICNT .EQ. 0) ICNT	= 1
	CALL LIST(ICNT,1)				!ENTER COUNT INTO LIST
	IF(IAND(ICODE,"004000) .NE. 0) ICNT	= ICNT*2	!NOW IS DOUBLE WORD
	ICNT	= 2*ICNT
	IF(ICNT .GT. IC(3) ) IC(3)	= ICNT
	CALL LIST(IFCNA,1)				!FCNA INTO LIST
	GO TO 1
196	MASK	= IOR("20000000000,MASK)		!NEGATIVE MASK FOR REG INPUT
	GO TO 198
197	MASK	= VALUES				!CONSTANT TO CAMAC
198	CALL LIST(MASK,2)				!CONSTANT TO WRITE
	CALL LIST(IFCNA,1)				!FCNA TO DO IT
199	IF(ICOUNT .NE. 0) GO TO 55			!*** ILLEGAL COUNT ERROR
	GO TO 1

C
C
C	SET COMMAND
C
200	CONTINUE
	CALL GETFLG("77777,I)
	DO 210 J	= 1,16
	IPFLAG(J)	= 0
	IF(IFLAG(J) .GT. 0) IPFLAG(J)	=-1		!SAVE ONLY NEW FLAG SETTINGS 
210	CONTINUE
	GO TO 1

C
C	EXECUTE	STATEMENT (EXECUTE SEVERAL FCNA)
C
C	LEGAL FUNCTIONS:	1	<CONTROL FCNA>
C				2	CONSTANT
C				3	LIST
C				4	TIMES
300	CONTINUE
	GO TO (310,320,330,340) IFUNC			!<>,CONSTANT,LIST,TIMES
	CALL GETFLG(NORFLG,ISRC)
	IERR	= 320					!*** ILLEGAL FLAGS
	IF(LERR .NE. 0) GO TO 55			!ERROR IN FLAGS
	IERR	= 311					!*** MISSING SOURCE
	IF(ISRC .EQ. 0) GO TO 55			!NO FCNA ERROR
	IF(ICNT .EQ. 0)ICNT	= 1			!DEFAULT COUNT
	CALL LIST(ISRC,1)
	CALL LIST(ICNT,1)				!COUNT ONTO LIST
	IF(ICNT .GT. 0) GO TO 305			!NOT LIST
	CALL PUSH(IADD,1)				!PUSH ADDRESS
	CALL PUSH(3,1)					!PUSH CTRL FCNA INDICATOR
	VALUE	= IFCNA
	IF(IFCNA .NE. 0) GO TO 65			!IS LIST
	GO TO 1
305	CALL LIST(IFCNA,1)				!PUSH FCNA
	GO TO 1
310	CONTINUE
	IERR	= 105					!*** DUPLICATE SOURCE
	IF(ISRC .NE. 0) GO TO 55			!*** 301 DUPLICATE FCNA
	IFCNA	= VALUE
	IF(IFCNA .GT. "177777) GO TO 330		!VECTOR FCNA
	ISRC	= "100003				!SINGLE FCNA
	GO TO 70
320	CONTINUE
	IERR	= 104					!*** BAD COUNT
	IF(VALUE .LE. 0 .OR. VALUE .GT. 10000) GO TO 55
325	CONTINUE
	IERR	= 103					!*** DUPLICATE COUNT
	IF(ICNT .NE. 0) GO TO 55			!ONLY 1 COUNT ALLOWED
	ICNT	= VALUE
	GO TO 70					!CONTINUE
330	CONTINUE
	IERR	= 105
	IF(ISRC .NE. 0) GO TO 55			!DUPLICATE SOURCE
	ISRC	= "110003				!LIST OF FCNA
	VALUE	= -1
	GO TO 325					!PUT VALUE INTO COUNT
340	CONTINUE
	IERR	= 104					!*** MISSING COUNT
	IF(ICNT .EQ. 0) GO TO 55			!NO COUNT SPEC.
	GO TO 70

C
C	WAIT	STATEMENT
C
400	CONTINUE
	CALL LIST("122007,1)				!LOAD + WAIT
	CALL LIST(VALUES,2)				!2 DUMMY WORDS
	IWAIT	= -1
450	CONTINUE
	CALL GETFLG(0,I)
	IERR	= 420					!*** NO FLAGS ALLOWED
	IF(LERR .NE. 0) GO TO 55
	GO TO 1
C
C	STOP	STATEMENT
C
500	CONTINUE
	IF(IS .EQ. 1) IEND	= -10			!IMPLIED STOP
	CALL LIST(0,1)					!STOP STATEMENT
	GO TO 450
C
C	DO	STATEMENT
C
600	CONTINUE
	IF(IFUNC .NE. 12) GO TO 605			!NOT WHILE
	IFSTAT	= -1
	GO TO 70					!CONTINUE PROCESSING
605	IF(IFSTAT .EQ. 0) GO TO 610
	IF(IFSTAT .EQ. -1) IFSTAT	= 0
	GO TO 1100					!SET UP CONDITIONAL DO
610	CONTINUE
	IERR	= 650					!*** ILLEGAL SYNTAX IN DO
	IF(IFUNC .NE. -2) GO TO 55
	INDSAV	= INDSAV + 5				!INDENTATION AFTER LISTING
	CALL PUSH(0,1)					!NO BACK POINTER
	CALL PUSH(IADD,1)				!PUSH CURRENT ADDRESS ONTO STACK
	CALL PUSH(4,1)					!PUSH DO LOOP INDICATOR
	GO TO 450					!TEST FOR BAD FLAGS
C
C	ENDDO	STATEMENT (TERMINATES DO LOOP)
C
700	CONTINUE
	IERR	= 701					!*** ILLEGAL DO NESTING
	IF(ISTACK(IS) .NE. 4) GO TO 55			!NO DO LOOP PRINT ERROR
	INDENT	= INDENT - 5
	INDSAV	= INDENT
	CALL POP(I,1)					!POP THE INDICATOR
	CALL POP(I,1)					!GET THE ADDRESS
	CALL LIST("106007,1)				!PUT BRANCH INTO LIST
	CALL LIST(I-IADD-1,1)				!PUT OFFSET INTO LIST
	CALL POP(I,1)					!POP BACK POINTER
	IF(I .EQ. 0) GO TO 1
	IC(I)	= IADD-I				!FILL IN BACK ADDRESS
	GO TO 450					!LOOK FOR BAD FLAGS

C	GO	STATEMENT (GO TO)
C
C	IFUNC:	1	STATEMENT NUMBERS
C		2	<READ FCNA>
C		3	REGISTER
C
800	CONTINUE
	IF(IFUNC .EQ. -2) GO TO 850			!DO FINAL BUSINESS
	IF(ISRC .NE. 0) GO TO 810			!THROUGH WITH ADDRESSES
	IF(IFUNC .GT. 1) GO TO 810
	IERR	= 21
	IF(VALUE .GT. 9999) GO TO 55			!*** 801 STATEMENT NUMBER TOO BIG
	IF(VALUE .EQ. 0)GO TO 55			!OR NEG OR ZERO
	ICNT	= ICNT + 1
	CALL PUSH(-1,1)					!WILL BE ADDRESS LATER
	I	= VALUE					!STATEMENT NUMBER
	CALL PUSH(I,1)					!PUSH ON THE STATEMENT NUMBER
	GO TO 70
810	CONTINUE
	IERR	= 105					!*** DUPLICATE SOURCE
	IF(ISRC .NE. 0) GO TO 55			!SOURCE ALREADY SPEC.
	ISRC	= IFUNC
	IERR	= 108					!***VECTORED FCNA NOT ALLOWED
	IF(VALUE .GT. "0177777) GO TO 55		!VECTORED FCNA
	IFCNA	= VALUE					!SAVE FCNA
	IFSTAT	= 1					!DONE WITH ADDRESSES
	GO TO 70
850	CONTINUE
	IERR	= 810					!*** NO BRANCHES IN GO TO
	IF(ICNT .LE. 1) GO TO 55			!NOT LARGE ENUF
	INDSAV	= INDSAV + 5				!INDENT THE LISTING
	IERR	= 811					!*** MISSING SRC IN GO TO
	IF(ISRC .EQ. 0) GO TO 55			!NO SOURCE ERROR
	IF(ISRC .EQ. 3) GO TO 860
	CALL LIST("104006,1)				!GET DATA
	CALL LIST("77777777,2)				!MASK
	CALL LIST(IFCNA,1)				!FCNA
860	CONTINUE
	CALL LIST("112007,1)				!MULTIPLE BRANCH OP CODE
	CALL LIST(VALUES,1)				!OFFSET TO SUBTRACT FROM VAL.
	CALL LIST(ICNT,1)				!COUNT (# OF BLOCKS)
	DO 870 J	= 1,ICNT			!FILL IN ADDRESSES
	CALL LIST(-1,1)					!WILL BE OFFSET
	K	= IS - 2*(ICNT-J) - 1			!POINTS TO ADDRESS
	ISTACK(K)	= IADD				!FILL IN ADDRESS ON STACK
870	CONTINUE
	DO 875 I	= 2,ICNT,2
	J	= IS - I + 2
	K	= IS - 2*ICNT + I
	ISAVE	= ISTACK(J)
	ISTACK(J)	= ISTACK(K)
875	ISTACK(K)	= ISAVE
	CALL PUSH(2*ICNT,1)				!FILL IN STACK COUNT
	CALL PUSH(7,1)					!PUSH INDICATOR
	GO TO 450					!TEST FOR BAD FLAGS

C
C
C	BLOCK
C		1	CONTINUE
C
900	CONTINUE
	IF(IFUNC .EQ. -2) GO TO 910			!END THE PREVIOUS BLOCK
	IFSAVE	= IFUNC					!CONTINUE REQUESTED
	GO TO 70
910	CONTINUE
	IERR	= 902					!*** ILLEGAL NESTING OR MISSING GOTO
	IF(ISTACK(IS) .NE. 7) GO TO 55			!NO GOTO
	MAX	= ISTACK(IS-1)				!NUMBER OF ENTRIES ON STACK
	DO 950 J	= 2,MAX,2			!LOOK THRU STACK
	IF(NUMBER .NE. ISTACK(IS-J)) GO TO 950		!NOT FOUND IT YET
	ISTACK(IS-J)	= 0
	IF(IFSAVE .NE. 0) GO TO 940			!CONTINUATION
	ISTACK(IS-J)	= -1				!INDICATE BRANCH OFFSET REQUIRED
	CALL LIST("106007,1)				!OP CODE BRANCH
	CALL LIST(-1,1)					!WILL BE OFFSET
940	CONTINUE
	I	= ISTACK(IS-J-1)			!ADDRESS OF GO TO OFFSET
	IC(I)	= IADD-I				!FILL IN OFFSET
	ISTACK(IS-J-1)	= IADD				!NEW ADDRESS FOR LATER
	IFSAVE	= -5
950	CONTINUE
	IF(IFSAVE .EQ. -5) GO TO 1			!BLOCK NUMBER FOUND
	IERR	= 903					!*** STATEMENT NUMBER NOT FOUND OR MISSING
	GO TO 55					!*** BLOCK NUMBER NOT FOUND
C
C	ENDBLOCK	STATEMENT 
C
1000	CONTINUE
	IERR	= 902					!*** ILLEGAL NESTING
	IF(ISTACK(IS) .NE. 7) GO TO 55			!ILLEGAL NESTING OR MISSING GOTO
	INDENT	= INDENT - 5
	INDSAV	= INDENT
	CALL POP(I,1)					!POP INDICATOR
	CALL POP(MAX,1)					!POP COUNT
	DO 1050 J	= 2,MAX,2			!PULL OFF ALL OFFSETS
	CALL POP(ISAVE,1)				!STATEMENT NUMBER
	CALL POP(I,1)					!ADDRESS OF OFFSET
	IF(ISAVE .EQ. 0) GO TO 1050			!NO OFFSET TO SET
	IF(ISAVE .GT. 0) WRITE(6,9950) ISAVE		!WARN USER
9950	FORMAT(' *** WARNING ***	STATEMENT NUMBER NOT FOUND'
	1  I7)
	IC(I) = IADD-I 					!SET OFFSET
1050	CONTINUE
	GO TO 450					!TEST FOR BAD FLAGS

C
C	IF	STATEMENT
C
C	IFUNC:	1	<READ FCNA>
C		2	<CTRL FCNA>
C		3	REGISTER
C		4	SIZE
C		5	DATA (CONSTANT)
C		6	EQ
C		7	NE
C		8	GT
C		9	GE
C		10	LT
C		11	LE
C
1100	CONTINUE
	IF(IFUNC .EQ. -2) GO TO 1150			!FINISH THE STATEMENT
	IF(IFUNC .EQ. 5) GO TO 1120
	IF(IFUNC .GT. 5) GO TO 1130			!RELATIONAL OPERATOR
	IERR	= 105					!*** DUPLICATE SOURCE
	IF(ISRC .NE. 0) GO TO 55			!SOURCE ALREADY SPEC.
	ISRC	= IFUNC					!SOURCE TYPE
	IERR	= 108					!*** VECTOR NOT ALLOWED
	IF(VALUE .GT. "0177777) GO TO 55		!VECTOR
	IFCNA	= VALUE
	IFSTAT	= IFSTAT + 1
	IF(IFUNC .NE. 2) GO TO 70			!DATA IN REGISTER
	IERR	= 1102					!*** DUPLICATE CNTRL FUNCTION
	IF(IFSAVE .NE. 0) GO TO 55			!RELATION SPECIFIED
	IFSAVE	= "104003				!CONTROL FUNC (CHAIN IF  NO Q)
	IFSTAT	= 3
	GO TO 70
1120	CONTINUE
	IF(IDST .NE. 0) GO TO 55			!*** 1105 DUPLICATE DATA
	IDST	= IFUNC
	VALUE1	= VALUE					!NUMBER TO COMPARE
	IFSTAT	= IFSTAT + 1
	GO TO 70
1130	CONTINUE					!OPERATORS (EQ,NE,LE,GE,...)
	IERR	= 1106					!*** DUPLICATE OPERATOR
	IF(IFSAVE .NE. 0) GO TO 55			!TOO MANY OPERATORS
	IERR	= 1107					!*** MISSING SRC OR DST
	IF(IFSTAT .NE. 1) GO TO 55			!MISSING SRC OR DST
	IFSTAT	= IFSTAT + 1
	IFUNC	= IFUNC - 8				!SET UP FUNCTION
	IF(IFUNC .GE. 0) GO TO 1135			!GT,GE,LT,LE
	IFSAVE	= "100005				!CHAIN IF EQ
	IF(IFUNC .EQ. -2) IFSAVE	= "102005	!CHAIN IF NE
	GO TO 70

1135	CONTINUE
	IF(ISRC .EQ. 0) IFUNC	= IAND(IFUNC+2,3)	!REVERSE FUNCTIONS
	IFSAVE	= "104005
	IF(IFUNC .GE. 2) IFSAVE	= "106005
	IF(IFUNC .EQ. 1) ICNT	= -1
	IF(IFUNC .EQ. 2) ICNT	= -1
	GO TO 70
1150	CONTINUE					!FINAL PROCESSING
	IIFLG	= 0					!NO FLAGS AT FIRST
	CALL GETFLG(NORFLG,IIFLG)
	IERR	= 320					!*** BAD FLAGS
	IF(LERR .NE. 0) GO TO 55			!BAD FLAGS
	ISAVE	= IADD
	IERR	= 1110					!*** MISSING SYNTAX ELEMENTS
	IF(IFSTAT .NE. 3) GO TO 55			!INCOMPLETE IF STATEMENT
	VALUE1	= VALUE1 + ICNT				!ACTUAL VALUE TO COMPARE
	IF(ISRC .EQ. 3.OR. ISRC .EQ. 1) IFSAVE	= IOR(IFSAVE,"010000)	!SET UP TO TEST DATA
	INDSAV	= INDSAV + 5
	IF(ISRC .NE. 1) GO TO 1160			!NO IMPLIED READ
	I	= IOR("104006,IIFLG)			!OP CODE READ TO REGISTER
	IIFLG	= IAND(IIFLG,"040000)
	CALL LIST(I,1)					!PUT TO LIST
	IF(VALUES .EQ. 0) VALUES	= "77777777	!24 BIT MASK
	CALL LIST(VALUES,2)				!MASK FOR DATA
	CALL LIST(IFCNA,1)				!SAVE FCNA
1160	CONTINUE
	IFCNA	= IOR(IFCNA,IIFLG)			!PUT IN FLAGS
	CALL LIST(IFSAVE,1)				!BRANCH OP CODE
	IF(ISRC .NE. 2) CALL LIST(VALUE1,2)		!DATA TO COMPARE
	CALL LIST(-1,1)					!WILL BE OFFSET
	CALL PUSH(IADD,1)				!SET UP ADDRESS OF OFFSET
	IF(ITYPE .EQ. 6) CALL PUSH(ISAVE,1)		!ADDRESS TO RETURN TO
	I	= 5					!IF STATEMENT
	IF(ITYPE .EQ. 6) I	= 4			!DO STATEMENT
	IF(ITYPE .EQ. 13) I	= 6			!ELSEIF STATEMENT
	CALL PUSH(I,1)					!ELSE PENDING
	IF(ITYPE .EQ. 13) ISTACK(IS)	= 6		!ELSE PENDING
	IF(ITYPE .EQ. 6) ISTACK(IS)	= 4		!DO TYPE INDICATOR
	IF(ISRC .EQ. 2) CALL LIST(IFCNA,1)		!NEED FCNA IF CNTRL FUNCTION
	GO TO 1

C
C	ELSE	STATEMENT
C
1200	CONTINUE
C
C	ELSEIF	STATEMENT
C
1300	CONTINUE
	IF(IFUNC .NE. -2) GO TO 1100			!ELSE IF MODIFIERS
	IERR	= 1401					!*** ILLEGAL NESTING OR MISSING IF
	IF(ISTACK(IS) .LT. 5 .OR. ISTACK(IS) .GT. 6) GO TO 55	!ERROR
	CALL LIST("106007,1)				!OP CODE (BRANCH)
	CALL LIST(-1,1)					!WILL BE OFFSET
	I	= ISTACK(IS-1)				!POINTS TO OFFSET
	IC(I)	= IADD-I 				!NOW IS OFFSET
	ISTACK(IS-1)	= IADD				!POINTS TO OFFSET
	IF(ITYPE .EQ. 13) GO TO 1100			!IF + ELSEIF ARE THE SAME
	GO TO 450
C
C	ENDIF	STATEMENT
C
1400	CONTINUE
	IERR	= 1401					!*** ILLEGAL NESTING OR MISSING IF
	IF(ISTACK(IS) .LT. 5 .OR. ISTACK(IS) .GT. 6) GO TO 55
1410	IF(ISTACK(IS) .LT. 5 .OR. ISTACK(IS) .GT. 6) GO TO 450
	IF(ISTACK(IS) .EQ. 5) INDENT	= INDENT - 5
	INDSAV	= INDENT
	CALL POP(I,1)					!POP THE INDICATOR
	CALL POP(I,1)					!THE OFFSET ADDRESS
	IC(I)	= IADD-I				!THE OFFSET
	GO TO 1410					!CONTINUE TILL DONE

C
C	DEFINE	STATEMENT
C
1500	CONTINUE
	GO TO 55
C
C	ADD	FUNCTION (ADDS DATA TO THE BUFFER)
C
1600	CONTINUE
	IFLAG(9)	= 1				!ADD TO MEM FLAG
	GO TO 100					!NOW FINISH AS IF MOVE

C
C	SCAN	FUNCTION
C
C	1	<READ FCNA>
C	2	DATA
C	3	FROM
C	4	TO
C	5	TIMES
C
1700	CONTINUE
	IF(IFUNC .NE. 1) GO TO 1701
	IF(VALUE .LE. "0177777)GO TO 1701		!NOT VECTORED
	IERR	= 108					!*** VECTOR NOT ALLOWED
	GO TO 55
1701	IF(IFUNC .EQ. -2) GO TO 1770			!DONE, CHECK IT
	GO TO(1710,1720,1730,1740,1750)IFUNC
	GO TO 55
1710	CONTINUE
	GO TO (1711,1712,55) IFSTAT			!*** 1701 ILLEGAL SYNTAX
1711	IERR	= 1710					!*** DUPLICATE SOURCE
	IF(ISRC .NE. 0) GO TO 55
	ISRC	= VALUE					!SOURCE FCNA
	IFSTAT	= 0
	GO TO 70
1712	IERR	= 1711					!*** DUPLICATE DST
	IF(IDST .NE. 0) GO TO 55			!TOO MANY DST ERRORS
	IDST	= VALUE
	IFSTAT	= 0
	GO TO 70
1720	CONTINUE
	IF(VALUE .LE. 0 .OR. VALUE .GT. 10000) GO TO 55	!*** 1702 RANGE TOO BIG,Z,OR NEG
	IERR	= 1712					!*** DUPLICATE COUNT
	IF(ICNT .NE. 0) GO TO 55			!TOO MANY COUNT ERRORS
	IERR	= 1713					!*** ILLEGAL SHOULD BE FCNA
	IF(IFSTAT .NE. 0) GO TO 55			!UNEXPECTED
	ICNT	= VALUE
	IFSTAT	= 3
	GO TO 70
1730	CONTINUE
	IF(IFSTAT .NE. 0) GO TO 55			!*** 1703 ILLEGAL SYNTAX
	IFSTAT	= 1
	GO TO 70
1740	CONTINUE
	IF(IFSTAT .GT. 1) GO TO 55			!*** 1704 ILLEGAL SYNTAX
	IFSTAT	= 2
	GO TO 70
1750	CONTINUE
	IF(IFSTAT .NE. 3) GO TO 55			!*** 1705 MISSING COUNT
	IFSTAT	= 0
	GO TO 70

C
C	ASSEMBLE SCAN OP CODES
C
1770	CONTINUE
	IERR	= 1714					!*** MISSING SYNTAX ELEMENT
	IF(IFSTAT .NE. 0) GO TO 55
	IERR	= 1715					!*** MISSING FCNA SOURCE
	IF(ISRC .EQ. 0) GO TO 55			!NO SOURCE
	IFSAVE	= "100007				!WILL BE OP CODE
	IF(IDST .EQ. 0) GO TO 1775			!NO DST
	IFSAVE	= "110007				!OP CODE INCREMENT FCNA
	ICNT	= IDST - ISRC + 1			!COUNT
	IERR	= 1716					!*** SRC,DST NOT IN SAME CRATE
	IF(IAND(ISRC,"7000) .NE. IAND(IDST,"7000))GO TO 55
	IERR	= 1717					!*** SRC,DST NOT SAME FUNC
	IF(IAND(ISRC,"170000) .NE. IAND(IDST,"170000)) GO TO 55
	IERR	= 1718					!*** BACKWARDS SCAN ILLEGAL
	IF(ICNT .LE. 0 ) GO TO 55			!ILLEGAL SRC,DST
	IERR	= 1719					!*** DST IN CONTROLLER NOT ALLOWED
	IDST	= IAND(IDST,"777)			!STRIP OFF N,A
	IF(IDST .GT. 25*16+15) GO TO 55			!DST TOO BIG
1775	CONTINUE
	I	= 0
	CALL GETFLG("064000,I)				!GET FLAGS
	IERR	= 120					!*** ILLEGAL FLAGS
	IF(LERR .NE. 0) GO TO 55			!FLAG ERROR
	J	= IOR( "102007,IAND(I,"060000) )	!LOAD OP CODE
	IFSAVE	= IOR(IFSAVE,I)				!SCAN OP CODE
	CALL LIST(J,1)					!OP CODE INTO LIST
	CALL LIST(ICNT,1)				!COUNT INTO LIST
	CALL LIST(ISRC,1)				!FIRST FCNA INTO LIST
	CALL LIST(IFSAVE,1)				!NEXT OP CODE
	CALL LIST(0,1)
	CALL LIST(0,1)
	GO TO 1

1800	CONTINUE
C
C	INCREMENT MEMORY ROUTINE
C
	IF(IFUNC .NE. -2) GO TO 55		!NO SYNTAX FOR TEST
	ICODE	= "112004			!OP CODE SHIFT ADDRESS BY QCNT
	CALL GETFLG("064000,ICODE)
	CALL LIST(ICODE,1)
	CALL LIST(VALUED,2)			!2 DUMMY WORDS
	GO TO 1
1900	CONTINUE
C
C	RESET ORIGIN OF BUFFER ROUTINE
C
	IF(IFUNC .EQ. 1) VALUES	= VALUE
	IF(IFUNC .EQ. 1) GO TO 70
	CALL LIST("100000,1)
	CALL LIST(0,1)
	IF(VALUES .EQ. 0) GO TO 1		! Address already zero
	CALL LIST("102001,1)			!OP CODE ADD DISPLACEMENT
	CALL LIST(VALUES,2)			!2 DUMMY WORDS
	GO TO 1
2000	CONTINUE
	GO TO 1

C
C	THIS IS THE END OF THE COMPILER
C
9000	CONTINUE
	CALL CLOSE(1)					!CLOSE INPUT FILE
	IF(JERR .NE. 0) RETURN				!DO NOT FINISH WITH ERRORS
	IF(IEND .EQ. 0) CALL LIST(0,1)			!IMPLIED STOP AT END
	CALL LIST(0,1)					!2 WORD STOP CODE
	IC(6)	= 2 * (IADD - 6)			!BYTE COUNT IN CLIST
	IC(5)	= ICMASK				!SAVE CRATE MASK
	IF(IS .NE. 1) GO TO 9010			!GIVE ERROR MESSAGE
	WRITE(6,9002)
9002	FORMAT(/'	CRATES USED:')
	I	= 1
	DO 9003 J	= 0,7
	IF(IAND(ICMASK,I) .NE. 0) WRITE(6,9004) J
	I	= I*2
9003	CONTINUE
9004	FORMAT(20X,I3)
	WRITE(6,9005) IC(3)
9005	FORMAT(/I10 ' BYTES IS THE MINIMUM BUFFER SIZE'/
	1 11X,'NO ERRORS IN CLIST'//)
	RETURN
9010	JERR	= JERR + 1
	WRITE(6,9001)
9001	FORMAT(' *** ERROR ***	MISSING	 ENDDO,ENDIF STATEMENTS')
	END						!RETURN TO MAIN PROGRAM