C	TEXT-DRIVEN REPORT GENERATOR
C
C  Submitted by:
C  
C  	R. N. Stillwell
C  	Institute for Lipid Research
C  	Baylor College of Medicine
C  	Houston, Texas 77030
C  	
C  (who would be glad to receive comments, suggestions, bug fixes, etc., but
C  who promises no support whatever).
C  
C  Literature reference:
C  
C  	R. N. Stillwell.  A low-overhead laboratory data management system
C  	for the PDP11.  Comput. Biomed. Res., 15, 29-38(1982).
C  
C  Acknowledgement:
C
C  	This software was developed under National Institutes of Health grants
C  	GM-13901 and GM-26611.
C 
C  General permission is hereby granted to copy, modify, or distribute this
C  program, but not for profit.  Copyright to this software is and shall
C  remain in the public domain.
C
C	20-JUL-81  SUBTASKING SUPPORT ADDED
C	09-OCT-81  UNIVERSAL LIBRARY SUPPORT ADDED
C	02-NOV-81  %SKIP COMMAND
C	07-JAN-82  %WHILE AND %EWHILE
C	07-JAN-82  ALLOW BLANKS BETWEEN % AND COMMAND
C	07-JAN-82  MOVE ERROR ROUTINES OUT
C	27-JAN-82  ENFORCE "STANDARD COMMON" ON ALL ROUTINES
C	08-MAR-82  ADD "%FREAD <cr>' TO CLOSE FREAD FILE
C	
C	DECLARATIONS
C	
C	INCLUDE 'COMMON.FLX'
C
C	DECLARE COMMON BLOCKS
C
	COMMON      /TABDAT/  NREC,NCOLS,LENREC,OFFSET,IPTRD,TABREC,
	1                     DATA,IALT,IDUM
	INTEGER     NREC,NCOLS,LENREC,OFFSET,IPTRD(41),TABREC
	BYTE        DATA(1000)
	LOGICAL*1   IALT,IDUM    !1-82

	COMMON      /LUN/     INLUN,OUTLUN,TILUN,TABLUN,TAILUN,RDFLUN
	INTEGER     INLUN,OUTLUN,TILUN,TABLUN,TAILUN,RDFLUN

	COMMON      /INPUT/   IREC,INPTR,LLINE,INLINE
	BYTE        INLINE(132)
	DATA        MAXIN/132/

	COMMON      /OUTPUT/  OUTLIN,OUTPTR,OUTEND
	BYTE        OUTLIN (132)
	INTEGER     OUTPTR,OUTEND
	DATA        MAXOUT /132/

	COMMON      /FILES/   FILNAM,MAXFNM,MODNAM,LFNAM,FLREC,
	1                     MAXLVL,INLVL,OLDLVL,ULBUF,CARCTL,TERM
	1                     ,OUTOPN,TBOPEN,OUTFIL
C
C	FILE STACK
C
	BYTE        FILNAM(26,5)
	DATA        MAXFNM/26/
	REAL*4      MODNAM(5)                 !9-OCT-81 RAD50 MODULE NAMES
	INTEGER     LFNAM(5)                  !LENGTHS OF NAMES
C	                                      !POINTERS TO  START OF CURRENT
C	                                        !OR NEXT RECORD
  	REAL*4      FLREC(5)                  !9-OCT-81 CHANGED FROM
C	                                      !RECORD PTR TO BYTE PTR
C
D	INTEGER     IFLREC(2,5)
D	EQUIVALENCE (IFLREC,FLREC)
	DATA        MAXLVL/5/
	INTEGER     INLVL                     !CURRENT LEVEL POINTER
	INTEGER     OLDLVL                    !PREVIOUS LEVEL POINTER
	INTEGER     ULBUF (7)
	BYTE        CARCTL
	LOGICAL*1   TERM,OUTOPN,TBOPEN
	BYTE        OUTFIL(26)
C
C	SCRATCH MEMORY.  DEFINITIONS MAY DIFFER FROM SUBROUTINE TO SUBROUTINE,
C	OR MAY USE EQUIVALENCE STATEMENTS.
C
	COMMON      /SCRATCH/  SCRATCH
	BYTE        SCRATCH (576)
C
C	LOCAL DECLARATIONS
C
	EQUIVALENCE (SCRATCH,VARVAL)  !ALSO TILINE, NAME!

	BYTE        CHAR
	BYTE        TILINE(132)
	DATA        MAXTI/132/
	INTEGER     TIPTR
	BYTE        VARVAL(256)
	EQUIVALENCE (VARVAL,TILINE)         !WATCH THIS!
	DATA        MAXVAR/256/
	BYTE        CMDCHR
	DATA        CMDCHR/'%'/
	BYTE        CARRET,NULL,BLANK,FILTYP
	DATA        CARRET,NULL,BLANK/"15,0,"40/
	LOGICAL*1   EOF,EQUAL,FILERR,EVALER,LOGIC1,GOTLAB
	LOGICAL*1   NOPNT,GOTEIF,LTRACE,QUOTED,SAMFIL
	REAL*8      VARNAM
	BYTE        BVAR(8)
	EQUIVALENCE (BVAR,VARNAM)
	BYTE        NAME(256),NAME2(25)
	DATA        MAXNAM,MXNAM2/256,25/
	BYTE        FMTBUF(20)
	EQUIVALENCE (NAME,VARVAL)        !WATCH THIS!
	DATA        FMTBUF/'(','F','2','0','.','7',',','A','1',')',10*' '/
	DATA        MAXFMT/20/
	DATA        LFMT/20/
	REAL*4      RWIND                    !CODE FOR REWIND CALL TO OPENF
	DATA        RWIND /0.0/
