C RATFOR.FTN

C	THIS RATIONAL FORTRAN (RATFOR) PREPROCESSOR WAS WRITTEN BY
C	PETER PALIJ BASED ON THE RATFOR PREPROCESSOR SUGGESTED BY
C	KERNIGHAN AND PLAUGER IN "SOFTWARE TOOLS".

C	 MODIFIED JULY 24, 1979	
C	 	  21-03-85 BY THOMAS SCHUETZ 
C	 		   PURPOSE : INCREASE SIZE OF DEFINE STACK TO 70

C	BLOCK DATA

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	29-05-79
C			18-06-79

C	BLOCK DATA IS USED TO ESTABLISH THE VARIOUS ARRAYS AND
C	VARIABLES USED THROUGHOUT THE RATFOR PREPROCESSOR.  
C	EACH VARIABLE IS DEFINED WITHIN THE CONTEXTS OF THE ROUTINE USING IT.

C	COMMON	 DEFINITION
C	------	 ----------
C	CDEFIO	 TRANSFERS THE PUSH BACK INFORMATION.
C	CLINE	 TRANSFERS THE CURRENT LINE NUMER.
C	RATDEF	 CONTAINS THE DEFINE BUFFER AND POINTER.
C	RATFIO	 CONTAINS THE UNIT CODE DESIGNATIONS FOR THE VARIOUS
C			 INPUT/OUTPUT ROUTINES.  THESE CODES ARE
C			 MACHINE DEPENDENT, AND DESIGNATE THE FILES
C			 RATFOR IS TO USE IN IT PROCESSING.
C	RATSYS	 CONTAINS THE VARIOUS CONSTANTS USED BY THE RATFOR
C			 PREPROCESSOR.
C	RASCII	 CONTAINS THE VARIOUS CHARACTER DEFINITIONS.  THESE
C			 ARE IN ASCII DECIMAL EQUIVALENTS, AND ARE
C			 MACHINE DEPENDENT.

	BLOCK DATA
	INTEGER BP
	LOGICAL*1 BUF(5)
	INTEGER LINECT
	INTEGER DEFPNT
	LOGICAL*1 DEFSTK(70,2,16)
	INTEGER ERRFIL,STDIN,STDOUT
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE
	INTEGER LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT
	INTEGER LEXRE,LEXUN,LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27)
	LOGICAL*1 MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE
	LOGICAL*1 TAB,TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3
	LOGICAL*1 DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5)
	LOGICAL*1 LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR
	LOGICAL*1 TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN
	LOGICAL*1 ORBAR,UPARW,COMMA,PERCNT
	COMMON /CDEFIO/BP,BUF
	COMMON /CLINE/LINECT
	COMMON /RATDEF/DEFPNT,DEFSTK
	COMMON /RATFIO/ERRFIL,STDIN,STDOUT
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,
     &		LEXDE,LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,
     &		LEXRE,LEXUN,LEXWH,OUTBUF,OUTP
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &		MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &		UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &		GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	DATA BP/0/,BUF/5*0/
	DATA LINECT/1/
	DATA DEFPNT/0/
	DATA ERRFIL/05/,STDOUT/01/
	DATA ALPHA/-3/,DIGIT/-1/,EOF/26/,EOS/-99/,LETTER/-2/,NL/13/
	DATA NO/-1/,YES/0/,LEXBR/1/,LEXDE/2/,LEXDO/3/,LEXEL/4/
	DATA LEXFO/5/,LEXIF/6/,LEXIN/7/,LEXNE/8/,LEXRE/9/,LEXUN/10/
	DATA LEXWH/11/,LEXDI/20/,LEXOT/21/,OUTP/0/
	DATA BLANK/32/,DIGITS/48,49,50,51,52,53,54,55,56,57,-99/
	DATA DQUOTE/34/,LASTP/22/,LBRACE/123/,LBRAK/91/
	DATA LOWALF/97,98,99,100,101,102,103,104,105,106,107,108,109,
     &		     110,111,112,113,114,115,116,117,118,119,120,121,
     &		     122,-99/
	DATA MINUS/45/,NAMPTR/1,7,14,17,22,26,29,37,42,49,55,61,67,74,
     &			       77,82,86,89,97,102,109,115/
	DATA RBRACE/125/,RBRAK/93/,SEMCOL/59/,SHARP/35/,SQUOTE/39/
	DATA TAB/9/
	DATA TABLE/66,82,69,65,75,-99,	  68,69,70,73,78,69,-99,
     &68,79,-99,    69,76,83,69,-99,	70,79,82,-99,	 73,70,-99,
     &73,78,67,76,85,68,69,-99,    78,69,88,84,-99,
     &82,69,80,69,65,84,-99,	85,78,84,73,76,-99,
     &87,72,73,76,69,-99,
     &98,114,101,97,107,-99,	100,101,102,105,110,101,-99,
     &100,111,-99,    101,108,115,101,-99,    102,111,114,-99,
     &105,102,-99,    105,110,99,108,117,100,101,-99,
     &110,101,120,116,-99,    114,101,112,101,97,116,-99,
     &117,110,116,105,108,-99,	  119,104,105,108,101,-99/
	DATA UPALF/65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,
     &		    81,82,83,84,85,86,87,88,89,90,-99/
	DATA AND/46,65,78,68,46,-99/,CONTIN/67,79,78,84,73,78,85,69,-99/
	DATA DIG2/50/,DIG3/51/,DOSTR/68,79,-99/,EQ/46,69,81,46,-99/
	DATA IFNOT/73,70,40,46,78,79,84,46,-99/,GE/46,71,69,46,-99/
	DATA GOTO/71,79,84,79,-99/,GT/46,71,84,46,-99/
	DATA LE/46,76,69,46,-99/,LPAREN/40/,LT/46,76,84,46,-99/
	DATA NE/46,78,69,46,-99/,NOT/46,78,79,84,46,-99/
	DATA OR/46,79,82,46,-99/,RPAREN/41/,STAR/42/
	DATA TRUE/46,84,82,85,69,46,-99/,UNLINE/95/
	DATA ANDSGN/38/,EQUALS/61/,EXCLAM/33/,GRTHAN/62/,LTTHAN/60/
	DATA ORBAR/124/,UPARW/94/,COMMA/44/,PERCNT/37/
	END

C ----------------------------------------------------------------------------
C	MAINLINE FOR RATFOR

C	WRITTEN BY RYAN STANSIFER AND PETER PALIJ
C	LAST MODIFIED:	01-06-79
C			14-06-79

       PROGRAM RATMN
       INTEGER*2  IDS
       LOGICAL*1  BUFF (72), CHAR
       PARAMETER  BLANK=' ', CR="015

       GOTO 120

       IF (IDS .LE. 0)	GO TO 900

C	   STRIP OFF TRAILING CHARATERS

       I = 1
 100   CONTINUE
       CHAR = BUFF (I)
       IF (CHAR .EQ. BLANK)  GO TO 110
       IF (CHAR .EQ. CR)  GO TO 120
       BUFF(I) = BLANK
       I = I+1
       GO TO 100

 110   CONTINUE
       CALL CMDLN (BUFF, 40)
       GO TO 130

 120   CONTINUE

C      GET COMMAND LINE

       TYPE 550
 550   FORMAT ('$RAT>')

       READ (5,560,END=130)  (BUFF(I),I=1,40)
 560   FORMAT (40A1)

       CALL CMDLN (BUFF, 40)
       GO TO 120

 900   CONTINUE

C	    THIS PROGRAM WAS NOT PROPERLY ENVOKED

       TYPE 540, IDS
 540   FORMAT (' RAT WAS NOT PROPERLY ENVOKED.	IDS = ', I4)
       STOP  'ABNORMAL TERMINATION'
 130   CONTINUE
       END

C ----------------------------------------------------------------------------
C	SUBROUTINE PARSE

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	29-05-79   14-06-79
C			11-06-79   18-06-79

C	PARSE FIRST DETERMINES THE NATURE OF THE CURRENT TOKEN STRING,
C	THEN IT ARRANGES FOR THE PROPER FORTRAN COMMANDS TO BE WRITTEN.

C	VARIABLE   VALUE
C	--------   -----
C	BP	   PUSH BACK BUFFER POINTER.
C	EOF	   END-OF-FILE FLAG.
C	FILE	   CURRENT INCLUDE LEVEL.
C	I	   COUNTER.
C	J	   COUNTER.
C	LAB	   VARIABLE CONTAINING CURRENT LABEL NUMBER.
C	LABVAL	   LABEL STACK.
C	LBRACE	   LEFT BRACE CHARACTER.
C	LBRAK	   LEFT BRACKET CHARACTER.
C	LEXBR	   BREAK COMMAND FLAG.
C	LEXDI	   DIGIT FLAG.
C	LEXDO	   DO COMMAND FLAG.
C	LEXEL	   ELSE COMMAND FLAG.
C	LEXFO	   FOR COMMAND FLAG.
C	LEXIF	   IF COMMAND FLAG.
C	LEXNE	   NEXT COMMAND FLAG.
C	LEXOT	   OTHER FLAG.
C	LEXRE	   REPEAT COMMAND FLAG.
C	LEXSTR	   STRING TO BE PARSED.
C	LEXTYP	   LEXICAL TYPE STACK.
C	LEXUN	   UNTIL COMMAND FLAG.
C	LEXWH	   WHILE COMMAND FLAG.
C	NAME	   INCLUDE FILE STACK.
C	RBRACE	   RIGHT BRACE CHARACTER.
C	RBRAK	   RIGHT BRACKET CHARACTER.
C	SP	   STACK POINTER.
C	TOKEN	   CURRENT LEXICAL TYPE.

	SUBROUTINE PARSE(FILE,NAME)
	COMMON /CDEFIO/BP,BUF
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	INTEGER BP
	LOGICAL*1 BUF(72)
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	INTEGER FILE,I,J,LAB,LABVAL(50),LEXTYP(50),SP
	LOGICAL*1 LEXSTR(72),NAME(25,3),TOKEN
	LOGICAL*1 GETTOK,LEX
	DATA SP/1/

C	RESET PUSH BACK POINTER. USED TO KEEP PUSHED BACK EOFS FROM
C	CLOSING THE WRONG INCLUDE FILE.

	BP=0

C	GET THE FIRST TOKEN

	LEXTYP(1)=EOF
	TOKEN=LEX(LEXSTR)

C	PROCESS TOKEN FOR THE BEGINNING OF RATFOR STRINGS.

   10	IF( .NOT. (TOKEN .NE. EOF))GO TO 120
	IF(TOKEN .EQ. LEXDI)CALL LABELC(LEXSTR)
	IF(TOKEN .EQ. LEXDO)CALL DOCODE(LAB)
	IF( .NOT. (TOKEN .EQ. LEXEL))GO TO 30
	IF( .NOT. (LEXTYP(SP) .EQ. LEXIF))GO TO 20
	CALL ELSEIF(LABVAL(SP))
	GO TO 60
   20	CALL SYNERR(12HILLEGAL ELSE,12)
	GO TO 110
   30	IF(TOKEN .EQ. LEXFO)CALL FORCOD(LAB)
	IF(TOKEN .EQ. LEXIF)CALL IFCODE(LAB)
	IF( .NOT. (TOKEN .EQ. LEXIN))GO TO 37