C
C	while stack
C
	INTEGER WINLVL(10)                    !INPUT FILE LEVEL
	REAL*4 WHIPTR(10)                     !FILE POINTERS VIA .MARK
        INTEGER WHILVL                        !WHILE STACK POINTER
	INTEGER MAXWHL                        !SIZE OF STACK
	DATA MAXWHL /10/
C
C	read file name
C
	BYTE        RDFIL(26)                 !9-OCT-81
C
C	error definitions (from error.flx)    !7-jan-82
C
C	SELECT (IERROR)
C	(1) ABORT-ON-IF-ERROR
C	(2) ABORT-ON-FILE-ERROR
C	(3) ABORT-ON-INPUT-FILE-ERROR
C	(4) ABORT-ON-INPUT-STACK-OVERFLOW
C	(5) ABORT-ON-LABEL-NOT-FOUND
C	(6) ABORT-ON-OUTPUT-FILE-ERROR
C	(7) ABORT-ON-TABLE-NAME-ERROR
C	(8) ABORT-ON-WHILE-MATCH-ERROR
C	(9) ABORT-ON-WHILE-STACK-ERROR
C	(101) REPORT-ERROR-LINE
C	(102) REPORT-EVALUATION-ERROR
C	(103) REPORT-FILE-NAME
C	(104) REPORT-ILLEGAL-COMMAND
C	(105) REPORT-INVALID-FORMAT
C	(106) REPORT-SKIP-ERROR
C	(107) REPORT-VARIABLE-ERROR
C	(108) REPORT-ADDVAR-ERROR
C	(OTHERWISE) REPORT-UNKNOWN-ERROR
C	FIN
C
C	external procedures
C
	INTEGER     ADDVAR,GETVAR
C
C	code
C
	INLUN = 3
	OUTLUN = 4
	TILUN = 5
	TABLUN = 2
	TAILUN = 1
	RDFLUN = 6
C
	INLVL = 1
	OLDLVL = 0
	IFLVL = 0
	WHILVL = 0
	LTRACE = .FALSE.
	INITIALIZE-ERROR-RECOVERY
	CALL INIFIL(NAME,MAXFNM,OUTFIL,MAXFNM)
	LNAME = LENGTH(NAME)-1
	OPEN-INPUT-FILE
	OUTOPN = .FALSE.
	TBOPEN = .FALSE.
	CARCTL = BLANK
	EOF = .FALSE.
C
C	initialize subtasking
C
	CALL INITAS
C
C	get the first character and we're off
C
	GET-CHARACTER
	UNTIL (EOF.AND.(INLVL.EQ.1))
	WHEN (CHAR.EQ.CMDCHR) PROCESS-COMMAND
	ELSE MOVE-CHARACTER-TO-OUTPUT
	UNLESS (EOF) GET-CHARACTER
	IF (EOF.AND.(INLVL.NE.1)) RE-OPEN-PREVIOUS-FILE
	FIN
	CALL-EXIT
C
	TO PROCESS-COMMAND
	INTEGER COMMND,CMDCMD,COPY,DUMP,EIF,ETRACE,EWHILE,EXITC,
	1 FORMAT,FREAD,GET,GOTO,IFCMD,INPUT,LABEL,
	1 LIST,PROMPT,PUT,OUTPUT,READ,SET,SKIP,STRING,SUBTAS,
	1 TABLE,TRACE,TYPE,WHILE
C	...etc.
	DATA CMDCMD,COPY,DUMP,EIF,ETRACE,EWHILE,EXITC,
	1 FORMAT,FREAD,GET,GOTO,IFCMD,INPUT,LABEL,
	1 LIST,PROMPT,PUT,OUTPUT,READ,SET,SKIP,STRING,SUBTAS,
	1 TABLE,TRACE,TYPE,WHILE
	1  /'% ','CO','DU','EI','ET','EW','EX','FO','FR','GE','GO',
	1 'IF','IN','LA','LI','PR',
	1 'PU','OU','RE','SE','SK','ST','SU','TA','TR','TY','WH'/
C	...etc.
	GET-COMMAND
	SELECT (COMMND)
	(CMDCMD) DO-CMDCMD-COMMAND
	(COPY)   DO-COPY-COMMAND
	(DUMP)   CALL DMPVAR (LFMT,FMTBUF)
	(EIF)    DO-EIF-COMMAND
	(ETRACE) LTRACE = .FALSE.
	(EWHILE) DO-EWHILE-COMMAND
	(EXITC)  DO-EXIT-COMMAND
	(FORMAT) DO-FORMAT-COMMAND
	(FREAD)  DO-FILE-READ-COMMAND
	(GET)    DO-GET-COMMAND
	(GOTO)   DO-GOTO-COMMAND
	(IFCMD)  DO-IF-COMMAND
	(INPUT)  DO-INPUT-COMMAND
	(LABEL)  DO-LABEL-COMMAND
	(LIST)   DO-LIST-COMMAND
	(OUTPUT) DO-OUTPUT-COMMAND
	(PROMPT) DO-PROMPT-COMMAND
	(PUT)    DO-PUT-COMMAND
	(READ)   DO-READ-COMMAND
	(SET)    DO-SET-COMMAND
	(SKIP)   DO-SKIP-COMMAND
	(STRING) DO-STRING-COMMAND
	(SUBTAS) DO-SUBTASK-COMMAND
	(TABLE)  DO-TABLE-COMMAND
	(TRACE)  LTRACE = .TRUE.
	(TYPE)   DO-TYPE-COMMAND
	(WHILE)  DO-WHILE-COMMAND
C    
C	(otherwise) report-illegal-command
	(OTHERWISE) CALL ERROR (104,2,COMMND)
	FIN
C	flush remainder of input line
	UNLESS (COMMND.EQ.CMDCMD) INPTR = 0
	FIN
C
C
C---------------------------------------------------
C
C
C	do-command procedures
C
	TO DO-CMDCMD-COMMAND
C	%%  (% is output)
	CHAR = CMDCHR
	MOVE-CHARACTER-TO-OUTPUT
	FIN

	TO DO-COPY-COMMAND
C	%COPY <varnam>     (C(<varnam>) (but no <cr>) is copied to output)
	GET-VARIABLE
C	if (lenvar.lt.0) report-variable-error
	IF (LENVAR.LT.0) CALL ERROR (107,LENVAR,VARNAM)
	IF (LENVAR.GT.0)
	DO (I=1,LENVAR)
	CHAR = VARVAL(I)
	MOVE-CHARACTER-TO-OUTPUT
	FIN
	FIN
	IF (LTRACE) WRITE (TILUN,501) VARNAM,(VARVAL(I),I=1,LENVAR)
501	FORMAT (' %COPY ',A8,' :',(1X,60A1))
	FIN

	TO DO-EIF-COMMAND
	IFLVL = IFLVL-1
	IF (LTRACE) WRITE (TILUN,502) IFLVL
502	FORMAT (' %EIF:  IF-level =',I5)
C	if (iflvl.lt.0) abort-on-if-error
	IF (IFLVL.LT.0) CALL ERROR(1,LNAME,NAME)
	FIN

	TO DO-EWHILE-COMMAND
C	if (term) report-illegal-command
	IF (TERM) CALL ERROR (104,2,COMMND)
C	if (inlvl.ne.winlvl(whilvl)) abort-on-while-match-error
	IF (INLVL.NE.WINLVL(WHILVL)) CALL ERROR (8,LNAME,NAME)
C	back up to while-expression and re-evaluate
	FLREC(INLVL) = WHIPTR(WHILVL)
	OPEN-INPUT-FILE
C	skip past text and %while
	SKIP-TO-COMMAND
	GET-COMMAND
	IF (LTRACE) WRITE (TILUN,5021) (INLINE(I),I=INPTR,LLINE)
5021	FORMAT (' %EWHILE',(1X,60A1))
	EVALUATE-WHILE-EXPRESSION
	FIN

	TO DO-EXIT-COMMAND
C	%EXIT  (Clean up any active %WHiles in this file and EOF).
	WHILE (WHILVL.GT.0.AND.WINLVL(WHILVL).EQ.INLVL) WHILVL = WHILVL-1
	EOF = .TRUE.
	FIN

	TO DO-FILE-READ-COMMAND
C	%FREAD <filename> <varnam>  (Read a line from the file into variable)
C	%FREAD <cr>  (Close current read file).
	WHEN (INPTR.GT.LLINE)
	UNLESS (RDFIL(1).EQ.0) CLOSE (UNIT=RDFLUN)
	RDFIL(1) = 0
	FIN
	ELSE
	GET-NAME
	GET-VARIABLE-NAME
	IF (.NOT.EQUAL(NAME,RDFIL))
	UNLESS (RDFIL(1).EQ.0) CLOSE (UNIT=RDFLUN)
	CALL MVSTR(RDFIL,NAME,25)
	OPEN (UNIT=RDFLUN,NAME=RDFIL,TYPE='OLD',READONLY)
	FIN
	VAREAL = 0.0   !EOF := FALSE
	IF (LTRACE) WRITE (TILUN,524) (RDFIL(I),I=1,LNAME)