C	STACK THE INCLUDE FILE NAME.

	FILE=FILE+1
	J=1
   33	IF( .NOT. (GETTOK(LEXSTR,72) .NE. NL))GO TO 36
	I=1
   35	IF( .NOT. (LEXSTR(I) .NE. EOS))GO TO 33
	IF(LEXSTR(I) .EQ. NL)GO TO 36
	NAME(J,FILE)=LEXSTR(I)
	I=I+1
	J=J+1
	GO TO 35

C	FLAG THE END OF THE INCLUDE FILE FOR THE SYSTEM WITH AN OCTAL
C	NULL

   36	NAME(J,FILE)="000
	RETURN
   37	IF(TOKEN .EQ. LEXRE)CALL REPEAT(LAB)
	IF( .NOT. (TOKEN .EQ. LEXUN))GO TO 50
	IF( .NOT. (LEXTYP(SP) .EQ. LEXRE))GO TO 40
	CALL UNTILC(LABVAL(SP))

C	NOTE: UNTILS DO NOT HAVE ANY FOLLOWING COMMANDS THAT MA
C	ATTACHED, SO IT IS TIME TO UNSTACK THE REPEAT AND ANYTHING
C	ELSE THAT IS UNSTACKABLE.

	SP=SP-1
	GO TO 100
   40	CALL SYNERR(13HILLEGAL UNTIL,13)
	GO TO 110
   50	IF(TOKEN .EQ. LEXWH)CALL WHILEC(LAB)

C	STACK FLAG IF THIS WAS THE BEGINNING OF A RATFOR STRING.

   60	IF( .NOT. (TOKEN .EQ. LEXDI .OR. TOKEN .EQ. LEXDO .OR. TOKEN
     &	    .EQ. LEXEL .OR. TOKEN .EQ. LEXIF .OR. TOKEN .EQ. LEXFO .OR.
     &	    TOKEN .EQ. LEXRE .OR. TOKEN .EQ.
     &	    LBRACE .OR. TOKEN .EQ. LBRAK .OR. TOKEN .EQ. LEXWH))GO TO 70
	SP=SP+1
	IF(SP .GT. 50)CALL ERROR(24HSTACK OVERFLOW IN PARSER,24)
	LEXTYP(SP)=TOKEN
	LABVAL(SP)=LAB
	GO TO 110

C	PROCESS THE TOKEN FOR THE END OF A RATFOR STRING.

   70	IF( .NOT. (TOKEN .EQ. RBRACE .OR. TOKEN .EQ. RBRAK))GO TO 90
	IF( .NOT. (LEXTYP(SP) .EQ. LBRACE .OR. LEXTYP(SP) .EQ.
     &	    LBRAK))GO TO 80
	SP=SP-1
	GO TO 100
   80	CALL SYNERR(30HILLEGAL RIGHT BRACE OR BRACKET,30)
	GO TO 100
   90	IF(TOKEN .EQ. LEXOT)CALL OTHERC(LEXSTR)
	IF(TOKEN .EQ. LEXBR .OR. TOKEN .EQ. LEXNE)CALL BRKNXT(SP,
     &	   LEXTYP,LABVAL,TOKEN)

C	SEMICOLONS ARE TREATED AS NEW LINE FLAGS IN EVERY WAY
C	EXCEPT THAT THEY ARE NOT COUNTED BY THE LINE COUNTER.

	IF( .NOT. (TOKEN .EQ. SEMCOL))GO TO 95
	CALL OUTDON
	GO TO 100
   95	IF(TOKEN .EQ. LEXDE)CALL DEFSET

C	ATTEMPT TO UNSTACK RATFOR COMMANDS.

  100	TOKEN=LEX(LEXSTR)
	CALL UNSTAK(SP,LEXTYP,LABVAL,TOKEN)
	GO TO 10
  110	TOKEN=LEX(LEXSTR)
	GO TO 10
  120	IF(SP .NE. 1)CALL SYNERR(14HUNEXPECTED EOF,14)

C	UNSTACK INCLUDE FILES.

	FILE=FILE-1
	RETURN
	END

C ----------------------------------------------------------------------------
C	FUNCTION LEX

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	28-05-79
C			11-06-79

C	LEX RETURNS THE LEXICAL NATURE OF THE TOKEN.

C	VARIABLE   VALUE
C	--------   -----
C	EOF	   END-OF-FILE MARK.
C	EOS	   END-OF-STRING.
C	LBRACE	   LEFT BRACE CHARACTER.
C	LBRAK	   LEFT BRACKET.
C	LEXDI	   DIGIT FLAG.
C	LEXOT	   OTHER FLAG.
C	LEXSTR	   STRING TO BE CHECKED.
C	LTYPE	   REPORT OF TYPE OF CHARACTER.
C	NL	   NEW LINE FLAG.
C	RBRACE	   RIGHT BRACE CHARACTER.
C	RBRAK	   RIGHT BRACKET.
C	SEMCOL	   SEMICOLON CHARACTER.
C	T	   DUMMY VARIABLE.
C	YES	   YES FLAG.

	LOGICAL*1 FUNCTION LEX(LEXSTR)
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	LOGICAL*1 LEXSTR(72),LTYPE(2),T
	INTEGER ALLDIG,LOOKUP
	LOGICAL*1 GETTOK

C	GET THE NEXT TOKEN.

   10	T=GETTOK(LEXSTR,72)

C	FIRST CHARACTER IN TOKEN IS LEXICAL TYPE.

	LEX=LEXSTR(1)

C	IGNORE NEW LINE FLAGS.

	IF(LEX .EQ. NL)GO TO 10
	IF(LEX .EQ. EOF .OR. LEX .EQ. LBRACE .OR. LEX .EQ.
     &	   LBRAK .OR. LEX .EQ. RBRACE .OR. LEX .EQ. RBRAK
     &	   .OR. LEX .EQ. SEMCOL)RETURN

C	CHECK FOR ALL DIGITS IN TOKEN.

	IF( .NOT. (ALLDIG(LEXSTR) .EQ. YES))GO TO 20
	LEX=LEXDI
	RETURN

C	CHECK FOR RATFOR LEXICAL TYPE.

   20	IF( .NOT. (LOOKUP(LEXSTR,LTYPE) .EQ. YES))GO TO 30
	LEX=LTYPE(1)
	RETURN

C	LEXICAL TYPE IS 'OTHER'.

   30	LEX=LEXOT
	RETURN
	END

C ----------------------------------------------------------------------------
C	FUNCTION GETTOK

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	27-05-79
C			11-06-79

C	GETTOK BREAKS THE INPUT INTO ALPHANUMERIC STRINGS, QUOTED
C	STRINGS, AND SINGLE NON-ALPHANUMERIC CHARACTERS. IT ALSO STRIPS
C	OUT BLANKS, TABS, AND COMMENTS THAT SEPARATE TOKENS.

C	VARIABLE   VALUE
C	--------   -----
C	ALPHA	   ALPHANUMERIC FLAG
C	BLANK	   THE BLANK CHARACTER.
C	C	   CURRENT CHARACTER
C	DIGIT	   NUMERIC FLAG
C	DQUOTE	   THE DOUBLE QUOTE CHARACTER.
C	EOF	   END-OF-FILE FLAG.
C	EOS	   END-OF-STRING FLAG.
C	FLG	   FLAG FOR WHETHER A PERCENT CHARACTER MEANS LITERAL.
C	I	   COUNTER.
C	LETTER	   ALPHABETIC FLAG.
C	LEXSTR	   THE LEXICAL STRING UNDER CONSIDERATION.
C	LINECT	   LINE COUNTER.
C	NL	   THE NEW LINE FLAG.
C	PERCNT	   PERCENT CHARACTER.
C	SHARP	   THE SHARP CHARACTER.
C	SQUOTE	   THE SINGLE QUOTE CHARACTER.
C	TAB	      THE TAB CHARACTER.
C	TOKSIZ	   NUMBER OF CHARACTERS IN THE CURRENT TOKEN.

	LOGICAL*1 FUNCTION GETTOK(LEXSTR,TOKSIZ)
	COMMON /CLINE/LINECT
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	INTEGER LINECT
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	INTEGER FLG,TOKSIZ
	LOGICAL*1 C,LEXSTR(72)
	LOGICAL*1 NGETC, TYPE
	DATA FLG/1/

C	GET THE NEXT CHARACTER WHILE CHECKING FOR THE EOF; IGNORE
C	BLANKS AND TABS.

   10	IF( .NOT. (NGETC(C) .NE. EOF))GO TO 20

C	SUPRESS BLANKS AND TABS.

	IF( .NOT. (C .NE. BLANK .AND. C .NE. TAB))GO TO 10

C	PROCESS LITERAL LINES.

	IF( .NOT. (FLG .EQ. 1 .AND. C .EQ. PERCNT))GO TO 20
	CALL LITERL(LEXSTR)
	I=1
	GO TO 100
   20	CALL PUTBAK(C)
	FLG=0

C	CHECK TOKEN FOR ALPHANUMERIC TYPE.

	I=1
   30	IF( .NOT. (I .LT. TOKSIZ-1))GO TO 40
	GETTOK=TYPE(NGETC(LEXSTR(I)))
	IF(GETTOK .NE. LETTER .AND. GETTOK .NE. DIGIT)GO TO 40
	I=I+1
	GO TO 30

C	CHECK FOR ILLEGAL TOKEN SIZE.

   40	IF(I .GE. TOKSIZ-1)CALL SYNERR(14HTOKEN TOO LONG,14)

C	CHECK AND REPORT ALPHANUMERIC TOKEN.

	IF( .NOT. (I .GT. 1))GO TO 50
	CALL PUTBAK(LEXSTR(I))
	LEXSTR(I)=EOS
	GETTOK=ALPHA
	GO TO 100

C	CHECK AND ASSURE SET OF QUOTES, SINGLE OR DOUBLE.

   50	IF( .NOT. (LEXSTR(1) .EQ. SQUOTE .OR. LEXSTR(1) .EQ. DQUOTE))
     &		 GO TO 80
	I=2
   60	IF( .NOT. (NGETC(LEXSTR(I)) .NE. LEXSTR(1)))GO TO 100
	IF( .NOT. (LEXSTR(I) .EQ. NL .OR. I .GE. TOKSIZ-1))GO TO 70
	CALL SYNERR(13HMISSING QUOTE,13)
	LEXSTR(I)=LEXSTR(1)
	CALL PUTBAK(NL)
	GO TO 100
   70	I=I+1
	GO TO 60

C	CHECK AND IGNORE SHARPS AND THE COMMENTS FOLLOWING.

   80	IF( .NOT. (LEXSTR(1) .EQ. SHARP))GO TO 100
   90	IF(NGETC(C) .NE. NL)GO TO 90
	LEXSTR(1)=NL
	GETTOK=NL

C	LABEL END OF TOKEN.

  100	LEXSTR(I+1)=EOS

C	ON NEW LINE, INCREMENT LINE COUNT, SET LITERAL FLAG.

	IF( .NOT. (LEXSTR(1) .EQ. NL))GO TO 110
	LINECT=LINECT+1
	FLG=1
  110	RETURN
	END

C ----------------------------------------------------------------------------
C	FUNCTION ALLDIG

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	28-05-79

C	ALLDIG CHECKS FOR A NUMERIC TOKEN.

C	VARIABLE   VALUE
C	--------   -----
C	DIGIT	   DIGIT FLAG.
C	EOS	   END-OF-STRING MARK.
C	I	   COUNTER
C	NO	   NO FLAG.
C	STR	   BUFFER WITH STRING TO BE CHECKED.
C	YES	   YES FLAG.

	INTEGER FUNCTION ALLDIG(STR)
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	INTEGER I
	LOGICAL*1 STR(72)
	LOGICAL*1 TYPE

C	ASSUME NO UNTIL YES IS PROVEN.

	ALLDIG=NO
	IF(STR(1) .EQ. EOS)RETURN
	I=1

C	SCAN FOR ALL NUMERIC.

   10	IF( .NOT. (STR(I) .NE. EOS))GO TO 20
	IF(TYPE(STR(I)) .NE. DIGIT)RETURN
	I=I+1
	GO TO 10
   20	ALLDIG=YES
	RETURN
	END
C ----------------------------------------------------------------------------
C	SUBROUTINE BALPAR

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED: 01-06-79

C	BALPAR IS USED TO COLLECT AND OUTPUT THE CONDITIONAL PARTS OF
C	RATFOR EXPRESSIONS.  IN ADDITION IT CHECKS FOR BALANCED
C	PARENTHESES.

C	VARIABLE   VALUE
C	--------   -----
C	EOF	   END OF FILE FLAG.
C	EOS	   END OF STRING FLAG.
C	FLG	   FLAG FOR THE FOR CONDITIONAL.
C	LBRACE	   LEFT BRACE CHARACTER.
C	LBRAK	   LEFT BRACKET CHARACTER.
C	LPAREN	   LEFT PARENTHESES CHARACTER.
C	NLPAR	   NUMBER OF LEFT PARENTHESES COUNTER.
C	RBRACE	   RIGHT BRACE CHARACTER.
C	RBRAK	   RIGHT BRACKET CHARACTER.
C	RPAREN	   RIGHT PARENTHESES CHARACTER.
C	SEMCOL	   SEMI-COLON CHARACTER.
C	T	   TOKEN VALUE.
C	TOKEN	   CURRENT TOKEN STRING.
C	TRUE	   .TRUE. STRING.

	SUBROUTINE BALPAR
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	INTEGER FLG,NLPAR
	LOGICAL*1 T,TOKEN(72)
	LOGICAL*1 GETTOK
	DATA FLG/0/

C	FIND BEGINNING OF CONDITIONAL.

	T=GETTOK(TOKEN,72)
	IF( .NOT. (T .NE. LPAREN))GO TO 20
	IF( .NOT. (T .NE. SEMCOL))GO TO 10
	CALL SYNERR(18HMISSING LEFT PAREN,18)
	RETURN

C	NULL FOR CONDITIONAL IS ASSIGNED A TRUE VALUE.

   10	CALL OUTCH(LPAREN)
	T=GETTOK(TOKEN,72)
	FLG=1
	IF( .NOT. (T .EQ. SEMCOL))GO TO 20
	CALL OUTSTR(TRUE)
	CALL OUTCH(RPAREN)
	RETURN

C	OUTPUT CONDITIONAL

   20	CALL OUTSTR(TOKEN)
	NLPAR=1

C	CONTINUE OUTPUT OF CONDITIONAL AND BALANCE PARENTHESES.

   30	T=GETTOK(TOKEN,72)
	IF( .NOT. (T .EQ. SEMCOL .OR. T .EQ. LBRACE .OR. T .EQ. LBRAK
     &	    .OR. T .EQ. RBRACE .OR. T .EQ. RBRAK .OR. T .EQ. EOF))
     &	    GO TO 40
	CALL PUTBAK(TOKEN(1))
	GO TO 50
   40	IF(T .EQ. NL)TOKEN(1)=EOS
	IF(T .EQ. LPAREN)NLPAR=NLPAR+1
	IF(T .EQ. RPAREN)NLPAR=NLPAR-1
	CALL OUTSTR(TOKEN)
	IF( .NOT. (NLPAR .LE. 0))GO TO 30

C	CLOSE FOR CONDITIONALS.

   50	IF( .NOT. (FLG .EQ. 1))GO TO 60
	FLG=0
	CALL OUTCH(RPAREN)
	NLPAR=NLPAR-1

C	SUPRESS THE SEMICOLON IN FOR STRINGS.

	IF(TOKEN(1) .EQ. SEMCOL)T=NGETC(TOKEN(1))

C	CHECK PARENTHESES BALANCE.

   60	IF(NLPAR .NE. 0)
     &	   CALL SYNERR(34HMISSING PARENTHESES IN CONDITIONAL,34)
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE BRKNXT

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	BRKNXT PROCESS THE BREAK AND NEXT COMMANDS FOR LOOPS.

C	VARIABLE   VALUE
C	--------   -----
C	I	   COUNTER.
C	LABVAL	   LABEL VALUE STACK.
C	LEXBR	   BREAK FLAG.
C	LEXDO	   DO FLAG.
C	LEXNE	   NEXT FLAG.
C	LEXRE	   REPEAT FLAG.
C	LEXWH	   WHILE FLAG.
C	LEXTYP	   LEXICAL TYPE STACK.
C	SP	   STACK POINTER.
C	TOKEN	   CURRENT TOKEN TYPE.

	SUBROUTINE BRKNXT(SP,LEXTYP,LABVAL,TOKEN)
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	INTEGER I,LABVAL(50),LEXTYP(50),SP
	LOGICAL*1 TOKEN
	I=SP

C	FIND THE HIGHEST LEGAL BREAK/NEXT COMMAND.

   10	IF( .NOT. (I .GT. 0))GO TO 40

C	PROCESS BREAK/NEXT FOR DO AND WHILE STRINGS.

	IF( .NOT. (LEXTYP(I) .EQ. LEXDO .OR. LEXTYP(I) .EQ. LEXWH))
     &	    GO TO 30
	IF( .NOT. (TOKEN .EQ. LEXBR))GO TO 20
	CALL OUTGO(LABVAL(I)+1)
	RETURN
   20	CALL OUTGO(LABVAL(I))
	RETURN

C	PROCESS BREAK/NEXT FOR REPEAT STRINGS.

   30	IF( .NOT. (LEXTYP(I) .EQ. LEXRE))GO TO 35
	IF(TOKEN .EQ. LEXBR)CALL OUTGO(LABVAL(I)+2)
	IF(TOKEN .EQ. LEXNE)CALL OUTGO(LABVAL(I)+1)
	RETURN

C	PROCESS BREAK/NEXT FOR FOR STRINGS.

   35	IF( .NOT. (LEXTYP(I) .EQ. LEXFO))GO TO 37
	IF(TOKEN .EQ. LEXBR)CALL OUTGO(LABVAL(I)+3)
	IF(TOKEN .EQ. LEXNE)CALL OUTGO(LABVAL(I)+1)
	RETURN

C	CHECK THE NEXT LEVEL.

   37	I=I-1
	GO TO 10

C	ILLEGAL BREAK/NEXT.

   40	IF( .NOT. (TOKEN .EQ. LEXBR))GO TO 50
	CALL SYNERR(13HILLEGAL BREAK,13)
	RETURN
   50	CALL SYNERR(12HILLEGAL NEXT,12)
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE DEFSET

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	21-03-85	BY THOMAS SCHUETZ

C	DEFSET SETS UP THE DEFINE STACK WITH THE WORD THAT IS TO BE
C	DEFINED AND ITS DEFINITION

C	VARIABLE    VARIABLE
C	--------    --------
C	C	    CURRENT CHARACTER
C	COMMA	    COMMA CHARACTER
C	DEFPNT	    STACK POINTER FOR DEFSTK
C	DEFSTK	    THE STACK OF DEFINES AND THEIR DEFINITIONS
C	EOS	    END OF STRING FLAG
C	I	    COUNTER
C	J	    COUNTER
C	LPAREN	    LEFT PARENTHESES CHARACTER
C	NLPAR	    PARENTHESES COUNTER
C	RPAREN	    RIGHT PARENTHESES CHARACTER
C	STR	    CURRENT STRING

	SUBROUTINE DEFSET
	COMMON /RATDEF/DEFPNT,DEFSTK
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	INTEGER DEFPNT
	LOGICAL*1 DEFSTK(70,2,16)
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	INTEGER I,J,NLPAR
	LOGICAL*1 C,STR(72)
	LOGICAL*1 GETTOK,NGET

	DEFPNT=DEFPNT+1

C	CHECK NUMBER OF DEFINED ALPHA NUMERIC STRINGS

	IF( DEFPNT .GT. 70 ) THEN
	    CALL SYNERR(20HTOO MANY DEFINITIONS,20)
	    DEFPNT=DEFPNT-1
	    RETURN
	END IF

C	LOAD STRING TO BE DEFINED

	C=GETTOK(STR,72)
	J=1
	I=1

C	CHECK STRING LENGTH

   30	IF( J .GT.15 ) THEN
	    CALL SYNERR(19HDEFINITION TOO LONG,19)
	    DEFPNT=DEFPNT-1
	    RETURN
	END IF
	IF( STR(I) .NE. EOS ) THEN
	    DEFSTK(DEFPNT,1,J)=STR(I)
	    I=I+1
	    J=J+1
	    GOTO 30
	END IF

C	FLAG END OF STRING

   	DEFSTK(DEFPNT,1,J)=EOS

C	GET THE STRING TO BE OUTPUT

	C=GETTOK(STR,72)
	J=1
	I=1
	IF (C .EQ. NL) THEN
	    DEFSTK(DEFPNT,2,J)=EOS
	    RETURN
	END IF

C	LOAD STRING

   70	IF( .NOT. (J .LT. 16))GO TO 80
	IF (STR(I) .EQ. EOS) THEN
	    DEFSTK(DEFPNT,2,J)=EOS
	    RETURN
	END IF
	DEFSTK(DEFPNT,2,J)=STR(I)
	I=I+1
	J=J+1
	GO TO 70