524	FORMAT (' %FREAD from file ',(1X,80A1))
	READ (RDFLUN,27,ERR=29,END=28) LENVAR,(VARVAL(I),I=1,132)
27	FORMAT (Q,132A1)
	LENVAR = MIN0(MAXTI,LENVAR)
	IF (.FALSE.)
28	VAREAL = -1.0  !EOF := TRUE
	FIN
	IF (.FALSE.)
29	CONTINUE
C	ABORT-ON-FILE-ERROR
	CALL ERROR (2,LNAME,NAME)
	FIN
	IF (LTRACE) WRITE (TILUN,525) VAREAL,VARNAM,(VARVAL(I),I=1,LENVAR)
525	FORMAT (' EOF =',F6.0,' ',A8,' = ',(1X,40A1))
	STORE-VARIABLE
	CONVERT-REAL-TO-VARIABLE
	VARNAM = 'EOF'
	STORE-VARIABLE
	FIN
	FIN

	TO DO-FORMAT-COMMAND
C	%FORMAT <format> <cr>   (set format for %SET)
C	<format> can be any legal FORTRAN format for a real number,
C	or "Fw" to output an integer without decimal point in **w-1**
C	spaces.
	GET-NAME
	CALL MVSTR(FMTBUF(2),NAME)
	LFMT = LNAME+1
	NOPNT = INDEX(NAME,'.') .EQ. 0
	IF (NOPNT)
	CALL MVSTR(FMTBUF(LFMT+1),'.0')
	LFMT = LFMT+2
	FIN
	CALL MVSTR(FMTBUF(LFMT+1),',A1)')
	LFMT = LFMT+4		!FOR DMPVAR
	IF (LTRACE) WRITE (TILUN,503) (NAME(I),I=1,LNAME)
503	FORMAT (' %FORMAT: ',(1X,60A1))
	FIN

	TO DO-GET-COMMAND