C	TRUNCATE STRINGS THAT ARE TOO LONG

   80	CALL SYNERR(34HDEFINE PRODUCT TOO LONG, TRUNCATED,34)
	DEFSTK(DEFPNT,2,16)=EOS
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE DOCODE

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	DOCODE GENERATES THE STRING DO ##### FOLLOWED BY THE USER'S
C	STATEMENT.

C	VARIABLE   VALUE
C	--------   -----
C	DOSTR	   DO STRING.
C	LAB	   CURRENT LABEL NUMBER.

	SUBROUTINE DOCODE(LAB)
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	INTEGER LAB
	INTEGER LABGEN
	CALL OUTTAB
	CALL OUTSTR(DOSTR)
	LAB=LABGEN(2)
	CALL OUTNUM(LAB)
	CALL EATUP
	CALL OUTDON
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE DOSTAT

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	DOSTAT FINISHES UP A DO LOOP.

C	VARIABLE   VALUE
C	--------   -----
C	LAB	   CURRENT LABEL NUMBER.

	SUBROUTINE DOSTAT(LAB)
	INTEGER LAB
	CALL OUTCON(LAB)
	CALL OUTCON(LAB+1)
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE EATUP

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	EATUP OUTPUTS THE REMAINDER OF A STRING.

C	VARIABLE   VALUE
C	--------   -----
C	EOF	   END OF FILE FLAG.
C	LBRACE	   LEFT BRACE CHARACTER.
C	LBRAK	   LEFT BRACKET CHARACTER.
C	LPAREN	   LEFT PARENTHESES CHARACTER.
C	NL	   NEW LINE FLAG.
C	NLPAR	   NUMBER OF LEFT PARENTHESES COUNTER.
C	RBRACE	   RIGHT BRACE CHARACTER.
C	RBRAK	   RIGHT BRACKET CHARACTER.
C	RPAREN	   RIGHT PARENTHESES CHARACTER.
C	SEMCOL	   SEMI-COLON CHARACTER.
C	T	   CURRENT TOKEN TYPE.
C	TOKEN	   CURRENT TOKEN STRING.

	SUBROUTINE EATUP
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	INTEGER NLPAR
	LOGICAL*1 T,TOKEN(72)
	LOGICAL*1 GETTOK
	NLPAR=0

C	CHECK FOR LEGAL RATFOR FORM.

   10	T=GETTOK(TOKEN,72)
	IF(T .EQ. SEMCOL .OR. T .EQ. NL)GO TO 40
	IF( .NOT. (T .EQ. RBRACE .OR. T .EQ. RBRAK .OR. T .EQ. LBRACE
     &	    .OR. T .EQ. LBRAK))GO TO 20
	CALL PUTBAK(TOKEN(1))
	GO TO 40
   20	IF( .NOT. (T .EQ. EOF))GO TO 30
	CALL SYNERR(14HUNEXPECTED EOF,14)
	CALL PUTBAK(TOKEN(1))
	GO TO 40

C	COUNT THE PARANTHESES AND OUTPUT THE STRING.

   30	IF(T .EQ. LPAREN)NLPAR=NLPAR+1
	IF(T .EQ. RPAREN)NLPAR=NLPAR-1
	CALL OUTSTR(TOKEN)
	IF( .NOT. (NLPAR .LT. 0))GO TO 10

C	CHECK PARENTHESES BALANCE.

   40	IF(NLPAR .NE. 0)CALL SYNERR(22HUNBALANCED PARENTHESES,22)
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE ELSEIF

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED: 01-06-79

C	ELSEIF FINISHES OFF AN IF STATEMENT.

C	VARIBLE   VALUE
C	-------   -----
C	LAB	  CURRENT LABEL VALUE.

	SUBROUTINE ELSEIF(LAB)
	INTEGER LAB
	CALL OUTGO(LAB+1)
	CALL OUTCON(LAB)
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE ERROR

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED: 27-05-79

C	ERROR REPORTS THE ERROR TO THE ERROR FILE AND THEN ABORTS.

C	VARIABLE   VALUE
C	--------   -----
C	ERRFIL	   STANDARD FORTRAN ERROR MESSAGE FILE CODE.
C	LNGTH	   LENGTH OF MESSAGE.
C	MSG	   MESSAGE BUFFER.

	SUBROUTINE ERROR(MSG,LNGTH)
	COMMON /RATFIO/ERRFIL,STDIN,STDOUT
	INTEGER ERRFIL,STDIN,STDOUT
	INTEGER LNGTH
	LOGICAL*1 MSG(LNGTH)

C	ERRFIL IS THE SYSTEM'S ERROR MESSAGE FILE CODE.

	WRITE(ERRFIL,5)MSG
    5	FORMAT(1X,72A1)
	STOP
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE FORCOD

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	FORCOD GENERATES THE BEGINNING OF A FOR LOOP.
C	THE FORM IS:
C		     INITIAL CONDITION
C	       ###   CONTINUE
C		     IF(.NOT.(CONDITIONAL))GOTO###+3
C		     GOTO###+2
C	       ###+1 CONTINUE
C		     REINITIALIZATION
C		     GOTO###
C	       ###+2 CONTINUE

C	***NOTE: A BLANK LINE IS OUTPUT WHEN EITHER THE INITIAL CONDITION
C		 OR THE REINITIALIZATION ARE NULL. IF THE CONDITIONAL
C		 IS NULL, A .TRUE. IS ISSUED.

C	VARIABLE   VALUE
C	--------   -----
C	EOF	   END OF FILE FLAG.
C	LAB	   CURRENT LABEL VALUE.
C	LBRACE	   LEFT BRACE CHARACTER.
C	LBRAK	   LEFT BRACKET CHARACTER.
C	NL	   NEW LINE FLAG.
C	NLPAR	   PARENTHESES COUNTER.
C	RBRACE	   RIGHT BRACE CHARACTER.
C	RBRAK	   RIGHT BRACKET CHARACTER.
C	T	   CURRENT TOKEN TYPE.
C	TOKEN	   CURRENT TOKEN.

	SUBROUTINE FORCOD(LAB)
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	INTEGER LAB,NLPAR
	LOGICAL*1 T,TOKEN(72)
	INTEGER LABGEN
	LOGICAL*1 GETTOK
	LAB=LABGEN(4)
	T=GETTOK(TOKEN,72)

C	CHECK FOR LEGAL FOR FORM.

	IF( .NOT. (T .NE. LPAREN))GO TO 10
	CALL SYNERR(16HILLEGAL FOR FORM,16)
	RETURN

C	OUTPUT INITIAL CONDITION.

   10	CALL OUTTAB
   15	T=GETTOK(TOKEN,72)
	IF(TOKEN(1) .EQ. SEMCOL)GO TO 20
	CALL OUTSTR(TOKEN)
	GO TO 15

C	OUTPUT CONDITIONAL.

   20	CALL OUTDON
	CALL PUTBAK(TOKEN(1))
	CALL OUTCON(LAB)
	CALL IFGO(LAB+3)
	CALL OUTGO(LAB+2)
	CALL OUTCON(LAB+1)
	CALL OUTTAB

C	OUTPUT THE REINITIALIZATION.

	NLPAR=1
   30	T=GETTOK(TOKEN,72)
	IF( .NOT. (T .EQ. RPAREN))GO TO 40
	NLPAR=NLPAR-1
	IF(NLPAR .EQ. 0)GO TO 70
	CALL OUTSTR(TOKEN)
	GO TO 30
   40	IF( .NOT. (T .EQ. LPAREN))GO TO 50
	NLPAR=NLPAR+1
	CALL OUTSTR(TOKEN)
	GO TO 30
   50	IF( .NOT. (T .EQ. EOF .OR. T .EQ. NL .OR. T .EQ. SEMCOL .OR.
     &	    T .EQ. LBRACE .OR. T .EQ. LBRAK .OR. T .EQ. RBRACE .OR.
     &	    T .EQ. RBRAK))GO TO 60
	IF(NLPAR .EQ. 0)GO TO 70
	CALL SYNERR(22HUNBALANCED PARENTHESES,22)
	GO TO 70
   60	CALL OUTSTR(TOKEN)
	GO TO 30
   70	CALL OUTDON
	CALL OUTGO(LAB)
	CALL OUTCON(LAB+2)
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE FORSTA

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	FORSTA FINISHES UP THE FOR LOOP.

C	VARIABLE   VALUE
C	--------   -----
C	LAB	   CURRENT LABEL NUMBER.

	SUBROUTINE FORSTA(LAB)
	INTEGER LAB
	CALL OUTGO(LAB+1)
	CALL OUTCON(LAB+3)
	RETURN
	END

C ----------------------------------------------------------------------------
C	FUNCTION GET

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	27-05-79

C	GETC RETURNS THE VALUE OF THE CURRENT CHARACTER IN
C	THE CURRENT INPUT BUFFER.

C	VARIABLE   VALUE
C	--------   -----
C	BUF	   ARRAY CONTAINING THE CURRENT INPUT BUFFER.  ONE
C		      INPUT IMAGE PLUS ONE LONG.
C	C	   CURRENT INPUT CHARACTER.
C	EOF	   END-OF-FILE CHARACTER.
C	I	   COUNTER.
C	LASTC	   CURRENT CHARACTER POSITION POINTER.
C	NL	   NEW LINE FLAG.
C	STDIN	   STANDARD FORTRAN INPUT DEVICE CODE.

	LOGICAL*1 FUNCTION GETC(C)
	COMMON /RATFIO/ERRFIL,STDIN,STDOUT
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	INTEGER ERRFIL,STDIN,STDOUT
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	INTEGER I,LAST
	LOGICAL*1 BUF(73),
	DATA LASTC/73/
	BUF(73)=NL
	LASTC=LASTC+1

C	DETERMINE IF A NEW INPUT LINE IS NEEDED.

	IF( .NOT. (LASTC .GT. 73))GO TO 10
	READ(STDIN,5,END=20)(BUF(I),I=1,72)

C	STDIN IS THE SYSTEM'S STANDARD INPUT FILE CODE, 72 IS ONE IMAGE.

    5	FORMAT(72A1)
	LASTC=1

C	EXTRACT NEXT CHARACTER.

   10	C=BUF(LASTC)
	GETC=
	RETURN

C	END OF FILE OPTION.

   20	C=EOF
	GETC=EOF
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE IFCODE

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	IFCODE GENERATES THE LABELS FOR AN IF AND ARRANGES FOR THE
C	IF STATEMENT TO BE MADE.

C	VARIABLE   VALUE
C	--------   -----
C	LAB	   CURRENT LABEL NUMBER.

	SUBROUTINE IFCODE(LAB)
	INTEGER LAB
	INTEGER LABGEN
	LAB=LABGEN(2)
	CALL IFGO(LAB)
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE IFGO

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	IFGO GENERATES THE STRING IF(.NOT. THEN INSERTS THE USER'S
C	CONDITIONAL, AND FINISHES WITH )GOTO######

C	VARIABLE   VALUE
C	--------   -----
C	IFNOT	   IF(.NOT. STRING.
C	LAB	   CURRENT LABEL VALUE.
C	RPAREN	   RIGHT PARENTHESES CHARACTER.

	SUBROUTINE IFGO(LAB)
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	INTEGER LAB
	CALL OUTTAB
	CALL OUTSTR(IFNOT)
	CALL BALPAR
	CALL OUTCH(RPAREN)
	CALL OUTGO(LAB)
	RETURN
	END

C ----------------------------------------------------------------------------
C	FUNCTION INDEX

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED: 27-05-79

C	INDEX SCANS THE SUPPLIED LIST OF CHARACTERS LOOKING FOR THE
C	DESIRED CHARACTER.  IF NOT FOUND RETURNS A NULL.

C	VARIABLE   VALUE
C	--------   -----
C	C	   CURRENT CHARACTER.
C	EOS	   END-OF-STRING FLAG.
C	STR	   ARRAY TO BE CHECKED AGAINST.

	INTEGER FUNCTION INDEX(STR,C)
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 C,STR(30)
	INDEX=1

C	MAKE THE COMPARISON TEST.

   10	IF( .NOT. (STR(INDEX) .NE. EOS))GO TO 20
	IF(STR(INDEX) .EQ. C)RETURN
	INDEX=INDEX+1
	GO TO 10

C	NO MATCH FOUND.

   20	INDEX=0
	RETURN
	END

C ----------------------------------------------------------------------------
C	FUNCTION ITO

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	27-05-79

C	ITOC CONVERTS AN INTEGER TO ITS CHARACTER EQUIVALENT.

C	VARIABLE   VALUE
C	--------   -----
C	D	   DUMMY VARIABLE.
C	DIGITS	   ARRAY CONTAINING THE CHARACTER VERSIONS OF THE
C			NUMBERS.
C	I	   COUNTER.
C	INT	   THE INTEGER TO BE CONVERTED.
C	INTVAL	   THE ABSOLUTE VALUE OF THE INTEGER TO BE CONVERTED.
C	J	   COUNTER.
C	K	   DUMMY VARIABLE.
C	MINUS	   THE MINUS SIGN.
C	STR	   OUTPUT CHARACTERS.
C	SIZE	   SIZE OF THE OUTPUT ARRAY.

	INTEGER FUNCTION ITOC(INT,STR,SIZE)
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	INTEGER D,I,INT,INTVAL,J,SIZE
	LOGICAL*1 K,STR(SIZE)
	INTEGER IABS,IMOD

C	THE CHARACTER STRING IS LOADED IN THE REVERSE NUMERICAL ORDER.


C	IABS IS A MACHINE DEPENDENT ROUTINE TO DETERMINE THE
C	ABSOLUTE VALUE OF THE GIVEN QUIANTITY.

	INTVAL=IABS(INT)
	STR(1)=EOS
	I=1
   10	I=I+1

C	IMOD IS A MACHINE DEPENDENT ROUTINE TO DETERMINE THE
C	REMAINDER OF THE FIRST QUANTITY AFTER IT IS DIVIDE BY
C	SECOND QUANTITY.

	D=IMOD(INTVAL,10)
	STR(I)=DIGITS(D+1)
	INTVAL=INTVAL/10
	IF( .NOT. (INTVAL .EQ. 0 .OR. I .GE. SIZE))GO TO 10
	IF( .NOT. (INT .LT. 0 .AND. I .LT. SIZE))GO TO 20
	I=I+1
	STR(I)=MINUS

C	RETURN NUMBER OF CHARACTERS (DIGITS), NOT INCLUDING THE EOS.

  C=I-1
	J=1

C	REVERSE THE ORDER OF THE CHARACTERS.

   30	IF( .NOT. (J .LT. I))GO TO 40
	K=STR(I)
	STR(I)=STR(J)
	STR(J)=K
	I=I-1
	J=J+1
	GO TO 30
   40	RETURN
	END
C  **** BISHIERHER UND NICHT WEITER ****
C ----------------------------------------------------------------------------
C	SUBROUTINE LABEL

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	LABELC OUTPUTS USER DESIGNATED LABELS.

C	VARIABLE   VALUE
C	--------   -----
C	DIG2	   THE NUMBER 2.
C	DIG3	   THE NUMBER 3.
C	LEXSTR	   STRING TO BE OUTPUT.

	SUBROUTINE LABELC(LEXSTR)
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	LOGICAL*1 LEXSTR(72)
	INTEGER LENGTH

C	CHECK FOR USER-RATFOR LABEL CONFLICT POTENTIAL.

	IF(LENGTH(LEXSTR) .EQ. 5 .AND. LEXSTR(1) .EQ. DIG2 .AND.
     &	   LEXSTR(2) .EQ. DIG3)
     &	   CALL SYNERR(32HWARNING: POSSIBLE LABEL CONFLICT,32)
	CALL OUTSTR(LEXSTR)
	CALL OUTTAB
	RETURN
	END

C ----------------------------------------------------------------------------
C	FUNCTION LABGEN

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	LABGEN GENERATES THE NEXT LABEL STARTIFG FROM 23000.

C	VARIABLE   VALUE
C	--------   -----
C	LABEL	   CURRENT LABEL NUMBER.
C	N	   NUMBER OF LABEL TO BE USED.

	INTEGER FUNCTION LABGEN(N)
	DATA LABEL/23000/
	LABGEN=LABEL
	LABEL+N
	RETURN
	END

C ----------------------------------------------------------------------------
C	FUNCTION LENGTH

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED: 06-06-79

C	LENGTH DETERMINES THE LENGTH OF THE CHARACTER STRING SUBMITTED.

C	VARIABLE   VALUE
C	--------   -----
C	EOS	   END OF STRING FLAG.
C	STR	   BUFFER TO BE MEASURED.

	INTEGER FUNCTION LENGTH(STR)
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 STR(72)
	LENGTH=0
   10	IF( .NOT. (STR(LENGTH+1) .NE. EOS))GO TO 20
	LENGTH=LENGTH+1
	GO TO 10
   20	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE LITERL

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	21-06-79

C	LITERL TAKES THE INPUT STRING AS IS AND OUTPUTS IT WITH THE
C	LEAD PERCENT (%) SUPRESSED.

C	VARIABLE    VALUE
C	--------    -----
C	C	    CURRENT CHARACTER.
C	NL	    NEW LINE FLAG.
C	STR	    RETURN ARRAY.

	SUBROUTINE LITERL(STR)
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	LOGICAL*1 C,STR(72)
	LOGICAL*1 NGET
	IF(NGETC(C) .NE. PERCNT)CALL OUTCH(C)
   10	IF( .NOT. (NGETC(C) .NE. NL))GO TO 20
	CALL OUTCH(C)
	GO TO 10
   20	STR(1)=NL
	CALL OUTDON
	RETURN
	END

C ----------------------------------------------------------------------------
C	FUNCTION LOOKUP

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	 28-05-79

C	LOOKUP COMPARES THE SUBMITTED STRING WITH THE
C	STRINGS IN ITS TABLE AND RETURN A YES OR NO ANSWER AND
C	THE FIRST CHARACTER OF THE STRING.

C	VARIABLE   VALUE
C	--------   -----
C	DEFN	   RETURNED CHARACTER AND A EOS
C	EOS	   END-OF-STRING CHARACTER.
C	I	   COUNTER.
C	J	   COUNTER.
C	K	   COUNTER.
C	LASTP	   INDIRECT POINTER TO THE BEGINNING OF THE
C			     LATEST TABLE ENTRY.
C	NAME	   STRING TO CHECKED.
C	NAMPTR	   POINTER TABLE TO THE BEGINNING OF THE TABLE
C			     ENTRIES.
C	NO	   NO FLAG.
C	TABLE	   TABLE CONTAINING THE POSSIBLE MATCHES.  TABLE
C			     STRINGS 1 TO 11 ARE THE UPPERCASE RATFOR
C			     KEY WORDS, STRINGS 12 TO 22 ARE THE LOWER
C			     CASE RATFOR STRINGS.
C	YES	   YES FLAG.

	INTEGER FUNCTION LOOKUP(NAME,DEFN)
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	INTEGER I,J,K
	LOGICAL*1 DEFN(2),NAME(72)

C	BEGIN WITH THE LATEST ENTRY AND SEARCH
C	BACKWARDS.

	I=LASTP
   10	IF( .NOT. (I .GT. 0))GO TO 50

C	LOCATE THE BEGINNING OF THE CHARACTER STRINGS IN THE TABLE.

	J=NAMPTR(I)
	K=1

C	CHECK FOR MATCH.

   20	IF( .NOT. (NAME(K).EQ.TABLE(J) .AND. NAME(K) .NE. EOS))
     &		 GO TO 30
	J=J+1
	K=K+1
	GO TO 20
   30	IF( .NOT. (NAME(K) .EQ. TABLE(J)))GO TO 40

C	RETURN THE LEXICAL TYPE.  1 <= I <= 11 ARE THE UPPERCASE
C	VERSIONS OF THE RATFOR KEY-WORDS, 12 <= I <=22 ARE THE
C	LOWER CASE VERSIONS OF THE RATFOR KEYWORDS.  THE UPPER CASE
C	STRING ORDER MATCHES THE LEXICAL FLAG SETTINGS FOR THE RATFOR
C	KEY WORDS.  (SEE BLOCK DATA, DATA SETTINGS FOR LEX-- CONSTANTS)

	IF(I .GT. 11)I=I-11
	DEFN(1)=I
	DEFN(2)=EOS
	LOOKUP=YES
	RETURN
   40	I=I-1
	GO TO 10

C	NO MATCH.

   50	LOOKUP=NO
	RETURN
	END

C ----------------------------------------------------------------------------
C	FUNCTION NGET

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	27-05-79

C	NGETC PERMITS BACK TRACKING WITH THE INPUT STRING.

C	VARIABLE   VALUE
C	--------   -----
C	BP	   BUFFER POINTER.
C	BUF	   ARRAY WITH THE BACKED CHARACTERS
C	C	   CURRENT CHARACTER.
C	EOF	   END-OF-FILE FLAG.

	LOGICAL*1 FUNCTION NGETC(C)
	COMMON /CDEFIO/BP,BUF
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	INTEGER BP
	LOGICAL*1 BUF(5)
	LOGICAL*1 
	LOGICAL*1 GET
	IF( .NOT. (BP .GT. 0))GO TO 10

C	LOAD BACKED-UP CHARACTER.

	C=BUF(BP)
	GO TO 20

C	GET THE NEW CHARACTER AND RECORD IT.

   10	BP=1
	BUF(BP)=GETC(C)
   20	IF(C .NE. EOF)BP=BP-1

C	CHECK FOR FORCED CONTINUE (I.E., NOTHING HIGHER THAN NGET
C	KNOWS THAT THE LINE WAS CONTINUED.

	IF( .NOT. (C .EQ. UNLINE))GO TO 40
   30	IF(GETC(C) .EQ. NL)GO TO 10
	GO TO 30

C	RETURN THE NEXT CHARACTER.

   40	NGETC=
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE OUTCH

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	OUTCH LOADS ONE CHARACTER AT A TIME INTO THE OUTPUT STRING.
C	THE STRING SIZE IS LIMITED TO 72 CHARACTERS, OR ONE OUTPUT
C	IMAGE.

C	VARIABLE   VALUE
C	--------   -----
C	BLANK	   THE BLANK CHARACTER.
C	C	   CURRENT CHARACTER.
C	I	   COUNTER.
C	OUTBUF	   OUTPUT STRING.
C	OUTP	   OUTPUT STRING POINTER.
C	STAR	   STAR CHARACTER.

	SUBROUTINE OUTCH(C)
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	INTEGER I
	LOGICAL*1 

C	AT THE END OF A LINE, OUTPUT THE LINE, ENTER A CONTINUE IN
C	COLUMN SIX OF THE NEXT LINE AND CONTINUE.

	IF( .NOT. (OUTP .GE. 72))GO TO 30
	CALL OUTDON
	I=1
   10	IF( .NOT. (I .LT. 6))GO TO 20
	OUTBUF(I)=BLANK
	I=I+1
	GO TO 10
   20	OUTBUF(6)=STAR
	OUTP=6

C	FOR A NEW LINE, FINISH IT UP.

   30	IF( .NOT. (C .EQ. NL))GO TO 50
	IF(OUTP .EQ. 0)GO TO 60
	CALL OUTDON
	RETURN

C	ADD THE CHARACTER TO THE OUTPUT STRING.

   50	OUTP=OUTP+1
	OUTBUF(OUTP)=
   60	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE OUTCON

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	OUTCON OUTPUTS THE STRING  ##### CONTINUE

C	VARIABLE   VALUE
C	--------   -----
C	CONTIN	   CHARACTER STRING CONTINUE.
C	N	   STATEMENT NUMBER.

	SUBROUTINE OUTCON(N)
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	INTEGER N
	IF(N .GT. 0)CALL OUTNUM(N)
	CALL OUTTAB
	CALL OUTSTR(CONTIN)
	CALL OUTDON
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE OUTDON

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	OUTDON ARRANGES FOR THE OUTPUT OF THE CURRENT OUTPUT STRING.

C	VARIABLE   VALUE
C	--------   -----
C	I	   COUNTER.
C	NL	   NEW LINE FLAG.
C	OUTBUF	   OUTPUT STRING.
C	OUTP	   OUTPUT STRING POINTER.

	SUBROUTINE OUTDON
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	OUTP=OUTP+1
	OUTBUF(OUTP)=NL
	IF(OUTP .LT. 8)GO TO 20
	I=1
   10	CALL PUTC(OUTBUF(I))
	I=I+1
	IF( .NOT. (I .GT. OUTP))GO TO 10
   20	OUTP=0
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE OUTGO

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	OUTGO OUTPUTS THE STRING GOTO#####.

C	VARIABLE   VALUE
C	--------   -----
C	GOTO	   GOTO STRING.
C	N	   STATEMENT NUMBER.

	SUBROUTINE OUTGO(N)
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	INTEGER N
	CALL OUTTAB
	CALL OUTSTR(GOTO)
	CALL OUTNUM(N)
	CALL OUTDON
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE OUTNUM

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	OUTNUM OUTPUTS A NUMBER AS A CHARACTER STRING.

C	VARIABLE   VALUE
C	--------   -----
C	CHARS	   NUMBER AS A CHARACTER STRING.
C	I	   COUNTER.
C	LEN	   LENGTH OF NUMBER.
C	N	   NUMBER TO BE OUTPUT.

	SUBROUTINE OUTNUM(N)
	INTEGER I,LEN,N
	LOGICAL*1 CHARS(72)
	INTEGER ITO
	LEN=ITOC(N,CHARS,72)
	I=1
   10	IF( .NOT. (I .LE. LEN))GO TO 20
	CALL OUTCH(CHARS(I))
	I=I+1
	GO TO 10
   20	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE OUTSTR

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	21-03-85
C	BY THOMAS SCHUETZ

C	OUTSTR OUTPUTS THE SUBMITTED STRING, IN THE PROCESS, CONVERTS
C	STRINGS INCLOSED IN QUOTES INTO HOLLERITH FORM, AND CONVERTS
C	== TO .EQ.
C	!= TO .NE.
C	^= TO .NE.
C	>= TO .GE.
C	=> TO .GE.
C	>> TO .GT.
C	>  TO .GT.
C	<= TO .LE.
C	=< TO .LE.
C	<< TO .LE.
C	<  TO .LT.
C	&& TO .AND.
C	&  TO .AND.
C	!! TO .OR
C	!  TO .OR.
C	-= TO .NOT.

C	VARIABLE   VALUE
C	--------   -----
C	AND	   .AND. STRING.
C	ANDSGN	   AND SIGN (&) CHARACTER.
C	C	   CURRENT CHARACTER.
C	D	   DUMMY CURRENT CHARACTER
C	D1	   DUMMY CURRENT CHARACTER
C	DQUOTE	   DOUBLE QUOTE CHARACTER
C	EOS	   END OF STRING FLAG.
C	EQ	   .EQ. STRING
C	EQUALS	   EQUALS (=) CHARACTER
C	EXCLAM	   EXCLAIMATION MARK (!) CHARACTER
C	GE	   .GE. STRING
C	GRTHAN	   GREATER THAN (>) CHARACTER
C	GT	   .GT. STRING
C	H	   ASCII H
C	I	   COUNTER
C	J	   COUNTER
C	LE	   .LE. STRING
C	LT	   .LT. STRING
C	LTTHAN	   LESS THAN (<) CHARACTER
C	NE	   .NE. STRING
C	NOT	   .NOT. STRING
C	OR	   .OR. STRING
C	ORBAR	   OR (|) CHARACTER
C	SQUOTE	   SINGLE QUOTE CHARACTER
C	STR	   STRING TO BE PUT OUT
C	UPARW	   UP ARROW (^) CHARACTER

	SUBROUTINE OUTSTR(STR)
	COMMON /RATDEF/DEFPNT,DEFSTK
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	INTEGER DEFPNT
	LOGICAL*1 DEFSTK(70,2,16)
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	INTEGER I,J
	LOGICAL*1 C,D,D1,H,STR(72)
	LOGICAL*1 NGET

C	LOAD UPPER CASE 'H'.

	H=UPALF(8)

C	DETERMINE IF STRING SHOULD BE REDEFINED.

 1000	I=DEFPNT
 1010	IF( .NOT. (I .NE. 0))GO TO 1070
	J=1

C	CHECK MATCHES CHARACTER BY CHARACTER UNTIL A NON-MATCH IS FOUND.

 1020	IF( .NOT. (J .LT. 16))GO TO 1040
	IF( .NOT. (STR(J) .NE. EOS .AND. DEFSTK(I,1,J) .NE. EOS))
     &	    GO TO 1040
	IF( .NOT. (STR(J) .EQ. DEFSTK(I,1,J)))GO TO 1030
	J=J+1
	GO TO 1020

C	NON-MATCH FOUND.

 1030	I=I-1
	GO TO 1010

C	CHECK THAT MATCH IS COMPLETELY CORRECT (i.e., LIF WILL NOT
C	MATCH LIFE).

 1040	IF( .NOT. (STR(J) .EQ. EOS .AND. DEFSTK(I,1,J) .EQ. EOS))
     &	    GO TO 1030

C	SUBSTITUTE THE STRING.

	J=1
 1050	IF( .NOT. (DEFSTK(I,2,J) .NE. EOS))GO TO 1060
	STR(J)=DEFSTK(I,2,J)
	J=J+1
	GO TO 1050

C	END OF STRING FLAG AND THEN RETEST DEFINITION JUST
C	ENTERED FOR REDIFINITION.

 1060	STR(J)=EOS
	GO TO 1000

C	BEGIN OUTPUT.

 1070	I=1
   10	IF( .NOT. (STR(I) .NE. EOS))GO TO 70
	C=STR(I)

C	PEEK AT THE NEXT CHARACTER.

	IF( .NOT. (STR(I+1) .EQ. EOS))GO TO 300
	D1=NGETC(D)

C	CONVERT == TO .EQ.

	IF( .NOT. (C .EQ. EQUALS .AND. D .EQ. EQUALS))GO TO 100
	CALL STRTWO(EQ)
	GO TO 70

C	CONVERT != OR ^= TO .NE.

  100	IF( .NOT. ((C .EQ. EXCLAM .OR. C .EQ. UPARW) .AND. D .EQ.
     &	    EQUALS))GO TO 110
	CALL STRTWO(NE)
	GO TO 70

C	CONVERT <> TO .NE.

  110	IF ( .NOT. (C .EQ. LTTHAN .AND. D .EQ. GRTHAN )) GOTO 120
	CALL STRTWO(NE)
	GOTO 70

C	CONVERT =^ TO .NE.

  120	IF ( .NOT. (C .EQ. EQUALS .AND. D .EQ. UPARW)) GOTO 130
	CALL STRTWO(NE)
	GOTO 70

C	CONVERT >= TO .GE.

  130	IF( .NOT. (C .EQ. GRTHAN .AND. D .EQ. EQUALS))GO TO 140
	CALL STRTWO(GE)
	GO TO 70

C 	CONVERT => TO .GE.

  140	IF ( .NOT. (C .EQ. EQUALS .AND. D .EQ. GRTHAN)) GOTO 150
	CALL STRTWO(GE)
	GOTO 70

C	CONVERT >> TO .GT.

  150	IF ( .NOT. (C .EQ. GRTHAN .AND. D .EQ. GRTHAN )) GOTO 160
	CALL STRTWO(GT)
	GOTO 70

C	CONVERT >  TO .GT.

  160	IF( .NOT. (C .EQ. GRTHAN))GO TO 170
	CALL STRTWO(GT)
	CALL PUTBAK(D)
	GO TO 70

C	CONVERT <= TO .LE.

  170	IF( .NOT. (C .EQ. LTTHAN .AND. D .EQ. EQUALS))GO TO 180
	CALL STRTWO(LE)
	GO TO 70

C	CONVERT =< TO .LE.

  180	IF ( .NOT. (C .EQ. EQUALS .AND. D .EQ. LTTHAN)) GOTO 190
	CALL STRTWO(LE)
	GOTO 70

C	CONVERT << TO .LT.

  190	IF ( .NOT. (C .EQ. LTTHAN .AND. D .EQ. LTTHAN)) GOTO 200
	CALL STRTWO(LT)
	GOTO 70

C	CONVERT < TO .LT.

  200	IF( .NOT. (C .EQ. LTTHAN))GO TO 210
	CALL STRTWO(LT)
	CALL PUTBAK(D)
	GO TO 70

C	CONVERT | TO .OR.

  210	IF( .NOT. (C .EQ. ORBAR))GO TO 220
	CALL STRTWO(OR)
	CALL PUTBAK(D)
	GO TO 70

C	CONVERT !! TO .OR.

  220	IF ( .NOT. (C .EQ. EXCLAM .AND. D .EQ. EXCLAM)) GOTO 230
 	CALL STRTWO(OR)
	GOTO 70

C	CONVERT !  TO .OR

  230	IF ( .NOT. (C .EQ. EXCLAM)) GOTO 240
	CALL STRTWO(OR)
	CALL PUTBAK(D)
	GOTO 70	

C	CONVERT && TO .AND.

  240	IF ( .NOT. (C .EQ. ANDSGN .AND. D .EQ. ANDSGN)) GOTO 250
	CALL STRTWO(AND)
	GOTO 70

C	CONVERT & TO .AND.

  250	IF( .NOT. (C .EQ. ANDSGN))GO TO 260
	CALL STRTWO(AND)
	CALL PUTBAK(D)
	GO TO 70

C	CONVERT -= TO .NOT.

  260	IF( .NOT. (C .EQ. MINUS .AND. D .EQ. EQUALS))GO TO 270
	CALL STRTWO(NOT)
	GO TO 70

C 	CONVERT ^  TO .NOT.

  270	IF ( .NOT. (C .EQ. UPARW)) GOTO 280
	CALL STRTWO(NOT)
	CALL PUTBAK(D)
	GOTO 70

  280	CONTINUE

C	FALSE ALARM.

  290	CALL PUTBAK(D)

C	OUTPUT CHARACTER.

  300	CALL OUTCH(C)
	I=I+1
	GOTO 10

   70	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE OUTTAB

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	OUTTAB SPACES TO COLUMN 7.

C	VARIABLE   VALUE
C	--------   -----
C	BLANK	   BLANK CHARACTER.
C	OUTP	   OUTPUT STRING POINTER.

	SUBROUTINE OUTTAB
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
   10	IF( .NOT. (OUTP .LT. 6))GO TO 20
	CALL OUTCH(BLANK)
	GO TO 10
   20	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE OTHER

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	OTHERC OUTPUTS LEXICAL TYPE OTHER STRINGS.

C	VARIABLE   VALUE
C	--------   -----
C	LEXSTR	   STRING TO BE OUTPUT.

	SUBROUTINE OTHERC(LEXSTR)
	LOGICAL*1 LEXSTR(72)
	CALL OUTTAB
	CALL OUTSTR(LEXSTR)
	CALL EATUP
	CALL OUTDON
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE PUTBAK

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	27-05-79

C	PUTBAK PUTS THE BACK TRACKED CHARACTERS BACK.

C	VARIABLE   VALUE
C	--------   -----
C	BP	   BUFFER POINTER.
C	BUF	   ARRAY CONTAINING THE BACKED UP CHARACTERS.
C	C	   CURRENT CHARACTER.

	SUBROUTINE PUTBAK(C)
	COMMON /CDEFIO/BP,BUF
	INTEGER BP
	LOGICAL*1 BUF(5)
	LOGICAL*1 
	BP=BP+1
	IF(BP .GT. 5)CALL ERROR(31HTOO MANY CHARACTERS PUSHED BACK,31)
	BUF(BP)=
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE PUT

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	27-05-79

C	PUTC ACCEPTS ONE CHARACTER AT A TIME INTO AN OUTPUT BUFFER,
C	AND WILL DUMP THE BUFFER WHEN IT IS FULL OR WHEN A
C	NEW LINE CHARACTER IS SENT.

C	VARIABLE   VALUE
C	--------   -----
C	BLANK	   THE BLANK CHARACTER.
C	BUF	   ARRAY CONTAINING THE OUTPUT BUFFER. ONE OUTPUT IMAGE
C			LONG.
C	C	   CURRENT OUTPUT CHARACTER.
C	I	   COUNTER.
C	LASTC	   CURRENT CHARACTER POSITION COUNTER.
C	NL	   NEW LINE CHARACTER.
C	STDOUT	   FORTRAN STANDARD OUTPUT DEVICE CODE.

	SUBROUTINE PUTC(C)
	COMMON /RATFIO/ERRFIL,STDIN,STDOUT
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	INTEGER ERRFIL,STDIN,STDOUT
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	INTEGER I,LAST
	LOGICAL*1 BUF(72),
	DATA LASTC/0/

C	CHECK IF BUFFER NEEDS TO BE DUMPED.

	IF( .NOT. (LASTC .GE. 72 .OR. C .EQ. NL))GO TO 30
	IF(LASTC .EQ. 0)GO TO 40
	WRITE(STDOUT,25)(BUF(I),I=1,LASTC)

C	STDOUT IS THE SYSTEM'S STANDARD OUTPUT FILE CODE, 72 IS ONE
C	IMAGE.

   25	FORMAT(72A1)
	LASTC=0

C	LOAD IN THE CHARACTER.

   30	IF( .NOT. (C .NE. NL)) GO TO 40
	LASTC=LASTC+1
	BUF(LASTC)=
   40	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE REMARK

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	27-05-79

C	REMARK OUTPUTS THE ERROR MESSAGE TO THE ERROR MESSAGE FILE.

C	VARIABLE   VALUE
C	--------   -----
C	ERRFIL	   FORTRAN STANDARD ERROR LIST FILE CODE
C	LNGTH	   LENGTH OF MESSAGE.
C	MSG	   MESSAGE BUFFER.

	SUBROUTINE REMARK(MSG,LNGTH)
	COMMON /RATFIO/ERRFIL,STDIN,STDOUT
	INTEGER ERRFIL,STDIN,STDOUT
	INTEGER LNGTH
	LOGICAL*1 MSG(LNGTH)
	WRITE(ERRFIL,5)MSG
    5	FORMAT(1X,72A1)
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE REPEAT

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	REPEAT SETS UP THE BEGINNING OF A REPEAT LOOP.

C	VARIABLE   VALUE
C	--------   -----
C	LAB	   CURRENT LABEL NUMBER.

	SUBROUTINE REPEAT(LAB)
	INTEGER LAB
	INTEGER LABGEN
	LAB=LABGEN(3)
	CALL OUTCON(LAB)
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE REPETS

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	REPETS FINISHES UP A REPEAT LOOP THAT HAS NO UNTIL.

C	VARIABLE   VALUE
C	--------   -----
C	LAB	   CURRENT LABEL VALUE.

	SUBROUTINE REPETS(LAB)
	INTEGER LAB
	CALL OUTCON(LAB+1)
	CALL OUTGO(LAB)
	CALL OUTCON(LAB+2)
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE STRTWO

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	STRTWO IS A SECONDARY STRING OUTPUT ROUTINE.

C	VARIABLE   VALUE
C	--------   -----
C	EOS	   END OF STRING FLAG.
C	STR	   OUTPUT STRING.

	SUBROUTINE STRTWO(STR)
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 STR(72)
	I=1
   10	IF( .NOT. (STR(I) .NE. EOS))GO TO 20
	CALL OUTCH(STR(I))
	I=I+1
	GO TO 10
   20	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE SYNERR

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	27-05-79

C	SYNERR REPORT A SYNTAX TYPE OF ERROR.  PROCESSING CONTINUES.

C	VARIABLE   TYPE
C	--------   ----
C	JUNK	   DUMMY VARIABLE.
C	LC	   CHARACTER VERSION OF THE LINE NUMBER.
C	LINECT	   CURRENT LINE NUMBER.
C	LNGTH	   LENGTH OF MESSAGE.
C	MSG	   MESSAGE BUFFER.

	SUBROUTINE SYNERR(MSG,LNGTH)
	COMMON /CLINE/LINECT
	INTEGER LINECT
	INTEGER JUNK,LNGTH
	LOGICAL*1 LC(72),MSG(LNGTH)
	INTEGER ITO
	CALL REMARK(13HERROR IN LINE,13)
	JUNK=ITOC(LINECT,LC,72)
	CALL REMARK(LC,JUNK)
	CALL REMARK(MSG,LNGTH)
	RETURN
	END

C ----------------------------------------------------------------------------
C	FUNCTION TYPE

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	27-05-79

C	TYPE DETERMINES IF THE CHARACTER SUBMITTED IS A LETTER, NUMBER,
C	OR OTHER.

C	VARIABLE   VALUE
C	--------   -----
C	C	   CURRENT CHARACTER
C	DIGIT	   NUMBER FLAG.
C	DIGITS	   THE CHARACTER VERSIONS OF THE NUMBERS.
C	LETTER	   ALPHABETIC FLAG.
C	LOWALF	   ARRAY WITH THE LOWER CASE LETTERS.
C	UPALF	   ARRAY WITH THE UPPER CASE LETTERS.

	LOGICAL*1 FUNCTION TYPE(C)
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	LOGICAL*1 
	INTEGER INDEX

C	SEND LETTER FLAG.

	IF( .NOT. (INDEX(LOWALF,C) .GT. 0))GO TO 10
	TYPE=LETTER
	RETURN
   10	IF( .NOT. (INDEX(UPALF,C) .GT. 0))GO TO 20
	TYPE=LETTER
	RETURN

C	SEND DIGITS FLAG.

   20	IF( .NOT. (INDEX(DIGITS,C) .GT. 0))GO TO 30
	TYPE=DIGIT
	RETURN

C	RETURN FACT OF 'OTHER' BY RETURNING THE CHARACTER.

   30	TYPE=
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE UNSTAK

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	30-05-79

C	UNSTAK ATTEMPTS TO UNSTACK AS MANY OF THE BACKED UP
C	RATFOR COMMANDS AS IS POSSIBLE.

C	VARIABLE   VALUE
C	--------   -----
C	LABVAL	   LABEL STACK.
C	LBRACE	   LEFT BRACE CHARACTER.
C	LBRAK	   LEFT BRACKET CHARACTER.
C	LEXDO	   DO COMMAND FLAG.
C	LEXEL	   ELSE COMMAND FLAG.
C	LEXFO	   FOR COMMAND FLAG.
C	LEXIF	   IF COMMAND FLAG.
C	LEXRE	   REPEAT COMMAND FLAG.
C	LEXTYP	   LEXICAL TYPE STACK.
C	LEXUN	   UNTIL COMMAND FLAG.
C	LEXWH	   WHILE COMMAND FLAG.
C	SP	   STACK POINTER.
C	TOKEN	   CURRENT LEXICAL TYPE.

	SUBROUTINE UNSTAK(SP,LEXTYP,LABVAL,TOKEN)
	COMMON /RATSYS/ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,
     &	       LEXDI,LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,
     &	       LEXUN,LEXWH,OUTBUF,OUTP
	COMMON /RASCII/BLANK,DIGITS,DQUOTE,LASTP,LBRACE,LBRAK,LOWALF,
     &	       MINUS,NAMPTR,RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,TABLE,
     &	       UPALF,AND,CONTIN,DIG2,DIG3,DOSTR,EQ,IFNOT,GE,GOTO,
     &	       GT,LE,LPAREN,LT,NE,NOT,OR,RPAREN,STAR,TRUE,UNLINE
     &	       ,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,ORBAR,UPARW,COMMA,
     &		PERCNT
	INTEGER ALPHA,DIGIT,EOF,EOS,LETTER,NL,NO,YES,LEXBR,LEXDE,LEXDI,
     &		LEXDO,LEXEL,LEXFO,LEXIF,LEXIN,LEXNE,LEXOT,LEXRE,LEXUN,
     &		LEXWH,OUTP
	LOGICAL*1 OUTBUF(74)
	LOGICAL*1 BLANK,DIGITS(11),DQUOTE,LASTP,LBRACE,LBRAK,LOWALF(27),
     &		MINUS,NAMPTR(22),RBRACE,RBRAK,SEMCOL,SHARP,SQUOTE,TAB,
     &		TABLE(120),UPALF(27),AND(6),CONTIN(9),DIG2,DIG3,
     &		DOSTR(3),EQ(5),IFNOT(9),GE(5),GOTO(5),GT(5),LE(5),
     &		LPAREN,LT(5),NE(5),NOT(6),OR(5),RPAREN,STAR,
     &		TRUE(7),UNLINE,ANDSGN,EQUALS,EXCLAM,GRTHAN,LTTHAN,
     &		ORBAR,UPARW,COMMA,PERCNT
	INTEGER LABVAL(50),LEXTYP(50),SP
	LOGICAL*1 TOKEN

C	UNSTACK AS MANY COMMANDS AS POSSIBLE BY PUTTING OUT THE
C	ENDS OF THE PREVIOUS RATFOR COMMANDS.

   10	IF( .NOT. (SP .GT. 1))GO TO 80
	IF(LEXTYP(SP) .EQ. LBRACE .OR. LEXTYP(SP) .EQ. LBRAK)RETURN
	IF(LEXTYP(SP) .EQ. LEXIF .AND. TOKEN .EQ. LEXEL)RETURN
	IF(LEXTYP(SP) .EQ. LEXRE .AND. TOKEN .EQ. LEXUN)RETURN
	IF( .NOT. (LEXTYP(SP) .EQ. LEXIF))GO TO 20
	CALL OUTCON(LABVAL(SP))
	GO TO 70
   20	IF( .NOT. (LEXTYP(SP) .EQ. LEXEL))GO TO 30
	IF(SP .GT. 2)SP=SP-1
	CALL OUTCON(LABVAL(SP)+1)
	GO TO 70
   30	IF( .NOT. (LEXTYP(SP) .EQ. LEXDO))GO TO 40
	CALL DOSTAT(LABVAL(SP))
	GO TO 70
   40	IF( .NOT. (LEXTYP(SP) .EQ. LEXWH))GO TO 50
	CALL WHILES(LABVAL(SP))
	GO TO 70
   50	IF( .NOT. (LEXTYP(SP) .EQ. LEXRE))GO TO 60
	CALL REPETS(LABVAL(SP))
	GO TO 70
   60	IF( .NOT. (LEXTYP(SP) .EQ. LEXFO))GO TO 70
	CALL FORSTA(LABVAL(SP))
   70	SP=SP-1
	GO TO 10
   80	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE UNTIL

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	UNTILC FINISHES UP A REPEAT LOOP THAT HAS AN UNTIL CONDITION.

C	VARIABLE   VALUE
C	--------   -----
C	LAB	   CURRENT LABEL VALUE.

	SUBROUTINE UNTILC(LAB)
	INTEGER LAB
	CALL OUTCON(LAB+1)
	CALL IFGO(LAB)
	CALL OUTCON(LAB+2)
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE WHILE

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	WHILEC SETS UP THE BEGINNIG OF A WHILE LOOP.

C	VARIABLE   VALUE
C	--------   -----
C	LAB	   CURRENT LABEL VALUE.

	SUBROUTINE WHILEC(LAB)
	INTEGER LAB
	INTEGER LABGEN
	CALL OUTCON(0)
	LAB=LABGEN(2)
	CALL OUTNUM(LAB)
	CALL IFGO(LAB+1)
	RETURN
	END

C ----------------------------------------------------------------------------
C	SUBROUTINE WHILES

C	WRITTEN BY PETER PALIJ
C	LAST MODIFIED:	01-06-79

C	WHILES FINISHES UP THE WHILE LOOP.

C	VARIABLE   VALUE
C	--------   -----
C	LAB	   CURRENT LABEL VALUE.

	SUBROUTINE WHILES(LAB)
	INTEGER LAB
	CALL OUTGO(LAB)
	CALL OUTCON(LAB+1)
	RETURN
	END

       SUBROUTINE  CMDLN (BUFFER, BUFSZ)

C		MODIFIED JUNE 28, 1979
C		PURPOSE  ACCEPT COLONS IN FILE NAMES
C		BY	 RDS


C		MODIFIED JULY 24, 1979
C		PURPOSE  INCREASE DEFINE STACK SIZE TO 70
C		BY	 RDS

       INTEGER BUFSZ,DUMMY
       LOGICAL*1  BUFFER (BUFSZ), CHAR
       LOGICAL*1  INFILE (25), OTFILE (25)
       LOGICAL*1  TYPE
       PARAMETER  BLANK=' '
       PARAMETER  RBRCKT=']', LBRCKT='[', COMMA=',', COLON=':'

       I = 1

C	SCAN LEADING BLANKS

 200   CONTINUE
       IF (BUFFER(I) .NE. BLANK)  GO TO 210
       I = I+1
       IF (I .LE. BUFSZ)  GO TO 200

C	NO FILE SPECIFIED

       TYPE 600
 600   FORMAT (' RAT -- MISSING FILE NAME')
       RETURN

C	FILE SPECIFIED

 210   CONTINUE
       J = I
       K = 1

C	LOOK AHEAD FOR DEVICE SPECIFICATION

215	CONTINUE
	IF (BUFFER (J) .EQ. COLON)  GO TO 220
	J = J + 1
	IF (J .LE. BUFSZ)  GO TO 215

C	NO DEVICE SPECIFICATION - DEFAULT DEVICE: SY:

	INFILE (K) = 'S'
	OTFILE (K) = 'S'
	K = K + 1
	INFILE (K) = 'Y'
	OTFILE (K) = 'Y'
	K = K + 1
	INFILE (K) = COLON
	OTFILE (K) = COLON
	K = K + 1

220	CONTINUE
	CHAR = BUFFER (I)
225	CONTINUE
	INFILE (K) = CHAR
	OTFILE (K) = CHAR
	I = I + 1
	K = K + 1
	CHAR = BUFFER (I)
	IF ((CHAR .EQ. LBRCKT) .OR. (CHAR .EQ. RBRCKT))  GO TO 225
	IF ((CHAR .EQ. COMMA ) .OR. (CHAR .EQ. COLON ))  GO TO 225
	DUMMY = TYPE (CHAR)
	IF ((DUMMY .EQ. -1) .OR. (DUMMY .EQ. -2))  GO TO 225

	IF (BUFFER (I - 1) .EQ. COLON)	GO TO 230

C	SET DEFAULT FILE TYPES .RAT, .FTN

	INFILE (K) = '.'
	OTFILE (K) = '.'
	K = K + 1
	INFILE (K) = 'R'
	OTFILE (K) = 'F'
	K = K + 1
	INFILE (K) = 'A'
	OTFILE (K) = 'T'
	K = K + 1
	INFILE (K) = 'T'
	OTFILE (K) = 'N'
	K = K + 1

230	INFILE (K) = "000
	OTFILE (K) = "000

       CALL RATFOR (INFILE, OTFILE, 25)

       RETURN
       END

       SUBROUTINE RATFOR (INFILE, OTFILE, SZ)
	COMMON /RATDEF/DEFPNT,DEFSTK
	COMMON /RATFIO/ERRFIL,STDIN,STDOUT
	INTEGER ERRFIL,STDIN,STDOUT
	INTEGER DEFPNT
	LOGICAL*1 DEFSTK(70,2,16)
	INTEGER DEPTH,FILE,SZ
	LOGICAL*1 INFILE(SZ),OTFILE(SZ),STACK(25,3)

C	       SUPPRESS PRINTING OF ERROR MESSAGE FOR
C	       NON-EXISTANT FILE

       CALL ERRSET (29,,,,.FALSE.,)
       CALL ERRSET (43,,,,.TRUE.,)

C	RESET THE DEFINE POINTER

	DEFPNT=0

C	STACK THE INITIAL FILE INTO THE INCLUDE FILE STACK

	FILE=1
	I=1
   10	IF( .NOT. (I .LT. 26))GO TO 15
	STACK(I,1)=INFILE(I)
	I=I+1
	GO TO 10

C	OPEN THE INITIAL FILES

   15	OPEN(UNIT=2, NAME=INFILE, TYPE='OLD', READONLY)
	OPEN(UNIT=1, NAME=OTFILE, TYPE='NEW')

C	DEPTH IS USED TO DETERMINE WHETHER IT IS TIME TO OPEN OR CLOSE
C	A DEVICE WITH THE INCLUDE FILE

	DEPTH=1

C	CHECK FOR LEVEL OF DEVICES

   20	IF( .NOT. (FILE .LE. 3))GO TO 40

C	SET PROPER UNIT FOR READS AND BEGIN RATFOR COMMAND PROCESSING

	STDIN=FILE+1
	CALL PARSE(FILE,STACK)

C	CHECK IF A NEW FILE NEEDS TO BE OPENED

	IF( .NOT. (FILE .GT. 0))GO TO 30
	IF(DEPTH .GT. FILE)GO TO 25
	OPEN(UNIT=FILE+1, NAME=STACK(1,FILE), TYPE='OLD', READONLY,
     &	     ERR=350)
	DEPTH=DEPTH+1
	GO TO 20

C	CLOSE LOWEST LEVEL OF INCLUDE

   25	CLOSE(UNIT=FILE+2, DISPOSE='SAVE')
	DEPTH=DEPTH-1
	GO TO 20

C	CLOSE THE BASE INPUT AND OUTPUT FILES

   30	CLOSE(UNIT=1, DISPOSE='SAVE')
	CLOSE(UNIT=2, DISPOSE='SAVE')
	RETURN
   40	TYPE 45
   45	FORMAT('TOO MANY LEVELS OF INCLUDES.')
	GO TO 30

 350	CONTINUE
       CALL ERRSNS (NUM,,,)
       IF (NUM .EQ. 29)  TYPE 690
       IF (NUM .EQ. 43)  TYPE 700
	GO TO 30
 690   FORMAT (' RAT -- INPUT FILE NOT FOUND.')
 700   FORMAT (' RAT -- FILE NAME IS NOT CORRECTLY FORMED.')
       END