C	%GET <varnam> <rowno> <colno>  (replace C(<varnam>) with C(rowno, colno)
C	of current table.
	CALL GETTAB(LTRACE,EVALER)
C	IF (EVALER) REPORT-ERROR-LINE
	IF (EVALER) CALL ERROR (101,LNAME,NAME)
	FIN

	TO DO-GOTO-COMMAND
C	%GOTO <label>  (transfer to line after <label> in current input file)
C	IF (TERM) REPORT-ILLEGAL-COMMAND
	IF (TERM) CALL ERROR (104,2,COMMND)
	GET-NAME
	IF (LTRACE) WRITE (TILUN,504) (NAME(I),I=1,LNAME)
504	FORMAT (' %GOTO ',(1X,60A1))
C	Scratch any %WHiles at the current level.
	WHILE (WHILVL.GT.0.AND.WINLVL(WHILVL).EQ.INLVL) WHILVL = WHILVL-1
	GO-TO-LABEL
	FIN

	TO DO-IF-COMMAND
C	%IF <expression>
C	if-block %EIF <cr>
C	  (if-block is executed if expression is TRUE)
C	  note that <expression> is terminated by <cr>.
C
	IF (LTRACE) WRITE (TILUN,505) (INLINE(I),I=INPTR,LLINE)
505	FORMAT (' %IF ',(1X,60A1))

	LOGIC1 = 0.0 .NE. EVAL(FILERR,EVALER)
C	IF (EVALER) REPORT-EVALUATION-ERROR
	IF (EVALER) CALL ERROR (102,LNAME,NAME)
C	IF (FILERR) ABORT-ON-FILE-ERROR
	IF (FILERR) CALL ERROR (2,LNAME,NAME)
	IFLVL = IFLVL+1
	IF (LTRACE) WRITE (TILUN,5050) LOGIC1,IFLVL
5050	FORMAT (' Condition is',L2,'; IF-level =',I5)
	IF (.NOT. LOGIC1) SKIP-TO-EIF
	FIN

	TO DO-INPUT-COMMAND
C	%INPUT <filename[!modulename]>
C	(Close current input file, open <filename>, [open <modulename>].)
	GET-NAME
	CONDITIONAL
C	(filerr.or.(lname.gt.maxfnm)) abort-on-input-file-error
	(FILERR.OR.(LNAME.GT.MAXFNM)) CALL ERROR (3,LNAME,NAME)
C	(evaler) report-error-line
	(EVALER) CALL ERROR (101,LNAME,NAME)
	(OTHERWISE)
	INLVL = INLVL + 1
C	if (inlvl.gt.maxlvl) abort-on-input-stack-overflow
	IF (INLVL.GT.MAXLVL) CALL ERROR (4,LNAME,NAME)
	IF (LTRACE) WRITE (TILUN,506) INLVL,(NAME(I),I=1,LNAME)
506	FORMAT (' %INPUT level =',I5,':',(1X,60A1))
	OPEN-INPUT-FILE
	FIN
	FIN
	FIN

	TO DO-LABEL-COMMAND
C	%LABEL <label>  (Define a label for %GOTO; remainder of line is flushed.)
C	just check for illegal mode
C	if (term) report-illegal-command
	IF (TERM) CALL ERROR (104,2,COMMND)
	IF (LTRACE) WRITE (TILUN,507) (INLINE(I),I=INPTR,LLINE)
507	FORMAT (' %LABEL ',(1X,60A1))
	FIN

	TO DO-LIST-COMMAND
C	%LIST <varnam>  (List the value of <varnam> on the terminal.)
	GET-VARIABLE
C	if (lenvar.lt.0) report-variable-error
	IF (LENVAR.LT.0) CALL ERROR (107,LENVAR,VARNAM)
	IF (LENVAR.GT.0) WRITE (TILUN,51) NULL,(VARVAL(I),I=1,LENVAR)
51	FORMAT (A1,132A1)
	FIN

	TO DO-OUTPUT-COMMAND
C	%OUTPUT <filename> [<options>] (Close current output file, open <filename>)
C	<options> may contain:
C	   'EXTEND' or 'EX' for extend existing file
C	   'NCC' for no carriage control
C	   'DELETE' for delete the file (does not change current output file)
C
	GET-NAME
C	if (filerr.or.(lname.gt.mxnam2)) abort-on-output-file-error
	IF (FILERR.OR.(LNAME.GT.MXNAM2)) CALL ERROR (6,LNAME,NAME)
C	when (evaler) report-error-line
	WHEN (EVALER) CALL ERROR (101,LNAME,NAME)
	ELSE
	FILTYP = 'O'
	CALL MVSTR(NAME2,NAME)
	LNAME2 = LNAME
	LNAME = 1
	NAME(1) = BLANK
C
C	see if <options> field is supplied
C
	UNLESS (INPTR.EQ.0 .OR. INPTR.GT.LLINE)
	GET-NAME
	IF (INDEX(NAME,'EX').NE.0) FILTYP = 'E'
	IF (INDEX(NAME,'DELETE').NE.0) FILTYP = 'D'
	FIN
	CALL OPENF(NAME2,FILTYP,EVALER,OUTLIN,OUTEND)
C	if (evaler) abort-on-output-file-error
	IF (EVALER) CALL ERROR (6,LNAME,NAME)
	OUTPTR = 0
	CARCTL = BLANK
	IF (INDEX(NAME,'NCC').NE.0) CARCTL = NULL
	IF (LTRACE) WRITE (TILUN,509) (NAME2(I),I=1,LNAME2),BLANK,
	1 (NAME(I),I=1,LNAME)
509	FORMAT (' %OUTPUT file',(1X,60A1))
	FIN
	FIN

	TO DO-PROMPT-COMMAND
C	%PROMPT ...   (Write ... to terminal (no <cr><lf>)).
	GET-TERMINAL-LINE
	IF (TIPTR.GT.0) WRITE (TILUN,32) NULL,(TILINE(I),I=1,TIPTR)
32	FORMAT (A1,132A1)
	FIN

	TO DO-PUT-COMMAND
C	%PUT <varnam> <rowno> <colno>  (replace C(rowno, colno) of current
C	 table with C(<varnam>).
	CALL PUTTAB(LTRACE,EVALER)
C	if (evaler) report-error-line
	IF (EVALER) CALL ERROR (101,LNAME,NAME)
	FIN

	TO DO-READ-COMMAND
C	%READ <varnam>   (Read C(<varnam>) from terminal.)
	GET-VARIABLE-NAME
C	get a line from the terminal (no prompt)
	CALL RDTERM (.FALSE., 132,LENVAR,VARVAL,FILERR,EOF)
	IF (EOF) CALL EXIT
C	if (filerr) abort-on-file-error
	IF (FILERR) CALL ERROR (2,LNAME,NAME)
	STORE-VARIABLE
	FIN

	TO DO-SET-COMMAND
C	%SET <varnam> <expression>  (Set C(<varnam>) := <expression>)
	GET-VARIABLE-NAME
	VAREAL = EVAL(FILERR,EVALER)
	CONDITIONAL
C	(filerr) abort-on-file-error
	(FILERR) CALL ERROR (2,LNAME,NAME)
C	(evaler) report-evaluation-error
	(EVALER) CALL ERROR (102,LNAME,NAME)
	(OTHERWISE)
	CONVERT-REAL-TO-VARIABLE
	UNLESS (EVALER)
	IF (LTRACE) WRITE (TILUN,510)VARNAM,(VARVAL(I),I=1,LENVAR)
510	FORMAT (' %SET ',A8,' to',(1X,60A1))
	STORE-VARIABLE
	FIN
	FIN
	FIN
	FIN

	TO DO-SKIP-COMMAND
C	%SKIP <expr>
C	Next output character will be in position <expr> of output line.
	OUTPTR = EVAL(FILERR,EVALER) - 1
	IF (LTRACE) WRITE (TILUN,514) OUTPTR
514	FORMAT (' %SKIP to position ',I5)
	CONDITIONAL
C	(filerr) abort-on-file-error
	(FILERR) CALL ERROR (2,LNAME,NAME)
C	(evaler) report-evaluation-error
	(EVALER) CALL ERROR (102,LNAME,NAME)
C	(outptr.gt.maxout.or.outptr.lt.1) report-skip-error
	(OUTPTR.GT.MAXOUT.OR.OUTPTR.LT.1) CALL ERROR (106,LNAME,NAME)
	(OUTPTR.GT.OUTEND)
	DO (I=OUTEND+1,OUTPTR) OUTLIN(I) = ' '
	FIN
	FIN
	FIN

	TO DO-STRING-COMMAND
C	%STRING <varnam> <opcode> <operands>  (replace C(<varnam>) with 
C	result of applying <opcode> to <operands>.
	CALL EVALST (LFMT,FMTBUF,NOPNT,LTRACE,FILERR,EVALER)
C	if (evaler) report-evaluation-error
	IF (EVALER) CALL ERROR (102,LNAME,NAME)
C	if (filerr) abort-on-file-error
	IF (FILERR) CALL ERROR (2,LNAME,NAME)
	FIN

	TO DO-SUBTASK-COMMAND
C	%SUbtask RUn <commandline>
C	%SUbtask REceive <varnam>  (receive a message from subtask)
C	%SUbtask SEnd <message>  (send message to subtask invoked by %SU RU)
	CALL SUBTSK (LTRACE,FILERR,EVALER)
C	if (filerr) abort-on-file-error
	IF (FILERR) CALL ERROR (2,LNAME,NAME)
C	if (evaler) report-evaluation-error
	IF (EVALER) CALL ERROR (102,LNAME,NAME)
	FIN

	TO DO-TABLE-COMMAND
C	%TABLE <tablename>   (Open table <tablename>).
	GET-NAME
C	if (filerr) abort-on-file-error
	IF (FILERR) CALL ERROR (2,LNAME,NAME)
C	if (lname.gt.9) abort-on-file-error
	IF (LNAME.GT.9) CALL ERROR (2,LNAME,NAME)
C	when (evaler) report-error-line
	WHEN (EVALER) CALL ERROR (101,LNAME,NAME)
	ELSE
	IF (LTRACE) WRITE (TILUN,511) (NAME(I),I=1,LNAME)
511	FORMAT (' %TABLE: open table ',(1X,60A1))
	NAME(LNAME+1) = 0
	CALL TABOPN(NAME,IERR)
	TBOPEN = .TRUE.
C	if (ierr) abort-on-table-name-error
	IF (IERR) CALL ERROR (7,LNAME,NAME)
	PLACE-TABLE-LIMITS-IN-VARIABLES
	FIN
	FIN

	TO DO-TYPE-COMMAND
C	%TYPE ...  (Type  ... <cr><lf> on terminal.)
	GET-TERMINAL-LINE
	IF (TIPTR.GT.0) WRITE (TILUN,32) NULL,(TILINE(I),I=1,TIPTR)
	WRITE (TILUN,33)
33	FORMAT (' ')
	FIN

	TO DO-WHILE-COMMAND
C	%WHile <expression>
C	while-block %EWHILE<cr>
C	(while-block is executed until expression is FALSE)
C
C	if (term) report-illegal-command
	IF (TERM) CALL ERROR (104,2,COMMND)
	IF (LTRACE) WRITE (TILUN,5110) (INLINE(I),I=INPTR,LLINE)
5110	FORMAT (' %WHILE',(1X,60A1))
	WHILVL = WHILVL+1
C	if (whilvl.gt.maxwhl) abort-on-while-stack-error
	IF (WHILVL.GT.MAXWHL) CALL ERROR (9,MAXWHL,NAME)
C	stack pointers to start of current record
	WINLVL(WHILVL) = INLVL
	WHIPTR(WHILVL)  = FLREC(INLVL)
	EVALUATE-WHILE-EXPRESSION
	FIN
C
C-------------------------------------------
C
C	OTHER PROCEDURES
C
	TO CALL-EXIT
	IF (LTRACE) WRITE (TILUN,512) (FILNAM(I,INLVL),I=1,LFNAM(INLVL))
512	FORMAT (' End of file on',(1X,40A1))
	IF (MODNAM(INLVL).NE.0.0)
	IF (LTRACE) TYPE-CURRENT-MODULE-NAME
	WRITE (TILUN,5121)
5121	FORMAT (1X)
	FIN
	CALL CLOSEF('I')
	IF (OUTOPN) CALL CLOSEF('O')
	IF (TBOPEN) CALL CLOSEF('T')
	CALL EXIT
	FIN

	TO CHECK-FOR-LABEL
	GET-COMMAND
D	WRITE (TILUN,9930) COMMND
D9930	FORMAT (' COMMAND = ',A2)
	IF (COMMND.EQ.LABEL)
C	no indirection allowed!
	CALL GETNAM(0,NAME2,MXNAM2-1,LNAME2,FILERR,QUOTED,EVALER)
C	if (filerr) abort-on-input-file-error
	IF (FILERR) CALL ERROR (3,LNAME,NAME)
C	when (evaler) report-error-line
	WHEN (EVALER) CALL ERROR (101,LNAME,NAME)
	ELSE
D	WRITE (TILUN,9931) (NAME2(I),I=1,LNAME2)
D9931	FORMAT (' NAME2: ',(1X,40A1))
	NAME2(LNAME2+1) = 0
	GOTLAB = EQUAL(NAME,NAME2)
	FIN
	FIN
	INPTR = 0 !FLUSH-INPUT
	FIN

	TO CONVERT-REAL-TO-VARIABLE
C	Convert real VAREAL to string VARVAL of length LENVAR according
C	to the current FORMAT specification.
	ENCODE (MAXVAR,FMTBUF,VARVAL,ERR=420) VAREAL,NULL
	IF (.FALSE.)
420	CONTINUE
C	report-invalid-format
	CALL ERROR (105,LFMT,FMTBUF)
	EVALER = .TRUE.
	FIN
	LENVAR = LENGTH(VARVAL)-1
	IF (NOPNT) LENVAR = LENVAR-1
	FIN

	TO EVALUATE-WHILE-EXPRESSION
	LOGIC1 = 0.0 .NE. EVAL(FILERR,EVALER)
C	if (filerr) abort-on-file-error
	IF (FILERR) CALL ERROR (2,LNAME,NAME)
C	if (evaler) report-evaluation-error
	IF (EVALER) CALL ERROR (102,LNAME,NAME)
	IF (LTRACE) WRITE (TILUN,5111)  WHILVL,LOGIC1
5111	FORMAT (' Level = ',I2,' Condition is ',L2)
	IF (.NOT.LOGIC1)
	IWHILE = 1
	UNTIL (EOF.OR.(IWHILE.EQ.0))
	SKIP-TO-COMMAND
	UNLESS (EOF)
	GET-COMMAND
	SELECT (COMMND)
	(WHILE) IWHILE = IWHILE+1
	(EWHILE) IWHILE = IWHILE-1
	FIN
	FIN
	FIN
C	when (eof) abort-on-while-match-error
	WHEN (EOF) CALL ERROR (8,LNAME,NAME)
	ELSE WHILVL = WHILVL-1
	FIN
	FIN

	TO GET-CHARACTER
C	in-line version of subroutine getchr.
	IF (INPTR.EQ.0)
C	read current input file
	CALL RDLINE (FILERR,EOF)
D	IF (LTRACE) WRITE (5,9909) FILERR,EOF,LLINE,
D	1 (INLINE(I),I=1,8),(INLINE(I),I=1,LLINE)
D9909	FORMAT (' RETURN FROM RDLINE: FILERR,EOF,LLINE:',2L2,I5/
D	1 ' INLINE(1-8): '/8O8/' INLINE'/(1X,64A1))
C	if (filerr) abort-on-input-file-error
	IF (FILERR) CALL ERROR (3,LNAME,NAME)
	FIN
	INPTR = INPTR+1
	CONDITIONAL
	(INPTR.GT.LLINE)
	CHAR = CARRET
	INPTR = 0
	FIN
	(OTHERWISE) CHAR = INLINE(INPTR)
	FIN
	FIN

	TO GET-COMMAND
C	assumes % has been found
C	leaves inptr following command word
	BYTE CMDBUF(2)
	EQUIVALENCE (CMDBUF,COMMND)
	INTEGER CMDPTR
	CMDPTR = 0
	GET-CHARACTER
	WHILE (CHAR.EQ.' ') GET-CHARACTER
	WHEN (CHAR.EQ.CMDCHR) COMMND = CMDCMD
	ELSE
	DO (I=1,2) CMDBUF(I) = ' '
	UNTIL (CHAR.EQ.' '.OR.CHAR.EQ.CARRET.OR.CHAR.EQ.CMDCHR)
	IF (CMDPTR.LE.1)
	CMDPTR = CMDPTR+1
	CMDBUF(CMDPTR) = CHAR
	FIN
	GET-CHARACTER
	FIN
C	convert command to upper case
	DO (I=1,2)
	IF (CMDBUF(I).GE."140) CMDBUF(I) = CMDBUF(I).AND."137
	FIN
	FIN
	FIN

	TO GET-NAME
C	"infinite" indirection allowed on all operands obtained
C	through GET-NAME
	CALL GETNAM(-1,NAME,MAXNAM-1,LNAME,FILERR,QUOTED,EVALER)
C	if (filerr) abort-on-input-file-error
	IF (FILERR) CALL ERROR (3,LNAME,NAME)
C	if (evaler) report-error-line
	IF (EVALER) CALL ERROR (101,LNAME,NAME)
	FIN

	TO GET-TERMINAL-LINE
	TIPTR = 0
	IF (CHAR.NE.CARRET) GET-CHARACTER
	UNTIL (CHAR.EQ.CARRET.OR.TIPTR.EQ.MAXTI)
	TIPTR = TIPTR+1
	TILINE(TIPTR) = CHAR
	GET-CHARACTER
	FIN
	INPTR = 0  !FLUSH-INPUT
	FIN

	TO GET-VARIABLE
	GET-VARIABLE-NAME
	LENVAR = GETVAR(VARNAM,VARVAL,MAXVAR)
	FIN

	TO GET-VARIABLE-NAME
C	no indirection
	CALL GETNAM(0,VARNAM,8,LVNAM,FILERR,QUOTED,EVALER)
C	if (filerr) abort-on-input-file-error
	IF (FILERR) CALL ERROR (3,LNAME,NAME)
C	when (evaler) report-error-line
	WHEN (EVALER) CALL ERROR (101,LNAME,NAME)
	ELSE
	IF (LVNAM.LT.8)
	DO (I=LVNAM+1,8) BVAR(I) = ' '
	FIN
	FIN
	FIN

	TO GO-TO-LABEL
C	call openf with inlvl = oldlvl (rewind)
	FLREC(INLVL) = RWIND
	OPEN-INPUT-FILE
	GOTLAB = .FALSE.
	REPEAT UNTIL (GOTLAB.OR.EOF)
	SKIP-TO-COMMAND
	UNLESS (EOF)  CHECK-FOR-LABEL
	FIN
C	if (eof) abort-on-label-not-found
	IF (EOF) CALL ERROR (5,LNAME,NAME)
	FIN

	TO INITIALIZE-ERROR-RECOVERY
	DO (I=61,64) CALL ERRSET(I,.TRUE.,.TRUE.,.TRUE.,.FALSE.)
	FIN

	TO MOVE-CHARACTER-TO-OUTPUT
	CONDITIONAL
	(CHAR.EQ.CARRET) CALL WRITLN
	(OTHERWISE)
	OUTPTR = OUTPTR+1
	OUTLIN(OUTPTR) = CHAR
	IF (OUTPTR.GT.OUTEND) OUTEND = OUTPTR
	IF (OUTPTR.EQ.MAXOUT) CALL WRITLN
	FIN
	FIN
	FIN

	TO OPEN-INPUT-FILE
	CALL OPENF(NAME,'I',EVALER)
C	if (evaler) abort-on-input-file-error
	IF (EVALER) CALL ERROR (3,LNAME,NAME)
	FIN

	TO PLACE-TABLE-LIMITS-IN-VARIABLES
	VAREAL = OFFSET+1
	VARNAM = 'FIRSTROW'
	CONVERT-REAL-TO-VARIABLE
	STORE-VARIABLE
	VAREAL = OFFSET+NREC
	VARNAM = 'LASTROW'
	CONVERT-REAL-TO-VARIABLE
	STORE-VARIABLE
	VAREAL = NCOLS
	VARNAM = 'LASTCOL'
	CONVERT-REAL-TO-VARIABLE
	STORE-VARIABLE
	FIN

	TO RE-OPEN-PREVIOUS-FILE
	IF (LTRACE)
	WRITE (TILUN,512) (FILNAM(I,INLVL),I=1,LFNAM(INLVL))
	IF (MODNAM(INLVL).NE.0.0) TYPE-CURRENT-MODULE-NAME
	FIN
	INLVL = INLVL-1
	OPEN-INPUT-FILE
	EOF = .FALSE.
	INPTR = 0
	GET-CHARACTER
	FIN

	TO SKIP-TO-COMMAND
	UNTIL (EOF.OR.(CHAR.EQ.CMDCHR)) GET-CHARACTER
	FIN

	TO SKIP-TO-EIF
	INTEGER SKPLVL
	SKPLVL = IFLVL
	GOTEIF = .FALSE.
	REPEAT UNTIL (GOTEIF.OR.EOF)
	SKIP-TO-COMMAND
	UNLESS (EOF)
C	test-eif
	GET-COMMAND
	SELECT (COMMND)
	(IFCMD) SKPLVL=SKPLVL+1
	(EIF)
	GOTEIF = SKPLVL .EQ. IFLVL
	SKPLVL = SKPLVL-1
	FIN
	FIN
	INPTR = 0  !FLUSH-INPUT
	FIN
	FIN
C	if (eof) abort-on-if-error
	IF (EOF) CALL ERROR (1,LNAME,NAME)
	IFLVL = IFLVL-1
	FIN

	TO STORE-VARIABLE
	IF (LENVAR.EQ.0)
	LENVAR = 1
	VARVAL(1) = ' '
	FIN
	IRET = ADDVAR(VARNAM,VARVAL,LENVAR)
C	if (iret.lt.0) report-addvar-error
	IF (IRET.LT.0) CALL ERROR (108,IRET,VARNAM)
	FIN

	TO TYPE-CURRENT-MODULE-NAME
	CALL R50ASC(6,MODNAM(INLVL),NAME2)
	WRITE (TILUN,513) (NAME2(I),I=1,6)
513	FORMAT (' in module: ',6A1)
	FIN

	END