irg.for

CX - -		@COPYRIGHT 1975 BY 


CX - -		SOFTWARE HOUSE(RS) 
CX - -		1105 MASSACHUSETTS AVE. 
CX - -		CAMBRIDGE, MASS. 02138 
CX - -	 
CX - -	 
CX - -		THIS PROGRAM WILL INTERACT WITH A USER, AND BASED UPON 
CX - -	HIS ANSWERS TO THE PROGRAM'S QUESTIONS, CREATE A REPORT 
CX - -	CONTROL FILE THAT WILL OPERATE UPON A DATABASE AND GENERATE A 
CX - -	REPORT ACCORDING TO THE USER'S SPECIFICATIONS. 
CX - -	 
CX - -	 
CX - -		THE ARRAY 'THING' IS THE MAJOR AREA OF STORAGE IN THE 
CX - -	PROGRAM. ENTRIES ARE PLACED IN 'THING' AND POINTERS 
CX - -	TO THESE ENTRIES ARE STORED. THIS MAKES MAXIMUM USE 
CX - -	OF STORAGE SPACE. 
CX - - 
CX - -		A SAMPLE SETUP OF HOW 'THING' MIGHT LOOK, WITH ITS 
CX - -	POINTERS, IS AS FOLLOWS: 
CX - - 
CX - -	THING(1) = FIRST-ENTRY		PTR1 = 1 
CX - -	THING(2) =     PART-A 
CX - -	THING(3) =     PART-B 
CX - -	THING(4) = SECOND-ENTRY		PTR2 = 4 
CX - -	THING(5) = THIRD-ENTRY		PTR3 = 5 
CX - -	THING(6) =     PART-C 
CX - -	THING(7) = FOURTH-ENTRY		PTR4 = 7 
CX - -	...				... 
CX - -	THING(N) = G'TH-ENTRY		PTR(G) = N 
CX - - 
CX - -		NOTICE THAT NOT ONLY DOES EVERY ENTRY HAVE A POINTER 
CX - -	TO IT, BUT SINCE THE ENTRIES ARE DEPOSITED SEQUENTIALLY, 
CX - -	THE BEGINNING OF ONE ENTRY MARKS THE END OF THE PREVIOUS 
CX - -	ENTRY, WHICH ALLOWS THE CONVENTION 
CX - - 
CX - -		PTR(I+1)-PTR(I) = LENGTH(ENTRY I) 
CX - - 
CX - -	THIS WORKS FOR ALL ENTRIES BUT THE LAST, SINCE THERE IS NO 
CX - -	ENTRY G+1. TO MAKE THIS CONVENTION HOLD FOR ALL ENTRIES, 
CX - -	WE SET UP THIS: 
CX - - 
CX - -	THING(N+1) = [ANYTHING]		PTR(G+1) = N+1 
CX - - 
CX - -	NOW THE CONVENTION HOLDS FOR ALL THE ENTRIES. FOR THIS REASON, 
CX - -	ANY ARRAY OF POINTERS SIMILAR TO THE ONE ABOVE ALWAYS HAS A 
CX - -	'PLACEHOLDER' LIKE PTR(G+1) AT THE END, TO MAKE THE 
CX - -	CONVENTION HOLD FOR ALL ENTRIES. 
CX - - 
CX - - 
CX - -	[ANYTHING] MEANS THAT YOU DON'T STORE ANYTHING THERE, YOU 
CX - -	JUST USE THAT ADDRESS AS THE END-MARKER FOR THE LAST, HERE THE 
CX - -	G'TH, ENTRY. 
CX - - 
CX - - 


	IMPLICIT INTEGER(A-Z) 
	COMMON /CHANS/ILOGCH, OLOGCH, OCTLCH
	COMMON /LDBUF/LDBUF(150) 
	COMMON /SFLAG/SCRFLG 
	COMMON /DUMP1/DMPFLG 
	COMMON /STACK/STACK(150),STKNUM 
	COMMON /RDCNT/RDCNT 
	COMMON /FIELD/FIELD(10,8) 
	COMMON /LTHING/LTHING 
	COMMON /SEMBUF/SEMBUF(150) 
	COMMON /THING/THING(4000),THGPTR 
	COMMON /LBUFA1/LBUFA1(150) 
	COMMON /RBUFA5/RBUFA5(30) 
	COMMON /LOGIN/LOGIN 


CX - -	THE ABOVE ARRAYS ARE SPECIALLY PLACED, EACH IN THEIR OWN 
CX - -	COMMON BLOCK, TO ALLOW THEM TO BE USED BY SUBROUTINES WITHOUT 
CX - -	NECESSITATING USING THEM ALL, WHEN ONLY ONE OR TWO ARE NEEDED. 
CX - -	THEY ARE USED FOR THE FOLLOWING PURPOSES: 
CX 
CX - -	LDBUF: SUBROUTINE WRITER USES THIS BUFFER SPECIALLY. WHEN 
CX - -		IT IS CALLED, IT OUTPUTS THE CONTENTS OF LDBUF 
CX - -		ONTO THE TTY. THUS, THIS BUFFER STORES DATA WHICH IS 
CX - -		TO BE TYPED OUT ONTO THE TTY AT SOME TIME. 
CX - -	RDCNT: NOT AN ARRAY, MERELY A COUNT OF HOW MANY LINES 
CX - -		SUBROUTINE READER HAS READ IN FROM A LOG FILE, TO NOTIFY 
CX - -		THE USER WHAT LINE HIS ERROR WAS ON. 
CX - -	FIELD: STORES AN ARRAY OF POINTERS INTO 'THING' THAT HOLD ALL 
CX - -		PERTINENT INFORMATION TO THE FIELDS, I.E. THEIR TEXTS, 
CX - -		EXPRESSIONS, WIDTHS, FORMATS, AND TITLES. 
CX - -		FIELD IS DIMENSIONED AT (MXFLDS,8) BECAUSE 8 POINTERS 
CX - -		ARE NEEDED PER FIELD. THIS IS CALLED A FIELD BLOCK. 
CX - -		THERE ARE TWO TYPES OF FIELD BLOCKS - EXPRESSION FIELD 
CX - -		BLOCKS AND TEXT FIELD BLOCKS. 
CX - -		AN EXPRESSION FIELD BLOCK LOOKS LIKE THIS: 
CX 
CX - -	**************************************************************** 
CX - -		/E /PTR TO/PLACE /FIELD/PTR TO/PTR TO/PLACE /TOTAL-/ 
CX - -		/  /EXPRE-/HOLDER/WIDTH/FORMAT/TITLE /HOLDER/ABLE  / 
CX - -		/  /SSION /      /     /      /      /      /      / 
CX - -	**************************************************************** 
CX 
CX - -		'E' MEANS THE CHARACTER 'E'. TOTALLABLE MEANS EITHER 
CX - -		'Y', INDICATING THAT THIS IS A TOTALLABLE EXPRESSION 
CX - -		OR A SPACE, INDICATING THAT IT IS NOT. 
CX 
CX - -		A TEXT FIELD BLOCK LOOKS LIKE THIS: 
CX 
CX - -	**************************************************************** 
CX - -		/T /PTR TO/PLACE /FIELD/0  /0  /0  /0  / 
CX - -		/  /TEXT  /HOLDER/WIDTH/   /   /   /   / 
CX - -	**************************************************************** 
CX 
CX - -		'T' IS THE CHARACTER 'T'. THE LAST 4 PLACES ARE ZERO 
CX - -		BECAUSE THEY ARE NEVER USED. 
CX 
CX - -	LTHING: NOT AN ARRAY, BUT A VARBLE THAT STORES HOW LONG 
CX - -		'THING' HAS BEEN DIMENSIONED. USED ONLY IN SUBROUTINE 
CX - -		ALLOC, TO SEE WHAT KIND OF SPACE THE USER HAS LEFT IN 
CX - -		'THING'. 
CX - -	SEMBUF: A GARBAGE BUFFER 150 WORDS LONG. 
CX - -	THING: THE MAIN STORAGE FOR THE PROGRAM. THGPTR IS ALWAYS 
CX - -		POINTING AT THE LAST POSITION USED IN 'THING'. 
CX - -	LBUFA1: A GARBAGE BUFFER 150 WORDS LONG. 
CX - -	RBUFA5: A 30-WORD BUFFER SPECIALLY USED BY SUBROUTINE READER 
CX - -		TO PASS ANY INPUT BACK FROM THE TTY OR LOG FILE 
CX - -		TO THE PROGRAM. CAN HOLD 150 A1 CHARS. 
CX - -	LOGIN: A VARBLE THAT HOLDS A 'Y' WHEN THE INPUT 
CX - -		SOURCE IS THE LOG FILE, SOMETHING ELSE THAN 'Y' WHEN 
CX - -		INPUT IS FROM THE TTY. 


	COMMON /ARRAYS/FLNM2(10),FLNM1(10),FTTEXT(2),SUPMAT(6) 
	COMMON /ARRAYS/ETOTAL(10),ETITLE(2),EFRMAT(11) 
	COMMON /ARRAYS/MAT1(5,10),MAT2(5,12),ONCHNG(5,4) 
	COMMON /ARRAYS/SRTLST(6),HDING(11),CVPAGE(21) 
	COMMON /ARRAYS/UPDOWN(5) 


CX - -	THE ABOVE ARRAYS ARE ALL IN ONE COMMON BECAUSE THEY ARE 
CX - -	SAVED IN THAT COMMON FOR SUBROUTINE OUTPUT. THEIR 
CX - -	PURPOSES ARE AS FOLLOWS: 
CX 
CX - -	FLNM1,FLNM2: 10-WORD ARRAYS TO HOLD FILENAMES OF 6 LETTERS, 
CX - -		A PERIOD, AND 3 LETTERS MAXIMUM. 
CX - -	FTTEXT: HOLDS POINTERS TO THE BEGINNING AND END 
CX - -		OF ANY TEXT THE USER INPUTS FOR THE FOOTING. 
CX - -	SUPMAT: HOLDS POINTERS TO THE SUPERTOTALS SERIES, OR UP- 
CX - -		ARROWS, TO INDICATE NO SUPERTOTALS SERIES AT THAT SORT- 
CX - -		LEVEL. IT IS DIMENSIONED AT (MXSLEV+1), THE LAST 
CX - -		POINTER FOR THE GRAND TOTAL SUPERTOTALS. 
CX - -	ETOTAL: HOLDS A 'Y' IF THAT FIELD IS TO BE TOTALLED IN 
CX - -		THE 'ON END' STATEMENT, A SPACE IF IT IS TOTALLABLE 
CX - -		BUT NOT FOR THE 'ON END' STATEMENT, AND 0 
CX - -		OTHERWISE. DIMENSIONED AT (MXFLDS). 
CX - -	ETITLE: LIKE FTTEXT, BUT FOR THE 'ON END' STATEMENT TEXT. 
CX - -	EFRMAT: HOLDS POINTERS TO ANY FORMATS USED FOR THE EXPRES- 
CX - -		SIONS TO BE TOTALLED IN THE 'ON END' STATEMENT. AN 
CX - -		UP-ARROW SIGNIFIES THE DEFAULT FORMAT. DIMENSIONED AT 
CX - -		(MXFLDS+1), THE LAST ONE IS A PLACEHOLDER. 
CX - -	MAT1: HOLDS A 'Y' IF THE COORDINATE (SORTLEVEL,FIELD) EXPRESSION 
CX - -		IS TO BE TOTALLED. I.E. IF THE 4TH FIELD IS TO BE 
CX - -		TOTALLED ON THE 3RD SORTLEVEL, THEN MAT1(3,4) = 'Y'. 
CX - -		DIMENSIONED AT (MXSLEV,MXFLDS). 
CX - -	MAT2: HOLDS POINTERS TO FORMATS FOR THE 'ON CHANGE ... TOTALS' 
CX - -		STATEMENTS. AN UP-ARROW SIGNIFIES THE DEFAULT FORMAT. 
CX - -		DIMENSIONED AT (MXSLEV,MXFLDS+2), AND IS 
CX - -		USED AS A COORDINATE MAP BETWEEN SORTLEVEL AND FIELD 
CX - -		LIKE MAT1 EXCEPT THAT (...,MXFLDS+1) POINTS TO 
CX - -		THE TEXT, IF ANY (IF NOT, THIS POINTER IS INSTEAD A ^), 
CX - -		AT THIS SORTLEVEL, WHILE (...,MXFLDS+2) IS A 
CX - -		DUMMY PLACEHOLDER. 
CX - -	ONCHNG: HOLDS INFORMATION AND POINTERS FOR THE 'ON CHANGE' 
CX - -		PRINT STATEMENTS. WHERE THE FORMAT OF A STATEMENT 
CX - -		OF THIS TYPE IS LIKE: 
CX 
CX - -		"ON CHANGE [EXPRESSION] PRINT AAAAA FORMAT BBBBB END." 
CX 
CX - -		[EXPRESSION] IS TAKEN FROM SRTLST, ONCHNG(...,1) 
CX - -		POINTS TO AAAAA, ONCHNG(...,2) IS A PLACEHOLDER FOR 
CX - -		THIS, ONCHNG(...,3) POINTS TO BBBBB, AND 
CX - -		ONCHNG(...,4) IS A DUMMY PLACEHOLDER FOR THAT. 
CX - -	SRTLST: HOLDS POINTERS TO THE SORT EXPRESSIONS. IS 
CX - -		DIMENSIONED AT (MXSLEV+1), THE LAST ONE IS 
CX - -		A PLACEHOLDER. 
CX - -	HDING: HOLDS POINTERS TO THE DIFFERENT LINES OF THE HDING. 
CX - -		DIMENSIONED AT (MXHLIN+1), THE LAST ONE IS A 
CX - -		PLACEHOLDER. 
CX - -	CVPAGE: HOLDS POINTERS TO THE LINES OF THE COVER PAGE TEXT. 
CX - -		DIMENSIONED AT (MAXCVPAGE+1) THE LAST ONE IS A 
CX - -		PLACEHOLDER. 
CX - -	UPDOWN: HOLDS A 'D' IF THAT SORT ATTRIBUTE IS TO 
CX - -		SORTED DESCENDING. 


	COMMON /SCALAR/BLANKS,MXSLEV,MXFLDS,MXHLIN 
	COMMON /SCALAR/OUTP3,LWIDTH,WNTFOT,FNDSTR 
	COMMON /SCALAR/WNTDAT,WNTSRT,VERSIN,MXCLIN 
	COMMON /SCALAR/OMXSLV,OUTFIL,DATNAM,FLINES 
	COMMON /SCALAR/WNTTIM,SUMARY,WGRTOT,OMXFLD 
	COMMON /SCALAR/PAGLEN,WSSRTD,WPGNUM,WNTTOT 


CX - -	THE ABOVE ARE CERTAIN VARBLES WHOSE VALUES ARE IMPORTANT 
CX - -	IN SUBROUTINE OUTPUT, SO THEY ARE SAVED IN THIS COMMON BLOCK. 
CX - -	THEIR PURPOSES FOLLOW: 
CX - - 
CX - -	BLANKS: NUMBER OF BLANK LINES AFTER THE FIELD TITLES IN THE 
CX - -		HDING. 
CX - -	MXSLEV: SETS THE MAXIMUM NUMBER OF EXPRESSIONS YOU CAN 
CX - -		SORT BY. CURRENTLY SET AT 5. IF YOU CHANGE THIS 
CX - -		AND THE DIMENSIONING OF ANY MATRIX THAT HAS THIS AS 
CX - -		AS A DIMENSION, YOU CAN QUICKLY ALTER THE NUMBER 
CX - -		OF SORT LEVELS ALLOWED IN THE PROGRAM WITHOUT 
CX - -		CHANGING THE ENTIRE PROGRAM. 
CX - -	MXFLDS: SIMILAR TO MXSLEV, BUT MAKES THE MAXIMUM 
CX - -		NUMBER OF FIELDS CURRENTLY 10. CAN BE CHANGED LIKE 
CX - -		MXSLEV, QUICKLY, TO ALTER THE MAXIMUM NUMBER 
CX - -		OF FIELDS IN THE PROGRAM. 
CX - -	MXHLIN: SAME, BUT FOR THE NUMBER OF LINES IN THE HDING. 
CX - -	MXCLIN: SAME, BUT FOR THE NUMBER OF LINES IN THE COVER 
CX - -		PAGE TEXT. 
CX - -	OUTP3: CONTAINS A POINTER TO THE NAME TO BE USED FOR THE 
CX - -		REPORT CONTROL FILE. 
CX - -	LWIDTH: WIDTH OF THE LINE, USUALLY DEFAULTED AT 72. 
CX - -	WNTFOT: 'Y' IF THE USER HAS INPUT HIS OWN FOOTING, 'N' IF 
CX - -		HE DIDN'T WANT ONE AT ALL, AND ' ' IF HE WANTED 
CX - -		THE DEFAULT FOOTING. 
CX - -	FNDSTR: CONTAINS A POINTER TO THE FIND STRING 
CX - -		IN 'THING'. 
CX - -	WNTDAT: IS 'N' IF USER DOESN'T WANT DATE IN THE HDING, 
CX - -		<CR> OTHERWISE. (WNTDAT THEN = ' ') 
CX - -	WNTSRT: 'Y' IF THE USER SPECIFIED HIS OWN 'ON CHANGE' 
CX - -		INFORMATION, ' ' IF HE WANTED THE DEFAULT, AND 
CX - -		'N' IF HE DIDN'T WANT ANY AT ALL. 
CX - -	VERSIN: STORES THE VERSIN NUMBER OF THE PROGRAM, 
CX - -		FOR COMPARISON AGAINST THE VERSIN NUMBER IN OLD LOG 
CX - -		FILES WHEN THE PROGRAM HAS SUFFICIENTLY 
CX - -		CHANGED ITS OUTPUT FORMAT THAT OLD LOG FILES WOULD 
CX - -		ONLY CAUSE ERRORS. 
CX - -	OUTFIL: STORE A POINTER TO THE NAME TO BE USED AS THE OUTPUT 
CX - -		FILE OF THE REPORT CONTROL FILE. 
CX - -	DATNAM: CONTAINS A POINTER TO THE NAME OF THE DATABASE. 
CX - -	FLINES: A NUMBER, USED IN THE 'FOOTING CCC ...' 
CX - -		STATEMENT, AS THE VALUE OF CCC. 
CX - -	WNTTIM: 'N' IF THE USER DOESN'T WANT THE TIME IN THE 
CX - -		HDINGS, <CR> OTHERWISE. 
CX - -	SUMARY: IS 'Y' IF THE USER WANTS NO DETAIL LINES, <CR> 
CX - -		OTHERWISE. 
CX - -	WGRTOT: IS 'Y' IF THE USER WANTS TO INPUT HIS OWN 
CX - -		INFORMATION FOR THE 'ON END' STATEMENT, ' ' IF HE 
CX - -		WANTED THE DEFAULT, AND 'N' IF HE DIDN'T WANT ANY 
CX - -		AT ALL. 
CX - -	PAGLEN: NUMBER OF LINES IN THE PAGE, USUALLY 60. 
CX - -	WSSRTD: WAS 'Y' IF THE DATABASE WAS ALREADY SORTED. LATER 
CX - -		ON, IF THIS IS 'Y', MEANS THAT NO 'SORT BY ...' 
CX - -		STATEMENT WILL APPEAR IN THE REPORT GENERATOR FILE. 
CX - -	WPGNUM: IS 'N' IF THE USER DOESN'T WANT PAGE NUMBERS ON 
CX - -		HIS HDINGS, <CR> OTHERWISE. 
CX - -	WNTTOT: 'Y' IF THE USER INPUT HIS OWN 'ON CHANGE ... TOTALS' 
CX - -		STATEMENTS, ' ' IF HE WANTED THE DEFAULT, AND 
CX - -		'N' IF HE DIDN'T WANT ANY AT ALL. 


	COMMON /DELIM/ENDCHR

	DOUBLE PRECISION LEFT1,LEFT2,WHOLE
	MXSLEV = 5 
	VERSIN = 4 
	RDCNT = 0 
	MXFLDS = 10 
	MXCLIN = 20 
	MXHLIN = 10 


CX - -	BECAUSE OF THE NEED FOR THE ORIGINAL SIZES OF THESE 
CX - -	MATRICES, THE SAME VARBLES WITH THE LETTER 'O' IN FRONT 
CX - -	OF THEM WILL BE USED TO REPRESENT THE ORIGINAL VALUES OF 
CX - -	THE DIMENSIONS OF THESE VARBLES. THEY WILL NOT, OF 
CX - -	COURSE, CHANGE THEIR VALUE WITHIN THE PROGRAM, BEING USED 
CX - -	PRIMARILY IN ARGUMENT-PASSING TO THE SUBROUTINE 'UN2PCK'. 


	OMXSLV = 5 
	OMXFLD = 10 
	THGPTR = 0 
	LTHING = 4000 
	ILOGCH = 20		! INPUT LOG FILE CHANNEL NUMBER
	OLOGCH = 21		! OUTPUT LOG FILE CHANNEL NUMBER
	OCTLCH = 22		! OUTPUT CONTROL FILE CHANNEL NUMBER
	STKNUM = 0 
	DMPFLG = 'N' 
	LOGIN = 'N' 
	ENDCHR= "21004020100


CX - -	THE ABOVE TWO LINES ARE A KLUDGE TO TELL SUBROUTINES 
CX - -	READER AND WRITER NOT TO ATTEMPT TO DUMP ANYTHING INTO 
CX - -	THE LOG FILE, BECAUSE IT HASN'T BEEN CREATED YET. DUMPING 
CX - -	ANYTHING INTO 20 NOW WOULD CAUSE A FOR20.DAT TO 
CX - -	APPEAR. HENCE WE HOLD OFF ON THE OUTPUT TILL THE LOG FILE 
CX - -	IS CREATED, THEN WE CAN TURN DMPFLG OFF. WE TURN LOGIN 
CX - -	OFF SO WE CAN WRITE TO THE TERMINAL. 


	CALL LOADA(1,43,'A REPORT-GENERATING PROGRAM FOR SYSTEM 1022') 
	CALL WRITER(43,1) 


CX - -	SETTING UP THE SOURCE OF INPUT FOR THE PROGRAM: 
CX 
CX - -		1) THE USER CAN INPUT FROM THE TTY OR A LOG FILE. 
CX - -		SHOULD HE CHOOSE THE TTY, COMMAND GOES TO LINE 260. 
CX - -		2) INPUTTING FROM A LOGFILE: 
CX - -			A) THE USER MUST GIVE A LOG FILE NAME. FILES 
CX - -			GENERATED BY THIS PROGRAM ALWAYS HAVE A .DMR 
CX - -			EXTENSION, SO IF THE USER GIVES A FILENAME WITH 
CX - -			NO EXTENSION, THAT FILENAME+.DMR WILL BE USED AS 
CX - -			INPUT, UNLESS IT DOESN'T EXIST. THEN WE CHECK 
CX - -			FOR JUST THAT FILENAME. IF NEITHER OF THOSE 
CX - -			FILES EXIST, WE NOTIFY THE USER AND ALLOW HIM 
CX - -			TO INPUT ANOTHER FILENAME. 
CX - -			B) IF THE USER GIVES A FILENAME WITH AN EXTENSION, 
CX - -			WE CHECK FOR THE EXISTENCE OF THAT FILE, AND IF IT 
CX - -			DOESN'T EXIST, WE NOTIFY THE USER AND ALLOW HIM 
CX - -			TO INPUT ANOTHER FILENAME. 
CX - -			C) CHECK THE VERSIN NUMBER. IF INCOMPATIBLE, 
CX - -			ANNOUNCE THAT FACT AND HALT EXECUTION. 


	CALL LOADA(1,45,'INPUT FROM A LOG FILE?  (Y/<CR>=N/FILENAME)  ') 
	CALL WRITER(45,0) 
	CALL READER 
	CALL A5A1(RBUFA5,SEMBUF,10,1)

CX - -	INPUT TO SEMBUF TO SAVE IT IN CASE A FILE NAME WAS INPUT. 


	X = SEMBUF(1)
	IF(X.EQ.'Y') GO TO 250
	IF(X.EQ.'N'.OR.X.EQ.' ') GO TO 260
214	LOGIN = 'Y' 
	CALL MKFLNM(SEMBUF,LEFT1,RIGHT) 
	IF(RIGHT .EQ. ' ') GO TO 230 

CX - -	IF NO EXTENSION WAS SPECIFIED, GO TO 230. 

	FILERR = 1		! FILE ERROR CODE.
220	CALL DPFLNM(WHOLE, LEFT1, RIGHT)	! BUILD DP FILENAME.
	OPEN(UNIT=ILOGCH, ACCESS='SEQIN', FILE=WHOLE, ERR=219)

	READ(ILOGCH,221),(LBUFA1(I),I=1,100) 
CX - -	SUCCESSFUL OPENING OF LOG FILE. 
221	FORMAT(100A1) 
	DECODE(10,222,LBUFA1(17)) VERNUM 


CX - -	VERSIN NUMBER IS ALWAYS STORED IN THE 17TH COLUMN OF 
CX - -	THE FIRST LINE ON THE FILE. 


222	FORMAT(I) 
	IF(VERNUM .NE. VERSIN) CALL ERROR(7,0,0,0) 


CX - -	INTERACTIVELY WE WOULD ASK FOR THE REPORT CONTROL FILE 
CX - -	NAME, BUT SINCE WE ARE RUNNING FROM A LOG FILE, WE MUST RETRIEVE 
CX - -	THIS FILE NAME FROM THE LOG FILE. ITS POSITION IS THE 
CX - -	FIRST SIGNIFICANT LINE OF INPUT IN THE LOG FILE. 
CX - -	IF THE FILENAME IS LEGITIMATE, GO TO LINE 266, TO STORE 
CX - -	IT IN 'THING', ELSE TYPE AN ERROR MESSAGE. 


	CALL READER 
	CALL A5A1(RBUFA5,LBUFA1,10,1)
	IF(LBUFA1(1) .NE. 1H ) GO TO 266 


CX - -	TEST IF BLANK INPUT. IF WAS, CALL ERROR, ELSE PROCEED. 


	CALL ERROR(2,2,'FILE NAME ',0) 


CX - -	EXTENSION SPECIFIED, FILE NOT FOUND. 


224	WRITE(5,225),(SEMBUF(D),D=1,10) 
225	FORMAT(' ?ERROR -- INPUT FILE "',10A1,'" NOT FOUND.',/) 
	GO TO 250 


CX - -	THE ABOVE GIVES THE USER ANOTHER CHANCE TO INPUT A VALID AND 
CX - -	EXISTING FILENAME. 
CX - -	YOU GET HERE IF THE FILENAME THE USER INPUT HAD 
CX - -	NO EXTENSION. SO WE FIRST ATTEMPT TO LOCATE A FILE WITH 
CX - -	THE SPECIFIED FILE NAME+.DMR, THEN WE LOOK FOR 
CX - -	THAT NAME WITHOUT AN EXTENSION. WE DO IT IN THIS ORDER 
CX - -	BECAUSE IF THE USER NAMED HIS REPORT CONTROL FILE WITHOUT 
CX - -	AN EXTENSION, IF WE DIDN'T LOOK FOR THE NAME+.DMR FILE FIRST 
CX - -	WE WOULD FIND THE REPORT CONTROL FILE, AND ATTEMPT TO USE IT AS 
CX - -	A LOG FILE. 


219	GO TO (224, 231, 240), FILERR
C NEVER FALLS THRU, BASED ON TYPE OF ERROR.

230	RIGHT = 'DMR' 
	FILERR = 2
	GO TO 220 

CX - -	ERROR RETURN IF FILENAME NOT FOUND. 

231	RIGHT = ' '
	FILERR = 3
	GO TO 220 

CX - -	ERROR RETURN IF NEITHER EXTENSION WAS FOUND. 


240	WRITE(5,241),(SEMBUF(D),D=1,10),(SEMBUF(D),D=1,6) 
241	FORMAT(' ?ERROR -- INPUT FILES "',10A1,'" AND "',6A1, 
	2'.DMR" WERE NOT FOUND.',/) 
250	LOGIN = 'N' 
	CALL LOADA(1,30,'     SPECIFY INPUT LOG FILE:  ') 
	CALL WRITER(30,0) 
	CALL READER 
	CALL A5A1(RBUF15,SEMBUF,10,1)
	GO TO 214 


CX - -	NOW THAT YOU HAVE ANOTHER FILE NAME, GO THROUGH THE SAME ROUTINE 
CX - -	AS ABOVE, TO CHECK THIS ONE OUT. 
CX - -	WE GET TO LINE 260 WHEN THE PROGRAM IS TO OPERATE 
CX - -	IN INTERACTIVE MODE. HENCE WE TURN 'LOGIN' OFF, SIGNIFYING 
CX - -	INPUT IS NOT TO COME FROM A LOG FILE. WE USE A WRITE STATEMENT 
CX - -	HERE INSTEAD OF A CALL TO WRITER BECAUSE WE HAVE NOT YET CREATED 
CX - -	THE LOG FILE. WE NEED THE ANSWER TO THE 'NAME OF REPORT CONTROL 
CX - -	FILE' QUESTION BEFORE WE CAN CREATE THE LOG FILE. SO WE 
CX - -	USE A WRITE STATEMENT HERE, AND THE FIRST THING WE 
CX - -	DO, AFTER WE CREATE THE LOG FILE AND INPUT THE VERSIN 
CX - -	NUMBER, IS STORE THE QUESTION AND ANSWER OF THE 'NAME 
CX - -	OF REPORT CONTROL FILE' QUESTION IN THE LOG FILE BY HAND. 


260	LOGIN = 1HN 
5	CALL LOADA(1,38,'SPECIFY NAME OF REPORT CONTROL FILE:  ') 
	CALL WRITER(38,0) 
	CALL READER 
	CALL A5A1(RBUFA5,FLNM2,10,1)
	IF(FLNM2(1) .NE. 1H ) GO TO 263 


CX - -	IF BLANK, CALL FOR ANOTHER CHANCE AT INPUTTING A FILE NAME. 


	CALL ERROR(2,2,'FILE NAME ',0) 
	GO TO 260 
263	CALL MKFLNM(FLNM2,LEFT2,RIGHT2) 
	IF(RIGHT2 .NE. 'DMR') GO TO 3 
	WRITE(5,4) 
4	FORMAT(' ?ERROR -- CANNOT HAVE .DMR EXTENSION.',/) 
	GO TO 5 


CX - -	WE CANNOT LET THIS FILE HAVE A .DMR EXTENSION BECAUSE 
CX - -	THEN THE REPORT CONTROL FILE, AS WELL AS THE LOG FILE, WOULD 
CX - -	BE TRYING TO INPUT INTO THE SAME FILE, WITH 
CX - -	DISASTROUS RESULTS. 
CX - -	SO NOW CREATE THE LOG WITH THE NAME OF THE 
CX - -	REPORT CONTROL FILE AND THE AUTOMATIC EXTENSION .DMR. 


3	RIGHT2 = 'DMR' 
	CALL DPFLNM(WHOLE, LEFT2, RIGHT2)
	OPEN(UNIT=OLOGCH, ACCESS='SEQOUT', FILE=WHOLE)

	CALL LOADA(1,17,'VERSION #        ') 
	CALL Q3DIG(10,1HL,VERSIN) 
	WRITE(OLOGCH,264),(LDBUF(D),D=1,17) 
264	FORMAT('     : ',17A1) 


CX - -	HERE WE STORE THE VERSION NUMBER, STORED IN THE VARIABLE 
CX - -	VERSIN. IT IS STORED IN THE LOG FILE AS A COMMENT, IN 
CX - -	THE FOLLOWING FORMAT: 
CX 
CX - -	     : VERSION #4 
CX 
CX - -	THIS IS THE FIRST LINE IN ANY LOG FILE. THE PROGRAM KNOWS 
CX - -	THAT THE VERSION NUMBER BEGINS IN COLUMN 17 OF THIS LINE. 

	WRITE(OLOGCH,265),(FLNM2(D),D=1,10) 
265	FORMAT('     : SPECIFY NAME OF REPORT CONTROL FILE:', 
	2/,10A1) 


CX - -	NEED TO DO THIS BY HAND BECAUSE DMPFLG IS STILL OFF. 
CX - -	NOTHING YET HAS GONE INTO THE LOG FILE FROM CALLS TO READER 
CX - -	OR WRITER. 


	CALL A1A5(RBUFA5,FLNM2,10,1)


CX - -	AT THIS POINT WE HAVE THE REPORT CONTROL FILE NAME, EITHER 
CX - -	THROUGH INTERACTIVE QUESTIONING OR BY RETRIEVING IT FROM A 
CX - -	LOG FILE, IN RBUFA5, WHERE WE NOW SIMPLY STORE IT 
CX - -	IN 'THING', WITH THE POINTER 'OUTP3' TO IT. 
CX - -	THE POINTER IS SET AT THGPTR+1 BECAUSE THGPTR 
CX - -	ALWAYS POINTS TO THE LAST POSITION USED IN 'THING', 
CX - -	AND WE WANT THE FIRST POSITION FREE, WHICH IS THE NEXT 
CX - -	ONE. THE CALL TO PSHTHG ALWAYS INCREMENTS THGPTR 
CX - -	AUTOMATICALLY, BY THE NUMBER OF WORDS THAT ARE DUMPED INTO 
CX - -	'THING'. 


266	OUTP3 = THGPTR + 1 
	CALL PSHTHG(2) 
	DMPFLG = 'Y' 


CX - -	NOW THAT THE LOG FILE IS PROPERLY SET UP, YOU CAN TURN THIS 
CX - -	FLAG OFF, AND USE WRITER AND READER PROPERLY. 


	CALL LOADA(1,37,'SPECIFY NAME OF REPORT OUTPUT FILE:  ') 
	CALL WRITER(37,0) 
	CALL READER 
	CALL A5A1(RBUFA5,LBUFA1,150,1)
	IF(LBUFA1(1) .EQ. 1H ) GO TO 278 
	OUTFIL = THGPTR + 1 
	CALL PSHTHG(ENDBUF(0)) 
	IF(LBUFA1(1) .EQ. 'T' .AND. LBUFA1(2) .EQ. 'T' .AND. 
	2 LBUFA1(3) .EQ. 'Y' .AND. LBUFA1(4) .EQ. ':') GO TO 275 


CX - -	IF ANSWER WAS TTY:, WE HAVE SPECIAL QUESTION NEXT. 


274	CALL LOADA(1,49,'REPORT DESTINATION TTY, LPT, OR OTHER? 
	2  (T/L/O)  ') 
	CALL WRITER(49,0) 
	CALL READER 
	IF(RBUFA5(1) .EQ. 'T') GO TO 275 
	IF(RBUFA5(1) .EQ. 'L') GO TO 277 
	IF(RBUFA5(1) .EQ. 'O') GO TO 273 
	CALL ERROR(6,0,0,0) 
	GO TO 274 
276	CALL LOADA(1,45,'STANDARD PAGE SIZE CONVENTIONS?  (<CR>=Y/N)  ') 
	CALL WRITER(45,0) 
	CALL YESNO 
	IF(RBUFA5(1) .NE. 'N') GO TO 320 
273	CALL LOADA(1,19,'     PAGE LENGTH?  ') 
	CALL WRITER(19,0) 
	CALL READER 
	DECODE(10,271,RBUFA5) PAGLEN 
271	FORMAT(I) 
	IF(PAGLEN .GT. 0) GO TO 272 
	CALL ERROR(2,3,'PAGE LENGTH    ',0) 
	GO TO 273 
272	CALL LOADA(1,18,'     LINE WIDTH?  ') 
	CALL WRITER(18,0) 
	CALL READER 
	DECODE(10,271,RBUFA5) LWIDTH 
	IF(LWIDTH .GT. 0) GO TO 320 
	CALL ERROR(2,3,'LINE WIDTH     ',0) 
	GO TO 272 
275	PAGLEN = 60 
	LWIDTH = 72 
	GO TO 276 
277	PAGLEN = 60 
	LWIDTH = 132 
	GO TO 276 


CX - -	WANT NO 'INIT ...' COMMAND, SO STORE A ^ AS SIGNAL 
CX - -	FOR THIS. 


278	OUTFIL = THGPTR + 1 
	CALL DPAROW
	GO TO 274 


CX - -	**************************************************************** 
CX - -	IN THE FOLLOWING SECTION THE PROGRAM WILL INPUT AND 
CX - -	STORE THE NAME OF THE DATA BASE IN 'THING' WITH A 
CX - -	A POINTER TO IT IN 'DATNAM', AND THE FNDSTR THE USER 
CX - -	INPUTS AS WHAT HE WANTS TO 'FIND' GOES IN 'THING', WITH 
CX - -	A POINTER TO IT IN 'FNDSTR'. 


320	CALL LOADA(1,37,'WHAT IS THE NAME OF THE DATA BASE?   ') 
	CALL WRITER(37,0) 
	CALL READER 
	IF(RBUFA5(1) .EQ. 1H ) GO TO 340 
	DATNAM = THGPTR + 1 
	CALL PSHTHG(ENDBUF(0)) 
	GO TO 370
340	DATNAM = THGPTR + 1
	CALL DPAROW


CX - -	AN UPARROW IN THING(DATNAM) INDICATES NO 'OPEN ...'
CX - -	COMMAND IN THE REPORT CONTROL FILE.

370	CALL LOADA(1,45,'WANT TO ''FIND'' ANYTHING? 
	2  (Y/<CR>=N/STRING)  ') 
	CALL WRITER(45,0) 
	CALL READER 
	IF(RBUFA5(1) .EQ. 1HY) GO TO 400 
	IF(RBUFA5(1) .EQ. 1H  .OR. RBUFA5(1) .EQ. 1HN) GO TO 395 
	GO TO 406 
395	FNDSTR = THGPTR + 1 
	CALL DPAROW 


CX - -	YOU INDICATED THAT NO FIND STRING WAS WANTED, SO THE PROGRAM 
CX - -	STORES A ^ IN 'THING' WITH 'FNDSTR' POINTING TO IT. 
CX - -	ALL SUBROUTINE DPAROW DOES IS TO STORE A ^ IN 'THING' IN 
CX - -	THE NEXT LOCATION AND INCREMENT THGPTR. 


	GO TO 420 
400	CALL LOADA(1,25,'     INPUT FIND STRING:  ') 
	CALL WRITER(25,0) 
	CALL READER 
406	FNDSTR = THGPTR + 1 
	CALL PSHTHG(ENDBUF(0)) 


CX - -	ENDBUF IS A FUNCTION THAT RETURNS THE NUMBER OF SIGNIFICANT 
CX - -	WORDS IN RBUFA5, STARTING FROM THE LEFT END OF THE LINE. 
CX - -	THIS DETERMINES HOW MANY OF THE FIRST WORDS OF RBUFA5 
CX - -	HAVE TO BE PUSHED BY PSHTHG INTO 'THING'. 
CX - -	**************************************************************** 
CX - -	IN THIS SECTION THE USER MUST INPUT THE SORTING 
CX - -	ORDER HE WANTS TO USE, WHETHER THE DATA BASE IS 
CX - -	SORTED ALREADY OR NOT, BECAUSE THIS SRTLST WILL DRIVE 
CX - -	SEVERAL OF THE REMAINING LOOPS IN THE PROGRAM. 


420	CALL LOADA(1,50,'IS THE DATA BASE ALREADY SORTED? 
	2  (Y/ <CR> = N)   ') 
	CALL WRITER(50,0) 
	CALL YESNO 
	IF(RBUFA5(1) .EQ. 1HY) GO TO 610 
	CALL LOADA(1,46,'ENTER SORT ORDER, FROM 
	2 OUTERMOST TO INNERMOST:') 
	CALL WRITER(46,1) 
500	CALL LOADA(1,18,'     (<CR> TO END)') 
	CALL WRITER(18,1) 
	DO 590 SRTNU0 = 1,MXSLEV 
	SRTNUM = SRTNU0
	CALL LOADA(1,7,'     * ') 
	CALL WRITER(7,0) 
	CALL READER 


CX - -	IF THE USER TYPES A 'D' FOLLOWED BY A SPACE AT THE BEGINNING 
CX - -	OF THE INPUT LINE, THIS IS A SIGNAL THAT THAT ATTRIBUTE 
CX - -	IS TO BE SORTED DESCENDING. WE CHECK THE THIRD CHARACTER 
CX - -	ON THE LINE TO MAKE SURE THAT THE LINE WAS NOT EMPTY AFTER 
CX - -	THE 'D', WHICH, BY ITSELF, IS THE SORT ATTRIBUTE 'D'. 
CX - -	STORE A 'D' IN MATRIX UPDOWN IN PROPER POSITION TO 
CX - -	HOLD FOR LATER OUTPUT OF 'DESCENDING' IN 'SORT BY ...' 
CX - -	COMMAND. 


	CALL A5A1(RBUFA5,LBUFA1,150,1)
	IF(LBUFA1(1) .EQ. 'D' .AND. LBUFA1(2) .EQ. ' ' 
	2 .AND. LBUFA1(3) .NE. ' ') GO TO 605 
560	SRTLST(SRTNUM) = THGPTR + 1 
	CALL PSHTHG(ENDBUF(0)) 
	SRTLST(SRTNUM+1) = THGPTR + 1 
	IF(RBUFA5(1) .EQ. 1H ) GO TO 670 


CX - -	TO CATCH END OF INPUT, I.E. A BLANK LINE. 


590	CONTINUE 
	GO TO 940 
605	UPDOWN(SRTNUM) = 'D' 


CX - -	THIS MATRIX WILL CONTAIN A 'D' IN THE PROPER POSITION FOR 
CX - -	ANY SORT EXPRESSION THAT HAS TO BE SORTED DESCENDING. 
CX - -	THE 'D ' IS STRIPPED AWAY FROM THE FRONT OF THE LINE, WHICH IS 
CX - -	REPLACED BACK IN RBUFA5 FOR THE PUSH TO OCCUR LATER. 


	DO 606 F0 = 1,148 
	F = F0
606	LBUFA1(F) = LBUFA1(F+2) 
	CALL A1A5(RBUFA5,LBUFA1,148,1)
	GO TO 560 


CX - -	IF THE USER INDICATED THAT THE DATA BASE WAS 
CX - -	ALREADY SORTED, THE VARBLE 'WSSRTD' IS SET TO 'Y', AND 
CX - -	THE USER STILL HAS TO INPUT A SRTLST, WHICH WILL DRIVE 
CX - -	SOME OF THE LOOPS IN THE TOTALS SEGMENTS OF THIS PROGRAM. 


610	CALL LOADA(1,39,'ENTER SORT ORDER USED 
	2 IN THE DATA BASE:') 
	CALL WRITER(39,1) 
	WSSRTD = 1HY 
	GO TO 500 


CX - -	IF FIRST ONE WAS BLANK, THEN NO ATTRIBUTES WERE INPUT, 
CX - -	INPUT. MUST HAVE AT LEAST ONE, SO 
CX - -	GIVE ANOTHER CHANCE TO INPUT SOME. 


670	IF(THING(SRTLST(1)) .NE. 1H ) GO TO 710 


CX - -	THERE MUST BE AT LEAST ONE SORT EXPRESSION. IF THE 
CX - -	FIRST ONE THE USER INPUT WAS BLANK, THEN THIS 
CX - -	TEST WILL CATCH THAT, AND MAKE HIM GO BACK AND INPUT 
CX - -	AT LEAST ONE SORT EXPRESSION. 


	CALL ERROR(1,0,0,0) 
	GO TO 420 


CX - -	THERE WILL BE A FEW OCCURRENCES OF THE FOLLOWING SITUATION. 
CX - -	WHEN INSIDE A LOOP BOUNDED BY A MAX---, IF THE LOOP RUNS 
CX - -	TO COMPLETION, THEN THAT VALUE WILL BE CORRECT AND WILL 
CX - -	REQUIRE NO CHANGE. BUT IF THE LOOP IS EXITTED PREMATURELY, 
CX - -	WE WANT THE MAX--- TO STILL REFLECT THE MAXIMUM NUMBER OF 
CX - -	--- USED, SO WE SET IT TO (---NUM - 1). THIS 
CX - -	COUNTERACTS THE FACT THAT ---NUM WAS INCREMENTED FOR THE 
CX - -	NEXT ITERATION OF THE LOOP EVEN THOUGH THE LOOP WAS EXITTED 
CX - -	ON THAT ITERATION, SO THE ---NUM WAS ONE TOO MANY. 


710	MXSLEV = SRTNUM - 1 


CX - -	**************************************************************** 
CX - -	THE FOLLOWING SECTION INPUTS THE TEXT FOR THE 
CX - -	COVER PAGE, SHOULD THE USER DESIRE ONE. THE FORMAT STATEMENT 
CX - -	WILL SUPPRESS THE NORMAL HDINGS ON THE PAGE. 


940	CALL LOADA(1,50,'ENTER TEXT FOR COVER PAGE, 
	2 TERMINATE WITH "DONE":') 
	CALL WRITER(50,1) 
	DO 1030 LINNU0=1,MXCLIN 
	LINNUM = LINNU0
	CALL LOADA(1,7,'     * ') 
	CALL WRITER(7,0) 
	CALL READER 
	CVPAGE(LINNUM) = THGPTR + 1 
	CALL PSHTHG(ENDBUF(0)) 
	CVPAGE(LINNUM+1) = THGPTR + 1 


CX - -	THIS INPUTS THE TWO POINTERS TO THE BEGINNING AND END OF THE 
CX - -	ENTRY MADE IN THING, TO THEIR PROPER STORAGE LOCATIONS. 
CX - -	THE NEXT ITERATION OF THE LOOP, THE POINTER WHICH WAS 
CX - -	JUST PLACED IN LINNUM+1 WILL AGAIN BE PLACED IN 
CX - -	LINNUM, SINCE LINNUM HAS BEEN INCREMENTED. THUS, 
CX - -	SOME REPETITION IS INVOLVED, BUT THIS INSURES THAT THERE 
CX - -	WILL BE A FINAL POINTER AS A PLACEHOLDER IN THE SEQUENCE OF 
CX - -	POINTERS. 


	CALL A5A1(RBUFA5,LBUFA1,150,1)
	IF(LBUFA1(1) .EQ. 'D' .AND. LBUFA1(2) .EQ. 'O' .AND. 
	2 LBUFA1(3) .EQ. 'N' .AND. LBUFA1(4) .EQ. 'E') GO TO 1050 
1030	CONTINUE 


CX - -	IF THE USER INPUT A "DONE" TO INDICATE THE END OF THE TEXT, 
CX - -	THIS CATCHES THAT AND SENDS THE PROGRAM ON ITS WAY. 


	GO TO 1060 


CX - -	**************************************************************** 
CX - -	THE FOLLOWING SECTION INPUTS THE HDING TEXT AND FOOTING  THAT 
CX - -	WILL APPEAR ON EVERY PAGE, AND THE DATE, PAGE, AND 
CX - -	TIME, IF THE USER WISHES. 


1050	MXCLIN = LINNUM-1 
1060	CALL LOADA(1,46,'ENTER TEXT FOR HEADING, TER
	2MINATE WITH "DONE":') 
	CALL WRITER(46,1) 
	DO 1150 HDNUM0=1,MXHLIN 
	HDNUM = HDNUM0
	CALL LOADA(1,7,'     * ') 
	CALL WRITER(7,0) 
	CALL READER 
	HDING(HDNUM) = THGPTR + 1 
	CALL PSHTHG(ENDBUF(0)) 
	HDING(HDNUM+1) = THGPTR + 1 
	CALL A5A1(RBUFA5,LBUFA1,150,1)
	IF(LBUFA1(1) .EQ. 'D' .AND. LBUFA1(2) .EQ. 'O' .AND. 
	2 LBUFA1(3) .EQ. 'N' .AND. LBUFA1(4) .EQ. 'E') GO TO 1170 
1150	CONTINUE 
	GO TO 1180 
1170	MXHLIN = HDNUM-1 
1180	CALL LOADA(1,29,'WANT A FOOTING?  (Y/<CR>=N)  ') 
	CALL WRITER(29,0) 
	CALL YESNO 
	WNTFOT = RBUFA5(1) 
	IF(WNTFOT .EQ. 1HN) GO TO 1230 
	IF(WNTFOT .EQ. 1H ) GO TO 1230 
1223	CALL LOADA(1,28,'     HOW MANY LINES IN IT?  ') 
	CALL WRITER(28,0) 
	CALL READER 
	DECODE(10,1221,RBUFA5) FLINES 
1221	FORMAT(I) 
	IF(FLINES .GT. 0) GO TO 1222 
	CALL ERROR(2,4,'NUMBER OF LINES     ',0) 
	GO TO 1223 
1222	CALL LOADA(1,34,'     WANT TEXT?  (Y/<CR>=N/TEXT)  ') 
	CALL WRITER(34,0) 
	CALL READER 
	IF(RBUFA5(1) .EQ. 1HY) GO TO 1 
	IF(RBUFA5(1) .EQ. 1H  .OR. RBUFA5(1) .EQ. 1HN) GO TO 1224 
	GO TO 2 
1	CALL LOADA(1,23,'          INPUT TEXT:  ') 
	CALL WRITER(23,0) 
	CALL READER 
2	FTTEXT(1) = THGPTR + 1 
	CALL PSHTHG(ENDBUF(0)) 
	FTTEXT(2) = THGPTR + 1 
	GO TO 1230 
1224	FTTEXT(1) = '^' 
1230	CALL LOADA(1,38,'STANDARD PAGE HEADINGS?  (<CR>=Y/N)   ') 
	CALL WRITER(38,0) 
	CALL YESNO 
	IF(RBUFA5(1) .EQ. 'N') GO TO 1231 
	WPGNUM = 'Y' 
	WNTDAT = 'Y' 
	WNTTIM = 'Y' 
	BLANKS = 2 
	GO TO 1330 
1231	CALL LOADA(1,37,'     WANT PAGE NUMBERS?  (<CR>=Y/N)  ') 
	CALL WRITER(37,0) 
	CALL YESNO 
	WPGNUM = RBUFA5(1) 
	CALL LOADA(1,29,'     WANT DATE?  (<CR>=Y/N)  ') 
	CALL WRITER(29,0) 
	CALL YESNO 
	WNTDAT = RBUFA5(1) 
	CALL LOADA(1,29,'     WANT TIME?  (<CR>=Y/N)  ') 
	CALL WRITER(29,0) 
	CALL YESNO 
	WNTTIM = RBUFA5(1) 
1232	CALL LOADA(1,42,'     NUMBER OF BLANK LINES AFTER TITLES?  ') 
	CALL WRITER(42,0) 
	CALL READER 
	DECODE(10,1233,RBUFA5) BLANKS 
1233	FORMAT(I) 
	IF(BLANKS .GT. 0) GO TO 1330 
	CALL ERROR(2,3,'BLANK LINES    ',0) 
	GO TO 1232 
 


CX - -	**************************************************************** 
CX - -	HERE THE USER WILL INPUT THE INFORMATION FOR HIS FIELDS. 
CX - -	THIS INFORMATION IS STORED IN MATRICES TILL THE LATTER 
CX - -	HALF OF THE PROGRAM, WHERE IT IS FORMATTED AND DUMPED 
CX - -	INTO THE RECEIVING FILE. THE USER HAS TWO CHOICES AS TO 
CX - -	THE TYPE OF FIELD HE WANTS - TEXT, OR EXPRESSION. IF 
CX - -	TEXT, HE MAY INPUT ANY TEXT STRING HE WANTS, AS LONG AS IT 
CX - -	IS SHORTER THAN, OR THE SAME SIZE AS, HIS FIELD WIDTH. 
CX - -	IF AN EXPRESSION, HE MAY INPUT ANY EXPRESSION HE WISHES. 


1330	SFWIDS = 0 
	DO 2020 FLDNU0 = 1,MXFLDS 
	FLDNUM = FLDNU0
	CALL LOADA(1,12,'FIELD #    :') 
	CALL Q3DIG(9,1HR,FLDNUM) 
	CALL WRITER(12,1) 
	CALL LOADA(1,42,'     EXPRESSION, "TEXT", OR <CR> TO END:  ') 
	CALL WRITER(42,0) 
	CALL READER 
	CALL A5A1(RBUFA5,LBUFA1,150,1)
	IF(LBUFA1(1) .EQ. 1H") GO TO 1600 
	IF(LBUFA1(1) .EQ. 1H ) GO TO 2040 
	FIELD(FLDNUM,1) = 'E' 
	FIELD(FLDNUM,2) = THGPTR + 1 
	CALL PSHTHG(ENDBUF(0)) 
	FIELD(FLDNUM,3) = THGPTR + 1 
1455	CALL LOADA(1,19,'     FIELD WIDTH:  ') 
	CALL WRITER(19,0) 
	CALL READER 
	DECODE(10,1460,RBUFA5) FIELD(FLDNUM,4)
1460	FORMAT(I) 
	IF(FIELD(FLDNUM,4) .GT. 0) GO TO 1780 
	CALL ERROR(2,3,'FIELD WIDTH    ',0) 
	GO TO 1455 
1600	FIELD(FLDNUM,1) = 'T' 
	DO 1610 LOOK0 = 2,150 
	LOOK = LOOK0
1610	IF(LBUFA1(LOOK) .EQ. 1H") GO TO 1620 
	CALL ERROR(9,0,0,0) 
	CALL LOADA(1,29,'          INPUT TEXT IN "":  ') 
	CALL WRITER(29,0) 
	CALL READER 
	CALL A5A1(RBUFA5,LBUFA1,150,1)
	GO TO 1600 
1620	LBUFA1(LOOK) = 1H 
	DO 1625 FREE0 = 1,30 
	FREE = FREE0
1625	RBUFA5(FREE) = 1H 
	CALL A1A5(RBUFA5,LBUFA1,LOOK-2,2)
	FIELD(FLDNUM,2) = THGPTR + 1 
	CALL PSHTHG(ENDBUF(0)) 
	FIELD(FLDNUM,3) = THGPTR + 1 
1630	CALL LOADA(1,19,'     FIELD WIDTH:  ') 
	CALL WRITER(19,0) 
	CALL READER 
	DECODE(10,1640,RBUFA5) FIELD(FLDNUM,4) 
1640	FORMAT(I) 
	IF(FIELD(FLDNUM,4) .GT. 0) GO TO 2010 
	CALL ERROR(2,3,'FIELD WIDTH    ',0) 
	GO TO 1630 
1780	CALL LOADA(1,42,'     SPECIAL FORMAT?   (Y/<CR>=N/FORMAT)  ') 


CX - -	THE USER CAN INPUT THE FORMAT ON THIS LINE, OR HE CAN 
CX - -	ANSWER 'Y' HERE, AND INPUT THE FORMAT ON THE NEXT LINE. 


	CALL WRITER(42,0) 
	CALL READER 
	IF(RBUFA5(1) .EQ. 1HY) GO TO 1820 
	IF(RBUFA5(1) .EQ. 1H  .OR. RBUFA5(1) .EQ. 1HN) GO TO 1860 
	GO TO 1850 
1820	CALL LOADA(1,33,'          INPUT DESIRED FORMAT:  ') 
	CALL WRITER(33,0) 
	CALL READER 
1850	FIELD(FLDNUM,5) = THGPTR + 1 
	CALL PSHTHG(ENDBUF(0)) 
	GO TO 1880 


CX - -	NO SPECIAL FORMAT WAS INPUT, SO SET UP FOR THE DEFAULT FORMAT. 


1860	FIELD(FLDNUM,5) = THGPTR + 1 
	CALL DPAROW 


CX - -	NO PLACEHOLDER IS STORED BECAUSE THE FORMAT AND TITLE ARE 
CX - -	ALWAYS STORED CONSECUTIVELY, SO FIELD(FLDNUM,6) IS 
CX - -	ALWAYS THE ENDMARKER OF THE FORMAT AND THE STARTMARKER 
CX - -	OF THE TITLE. 


1880	CALL LOADA(1,37,'     FIELD TITLE?  (Y/<CR>=N/TITLE)  ') 
	CALL WRITER(37,0) 


CX - -	THE FOLLOWING TELL THE READING ROUTINES THAT THE ANSWER IS 
CX - -	TO BE CHANGED INTO SPECIAL SCROLLING FORMAT. ALL OCCURRENCES 
CX - -	OF THE STRING '^/' ARE TO BE REDUCED TO SLASH, AND ALL 
CX - -	SLASHES ARE CONTROL CHARACTERS FOR THE SCROLLING, AND HENCE 
CX - -	ARE CHANGED TO "21004020100. 


	SCRFLG = 'T' 
	CALL READER 
	SCRFLG = 'N' 
	IF(RBUFA5(1) .EQ. 1HY) GO TO 1897 
	IF(RBUFA5(1) .EQ. 1H  .OR. RBUFA5(1) .EQ. 1HN) GO TO 1890 
	GO TO 1920 
1890	FIELD(FLDNUM,6) = THGPTR + 1 
	CALL DPAROW 
	FIELD(FLDNUM,7) = THGPTR + 1 
	GO TO 1970 


CX - -	LINES 1890-1895 INDICATE NO TITLE WAS INPUT. THE SECOND POINTER WAS 
CX - -	STORED AS A PLACEHOLDER. CONTINUE WITH TOTALLABLE QUESTION 
CX - -	AT LINE 1970. 


1897	IF(FIELD(FLDNUM,4) .GE. 3) GO TO 1898 


CX - -	A FIELD TITLE CANNOT EXIST IN A FIELD WIDTH OF LESS THAN THREE. 
CX - -	THE MINIMUM ENTRY ON ANY LINE CAN BE A CHARACTER, A HYPHEN, 
CX - -	AND A SPACE. THUS, A FIELD WIDTH OF LESS THAN THREE CANNOT 
CX - -	HANDLE A TITLE. 


	WRITE(5,1899) 
1899	FORMAT(' ?ERROR -- FIELD TOO SMALL FOR TITLE. NON-FATAL.',/) 
	GO TO 1890 
1898	CALL LOADA(1,43,'          INPUT TITLE (<CR> = 
	2 EXPRESSION)  ') 
	CALL WRITER(43,0) 
	SCRFLG = 'T' 
	CALL READER 
	SCRFLG = 'N' 
1920	FIELD(FLDNUM,6) = THGPTR + 1 
	IF(RBUFA5(1) .NE. 1H ) GO TO 1940 


CX - -	THE USER INPUT A <CR> INDICATING THAT HE WOULD LIKE TO USE 
CX - -	THE EXPRESSION AS THE TITLE. THEREFORE, WE MUST LOAD IT INTO 
CX - -	RBUFA5,  SINCE SUBROUTINE SCROLL TAKES ITS ARGUMENT 
CX - -	IN RBUFA5; WE SIMPLY USE THE POINTERS TO THE EXPRESSION 
CX - -	STORED IN FIELD(FLDNUM,2) AND FIELD(FLDNUM,3) 
CX --	AND SET UP A LOOP TO MOVE OVER THE CORRECT NUMBER OF WORDS 
CX - -	FROM THAT ENTRY IN THING TO RBUFA5, FROM WHICH WE WILL 
CX - -	CALL SCROLL. 


	DO 1934 FREE0 = 1,30 
	FREE = FREE0
1934	RBUFA5(FREE) = 1H 


CX - -	CLEAR THE BUFFER. 


	DO 1936 A0 = FIELD(FLDNUM,2),FIELD(FLDNUM,3)-1 
	A = A0
1936	RBUFA5(A-FIELD(FLDNUM,2)+1) = THING(A) 


CX - -	WE WOULD HAVE GOTTEN TO LINE 1940 ANYWAY, BECAUSE HAD THE USER 
CX - -	NOT INPUT 
CX - -	A <CR> AT THAT POINT, THEN THERE WOULD HAVE BEEN TEXT THERE, 
CX - -	AND WE WOULD HAVE JUMPED RIGHT HERE TO SCROLL THAT TEXT. 


1940	CALL SCROLL(FIELD(FLDNUM,4)) 
	CALL PSHTHG(ENDBUF(0)) 
	FIELD(FLDNUM,7) = THGPTR + 1 


CX - -	THIS IS THE PLACEHOLDER POINTER. 


1970	CALL LOADA(1,31,'     TOTALLABLE?  (Y/<CR>=N)   ') 
	CALL WRITER(31,0) 
	CALL YESNO 
	FIELD(FLDNUM,8) = RBUFA5(1) 
2010	SFWIDS = SFWIDS + FIELD(FLDNUM,4) 


CX - -	KEEP A RUNNING TOTAL OF ALL THE SPACE USED ON THE LINE 
CX - -	FOR THE FIELDS. 


2020	CONTINUE 
	GO TO 2090 
2040	IF(FLDNUM .NE. 1) GO TO 2080 
	CALL ERROR(4,0,0,0) 
	GO TO 1330 


CX - -	**************************************************************** 
CX - -	IF THE COMBINED FIELD WIDTHS SPECIFIED OVERFLOWED 
CX - -	THE LWIDTH THE USER DECLARED, THE PROGRAM WILL 
CX - -	READJUST ACCORDINGLY, AFTER WARNING THE USER OF THIS OCCURRENCE. 


2080	MXFLDS = FLDNUM - 1 
2090	IF(SFWIDS .LE. LWIDTH) GO TO 2140
	LWIDTH = SFWIDS
	CALL ERROR(5,0,0,LWIDTH)

CX - -**************************************************************** 
CX - -	IF THE USER DOESN'T WANT THE DETAIL LINES TO BE PRINTED OUT, 
CX - -	HE CAN CAUSE THE 'PRINT' COMMAND IN THE REPORT CONTROL FILE 
CX - -	TO BE THIS:  'PRINT.'   IF HE ANSWERS 'Y' TO THIS QUESTION. 


2140	CALL LOADA(1,40,'SUMARY REPORTING ONLY?  (Y/ <CR> = N)  ') 
	CALL WRITER(40,0) 
	CALL YESNO 
	SUMARY = RBUFA5(1) 


CX - -	**************************************************************** 
CX - -	THE FOLLOWING SECTION WILL ASK FOR THE SUBTITLES THE 
CX - -	USER WISHES FOR THE 'ON CHANGE ...' STATEMENTS. 
CX - -	THE TOTAL DEFAULT SECTION BEGINS AT 2550. NOTICE FLAG1: 
CX - -	THIS FLAG DENOTES, WHEN IT IS EQUAL TO 1HY, THAT WE 
CX - -	WISH TO GENERATE A SINGLE DEFAULT CASE, AND WE 
CX - -	ARE USING THE SAME CODE AS THE TOTAL DEFAULT GEN- 
CX - -	ERATOR, BUT ONLY FOR ONE 'ON CHANGE ...' STATEMENT. 
CX - -	SO WE USE THE FLAG TO LET US KNOW, INSIDE THE LOOP, WHETHER 
CX - -	WE HAVE TO GET OUT OR NOT. 


	CALL LOADA(1,48,'TITLES ON ATTRIBUTE
	2 CHANGES? (Y/N/<CR>=DEFAULT)  ') 
	CALL WRITER(48,0) 
	CALL YESNO 
	WNTSRT = RBUFA5(1) 
	IF(WNTSRT .EQ. 1HN) GO TO 2970 


CX - -	THIS IS THE 'Y' CASE, WHERE THE USER INPUTS HIS OWN INFORMATION. 


	IF(WNTSRT .EQ. 1H ) GO TO 2550 
	DO 2530 VAR0 = 1,MXSLEV 
	VAR = VAR0
	CALL LOADA(1,19,'     ON CHANGE OF ''') 
	CALL UNPACK(SRTLST,VAR,PTR) 


CX - -	THIS HANDY LITTLE SUBROUTINE TAKES AN ENTRY IN 'THING' AND 
CX - -	LEAVES IT IN A1 FORMAT IN LBUFA1, WITH THE THIRD ARGUMENT 
CX - -	CONTAINING THE NUMBER OF SIGNIFICANT CHARACTERS IN THE 
CX - -	STRING. THE FORMAT OF THIS CALL IS THAT THE SUBROUTINE 
CX - -	KNOWS THAT THE POINTER, THE SECOND ARGUMENT, ALWAYS POINTS 
CX - -	TO THE BEGINNING OF THE ENTRY, AND THIS POINTER + 1 
CX - -	ALWAYS POINTS TO THE END OF THAT ENTRY ACCORDING 
CX - -	TO THE CONVENTION EXPLAINED EARLIER. SO IT KNOWS 
CX - -	EXACTLY WHERE, AND HOW MUCH, TO UNPACK. 


	DO 2295 A0 = 20,19+PTR 
	A = A0
2295	LDBUF(A) = LBUFA1(A-19) 
	A = PTR + 20 
	CALL LOADA(A,29,'''?  (Y/N/ <CR> FOR DEFAULT)  ') 
	CALL WRITER(48+PTR,0) 


CX - -	THIS PRINTS SOMETHING OF THE FORM: 
CX 
CX - -	ON CHANGE OF 'STATE'?  (Y/N/<CR>=DEFAULT) 
CX 
CX - -	WHERE STATE IS A SORT EXPRESSION. 


	CALL YESNO 
	IF(RBUFA5(1) .EQ. 1HN) GO TO 2541 
	IF(RBUFA5(1) .EQ. 1H ) GO TO 2770 
	CALL LOADA(1,38,'          INPUT SUB 
	2TITLE EXPRESSION:  ') 
	CALL WRITER(38,0) 
	CALL READER 
	ONCHNG(VAR,1) = THGPTR + 1 
	CALL PSHTHG(ENDBUF(0)) 
	ONCHNG(VAR,2) = THGPTR + 1 


CX - -	THIS STORES THE POINTERS TO THE STUFF THAT'S PRINTED IN 
CX - -	AN 'ON CHANGE' STATEMENT. IF THE FORMAT OF THAT IS: 
CX 
CX - -	ON CHANGE [A] PRINT [B] FORMAT [C] END. 
CX 
CX - -	THEN THIS INPUTS THE [B] PART. THE [A] PART COMES FROM THE 
CX - -	SRTLST. 


	CALL LOADA(1,39,'          INPUT 
	2 FORMAT:  (TEXT IN "")  ') 
	CALL WRITER(39,0) 
	CALL READER 
	ONCHNG(VAR,3) = THGPTR + 1 
	CALL PSHTHG(ENDBUF(0)) 
	ONCHNG(VAR,4) = THGPTR + 1 


CX - -	THIS INPUTS THE [C] PART MENTIONED ABOVE. 


2530	CONTINUE 
	GO TO 2970 
2541	ONCHNG(VAR,1) = THGPTR + 1 
	ONCHNG(VAR,2) = THGPTR + 2 
	CALL DPAROW 
	CALL DPAROW 
	ONCHNG(VAR,3) = THGPTR 
	ONCHNG(VAR,4) = THGPTR + 1 
	GO TO 2530 


CX - -	ABOVE IS THE SECTION THAT GENERATES THE DEFAULT CASES 
CX - -	FOR THE 'ON CHANGE' STATEMENTS. 
CX - -	**************************************************************** 
CX 
CX - -	BELOW, WE HAVE THE DEFAULT GENERATOR FOR THE 'ON CHANGE' 
CX - -	COMMANDS. 


2550	DO 2751 VAR0 = 1,MXSLEV 
	VAR = VAR0
2560	ONCHNG(VAR,1) = SRTLST(VAR) 
	ONCHNG(VAR,2) = SRTLST(VAR+1) 
	SEMBUF(1) = 1H" 
	DO 2600 J0 = 2,5*VAR+1 
	J = J0
2600	SEMBUF(J) = 1H 
	J = 5*VAR+1 
	CALL UNPACK(SRTLST,VAR,PTR) 
	DO 2650 K0 = J+1,J+PTR 
	K = K0
2650	SEMBUF(K) = LBUFA1(K-J) 
	K = J+PTR+1 
	SEMBUF(K) = 1H: 
	SEMBUF(K+1) = 1H 
	SEMBUF(K+2) = 1H 
	SEMBUF(K+3) = 1H 
	SEMBUF(K+4) = 1H" 
	SEMBUF(K+5) = 1H 
	SEMBUF(K+6) = 1HG 
	SEMBUF(K+7) = 1H 
	K = K+8 
	DO 2740 L0=K,K+MXSLEV-VAR 
	L = L0
2740	SEMBUF(L) = 1H/ 
	ONCHNG(VAR,3) = THGPTR + 1 
	L = K+MXSLEV-VAR 
	DO 2744 FREE0 = L+1,L+5 
	FREE = FREE0
2744	SEMBUF(FREE) = 1H 


CX - -	NOW ROUND L UP TO THE NEAREST MULTIPLE OF 5. 


	L = ((L+4)/5)*5 
	CALL ALLOC(L) 
	CALL A1A5(THING(THGPTR+1),SEMBUF,L,1)
	ONCHNG(VAR,4) = THGPTR + L/5 + 1 
	THGPTR = THGPTR + L/5 
	IF(FLAG1 .EQ. 1HY) GO TO 2790 
2751	CONTINUE 
	GO TO 2970 
 


CX - -	THIS IS THE FLAG ARRANGEMENT THAT ALLOWS YOU TO USE THE 
CX - -	ABOVE CODE ONLY ONCE. 


2770	FLAG1 = 1HY 
	GO TO 2560 
2790	FLAG1 = 1HN 
	GO TO 2530 


CX - -	**************************************************************** 
CX - -	THIS SECTION WILL BE SIMILAR TO THE ABOVE SECTION, 
CX - -	BUT WILL BE ASKING QUESTIONS FOR THE 'ON CHANGE ... 
CX - -	TOTALS ...' STATEMENTS. THE DEFAULT GENERATOR AND FLAG SCHEME 
CX - -	ARE SIMILAR. 


2970	CALL LOADA(1,48,'TOTALS ON ATTRIBUTE 
	2CHANGES? (Y/N/<CR>=DEFAULT)  ') 
	CALL WRITER(48,0) 
	CALL YESNO 
	WNTTOT = RBUFA5(1) 
	IF(WNTTOT .EQ. 1HN) GO TO 4060 
	IF(WNTTOT .EQ. 1H ) GO TO 3830 
	DO 3410 LVAR0 = MXSLEV,1,-1 
	LVAR = LVAR0


CX - -	LVAR IS SORTLEVEL. 


	CALL LOADA(1,19,'     ON CHANGE OF ''') 
	CALL UNPACK(SRTLST,LVAR,PTR) 
	DO 3090 A0 = 20,19+PTR 
	A = A0
3090	LDBUF(A) = LBUFA1(A-19) 
	A = 20 + PTR 
	CALL LOADA(A,28,'''?  (Y/N/<CR>=ALL DEFAULT)  ') 
	CALL WRITER(47+PTR,0) 
	CALL YESNO 
	IF(RBUFA5(1) .EQ. 1HN) GO TO 3430 
	IF(RBUFA5(1) .EQ. 1H ) GO TO 3610 
	DO 3300 MVAR0=1,MXFLDS 
	MVAR = MVAR0


CX - -	MVAR IS FIELD NUMBER. 


	IF(FIELD(MVAR,8) .NE. 1HY) GO TO 3300 
	CALL LOADA(1,16,'          WANT ''') 
	CALL UN2PCK(FIELD,OMXFLD,8,MVAR,2,PTR) 


CX - -	THIS SUBROUTINE IS SIMILAR TO UNPACK, BUT IT UNPACKS STUFF 
CX - -	FROM POINTERS IN A 2-DIMENSIONAL ARRAY. BECAUSE OF THIS, THE 
CX - -	DIMENSIONS OF THAT ARRAY HAVE TO BE PASSED AS THE SECOND 
CX - -	AND THIRD ARGUMENTS. 


	DO 3220 A0 = 17,16+PTR 
	A = A0
3220	LDBUF(A) = LBUFA1(A-16) 
	A = PTR + 17 
	CALL LOADA(A,25,''' TOTALLED?  (Y/<CR>=N)  ') 
	CALL WRITER(PTR+41,0) 
	CALL YESNO 
	IF(RBUFA5(1) .NE. 1HY) GO TO 3300 
	MAT1(LVAR,MVAR) = 1HY 
	CALL LOADA(1,46,'          SPECIAL FORMAT?  (Y/<CR>=N/FORMAT)  ') 
	CALL WRITER(46,0) 
	CALL READER 
	IF(RBUFA5(1) .EQ. 1HY) GO TO 3500 
	IF(RBUFA5(1) .EQ. 1H  .OR. RBUFA5(1) .EQ. 1HN) GO TO 3570 
	GO TO 3540 
3500	CALL LOADA(1,36,'                    INPUT FORMAT:   ') 
	CALL WRITER(36,0) 
	CALL READER 
3540	MAT2(LVAR,MVAR) = THGPTR + 1 
	CALL PSHTHG(ENDBUF(0)) 
	MAT2(LVAR,MVAR+1) = THGPTR + 1 
	GO TO 3300 
3570	MAT2(LVAR,MVAR) = THGPTR + 1 
	CALL DPAROW 
	MAT2(LVAR,MVAR+1) = THGPTR + 1 
3300	CONTINUE 
	CALL LOADA(1,42,'          SPECIAL TEXT?  (Y/<CR>=N/TEXT)  ') 
	CALL WRITER(42,0) 
	CALL READER 
	IF(RBUFA5(1) .EQ. 1HY) GO TO 3360 
	IF(RBUFA5(1) .EQ. 1H  .OR. RBUFA5(1) .EQ. 1HN) GO TO 3590 
	GO TO 3390 
3590	MAT2(LVAR,MXFLDS+1) = THGPTR + 1 
	CALL DPAROW 
	MAT2(LVAR,MXFLDS+2) = THGPTR + 1 
	GO TO 3400 
3360	CALL LOADA(1,28,'               INPUT TEXT:  ') 
	CALL WRITER(28,0) 
	CALL READER 
3390	MAT2(LVAR,MXFLDS+1) = THGPTR + 1 
	CALL PSHTHG(ENDBUF(0)) 
	MAT2(LVAR,MXFLDS+2) = THGPTR + 1 


CX - -	THE CODE ABOVE IS PRETTY STRAIGHTFORWARD, ESPECIALLY SINCE 
CX - -	IT IS SO SIMILAR TO THE CODE FOR THE PLAIN 'ON CHANGE' 
CX - -	STATEMENTS, WHICH IS COMMENTED. THIS SECTION HERE 
CX - -	ALLOWS THE USER A CHANCE TO GENERATE SUPERTOTALS. IF HE 
CX - -	DOESN'T WANT THEM, A ^ IS STORED AT THIS LEVEL IN SUPMAT. 
CX - -	IF HE DOES WANT THEM, A POINTER TO THE STARTING POSITION OF 
CX - -	THE SUPERTOTALS SERIES IS STORED AT THIS LEVEL IN 
CX - -	SUPMAT, AND THE SUPERTOTALS ARE INPUT VIA THE SUBROUTINE 
CX - -	MKSUPR. SINCE THE SUPERTOTALS ARE SELF-ENDING, NO 
CX - -	NEED EXISTS FOR THE PRACTICE OF STORING A PLACEHOLDER. 


3400	CALL LOADA(1,34,'WANT SUPER TOTALS? (Y/<CR> = N)   ') 
	CALL WRITER(34,0) 
	CALL YESNO 
	IF(RBUFA5(1) .NE. 1HY) GO TO 4059 
	SUPMAT(LVAR) = THGPTR + 1 
	CALL MKSUPR(MXFLDS,THGPTR + 1) 
	GO TO 3410 
4059	SUPMAT(LVAR) = 1H^ 
3410	CONTINUE 
	GO TO 4060 
3430	MAT1(LVAR,1) = 1H^ 


CX - -	THIS SIGNIFIES NO TOTALS ON THIS LEVEL AT ALL. 


	GO TO 4059 


CX - -	THIS IS THE FLAG ARRANGEMENT THAT ALLOWS YOU TO ONLY USE 
CX - -	THE FOLLOWING CODE ONCE. 


3610	MOM = LVAR 


CX - -	THIS IS TO KEEP THE CODE STRAIGHT, SINCE LVAR IS USED ABOVE, 
CX - -	AND MOM IS USED BELOW. 


	FLAG2 = 1HY 
	GO TO 3840 
3640	FLAG2 = 1HN 
	GO TO 3400 


CX - -	**************************************************************** 
CX - -	THIS IS THE DEFAULT GENERATOR FOR THE 'ON CHANGE .. TOTALS' 
CX - -	STATEMENTS. 


3830	DO 4050 MOM0 = MXSLEV,1,-1 
	MOM = MOM0
3840	DO 3880 DAD0 = 1,MXFLDS 
	DAD = DAD0
	MAT2(MOM,DAD) = THGPTR + 1 
	CALL DPAROW 
	MAT2(MOM,DAD+1) = THGPTR + 1 
	MAT1(MOM,DAD) = FIELD(DAD,8) 
3880	CONTINUE 
	MAT2(MOM,MXFLDS+1) = THGPTR + 1 
	CALL LOADA(1,9,'TOTAL BY ') 
	N = (SRTLST(MOM+1)-SRTLST(MOM))*5 
	CALL A5A1(THING(SRTLST(MOM)),LDBUF,N,10)
	DO 3920 PTR0 = 9+N,1,-1 
	PTR = PTR0
3920	IF(LDBUF(PTR) .NE. 1H ) GO TO 3925 
3925	LDBUF(PTR+1) = 1H: 
	DO 3932 FREE0 = PTR+2,PTR+7 
	FREE = FREE0
3932	LDBUF(FREE) = 1H 
	N = PTR + 1 


CX - -	NOW ROUND N UP TO THE NEAREST MULTIPLE OF 5. 


	N = ((N+4)/5)*5 
	CALL ALLOC(N) 
	CALL A1A5(THING(THGPTR+1),LDBUF,N,1)
	THGPTR = THGPTR + N/5 
	MAT2(MOM,MXFLDS+2) = THGPTR + 1 
	IF(FLAG2 .EQ. 1HY) GO TO 3640 


CX - -	THIS FLAG CHECK WILL TELL US IF WE HAVE TO GET OUT OR NOT. 
CX - -	THE LINE BELOW GENERATED AN AUTOMATIC ^ IN SUPMAT, SINCE 
CX - -	THE DESIGN CALLS FOR NO SUPERTOTALS WHEN THE USER INPUTS 
CX - -	AN INDICATION FOR A TOTALLY-DEFAULT 'ON CHANGE TOTALS' SECTION. 


	SUPMAT(MOM) = 1H^ 
4050	CONTINUE 


CX - -	**************************************************************** 
CX - -	THE	THE FOLLOWING SECTION INPUTS THE INFORMATION FOR THE 
CX - -	'ON END ... ' STATEMENT. IT IS SIMILAR TO THE ABOVE 
CX - -	TWO SECTIONS. ALL TOTALLABLE EXPRESSINS ARE TOTALLED HERE. 


4060	CALL LOADA(1,38,'GRAND TOTALS?  (Y/N/ <CR> = DEFAULT)  ') 
	CALL WRITER(38,0) 
	CALL YESNO 
	WGRTOT = RBUFA5(1) 
	IF(WGRTOT .EQ. 1HN) GO TO 4691 
	IF(WGRTOT .EQ. 1H ) GO TO 4500 
	DO 4350 LOOP90 = 1,MXFLDS 
	LOOP9 = LOOP90
	IF(FIELD(LOOP9,8) .NE. 1HY) GO TO 4350 
	CALL LOADA(1,18,'     GRAND TOTAL ''') 
	CALL UN2PCK(FIELD,OMXFLD,8,LOOP9,2,PTR) 
	DO 4180 F0 = 19,18+PTR 
	F = F0
4180	LDBUF(F) = LBUFA1(F-18) 
	F = 19+PTR 
	CALL LOADA(F,19,'''?  (Y/ <CR> = N)  ') 
	CALL WRITER(PTR+37,0) 
	CALL YESNO 
	IF(RBUFA5(1) .NE. 1HY) GO TO 4350 
	ETOTAL(LOOP9) = 1HY 
	CALL LOADA(1,46,'          SPECIAL FORMAT?  (Y/<CR>=N/FORMAT)  ') 
	CALL WRITER(46,0) 
	CALL READER 
	IF(RBUFA5(1) .EQ. 1HY) GO TO 4300 
	IF(RBUFA5(1) .EQ. 1H  .OR. RBUFA5(1) .EQ. 1HN) GO TO 4460 
	GO TO 4330 
4300	CALL LOADA(1,30,'               INPUT FORMAT:  ') 
	CALL WRITER(30,0) 
	CALL READER 
4330	EFRMAT(LOOP9) = THGPTR + 1 
	CALL PSHTHG(ENDBUF(0)) 
	EFRMAT(LOOP9+1) = THGPTR + 1 
4350	CONTINUE 
	CALL LOADA(1,37,'     SPECIAL TEXT?  (Y/<CR>=N/TEXT)  ') 
	CALL WRITER(37,0) 
	CALL READER 
	IF(RBUFA5(1) .EQ. 1HY) GO TO 4400 
	IF(RBUFA5(1) .EQ. 1H  .OR. RBUFA5(1) .EQ. 1HN) GO TO 4480 
	GO TO 4430 
4400	CALL LOADA(1,24,'          INPUT TEXT:   ') 
	CALL WRITER(24,0) 
	CALL READER 
4430	ETITLE(1) = THGPTR + 1 
	CALL PSHTHG(ENDBUF(0)) 
	ETITLE(2) = THGPTR + 1 
	GO TO 4683 


CX - -	DEFAULT FORMAT. 


4460	EFRMAT(LOOP9) = THGPTR + 1 
	CALL DPAROW 
	EFRMAT(LOOP9+1) = THGPTR + 1 
	GO TO 4350 


CX - -	NO TEXT. 


4480	ETITLE(1) = THGPTR + 1 
	CALL DPAROW 
	ETITLE(2) = THGPTR + 1 
	GO TO 4683 


CX - -	**************************************************************** 
CX - -	THIS IS THE DEFAULT GENERATOR FOR THE 'ON END ...' 
CX - -	STATEMENT. 


4500	CALL LOADA(1,15,'GRAND TOTAL:   ') 
	ETITLE(1) = THGPTR + 1 
	CALL A1A5(THING(THGPTR+1),LDBUF,15,1)
	ETITLE(2) = THGPTR + 4 
	THGPTR = THGPTR + 3 
	DO 4682 VAR0 = 1,MXFLDS 
	VAR = VAR0
	EFRMAT(VAR) = THGPTR + 1 
	CALL DPAROW 
	EFRMAT(VAR+1) = THGPTR + 1 
	ETOTAL(VAR) = FIELD(VAR,8) 


CX - -	ALL TOTALLABLE FIELDS ARE TOTALLED. 


4682	CONTINUE 


CX - -	THE USER IS GIVEN THE CHANCE TO INPUT A SUPERTOTALS SERIES 
CX - -	HERE AS LONG AS HE DOES NOT ANSWER WITH AN EXPLICIT 'N' THE 
CX - -	QUESTION, 'GRAND TOTALS?'. 


4683	CALL LOADA(1,34,'WANT SUPER TOTALS? (Y/<CR> = N)   ') 
	CALL WRITER(34,0) 
	CALL YESNO 
	IF(RBUFA5(1) .NE. 1HY) GO TO 4690 
	SUPMAT(MXSLEV+1) = THGPTR + 1 


CX - -	RECALL THAT THE MXSLEV+1'TH POSITION IS FOR THE 'ON END' 
CX - -	SUPERTOTALS SERIES. 


	CALL MKSUPR(MXFLDS,THGPTR + 1) 
	GO TO 4691 
4690	SUPMAT(MXSLEV+1) = 1H^ 
4691	CONTINUE
CX - -	GO TO 4699

CX - -	THIS STEP WAS ADDED TEMPORARILY TO ESCAPE FROM THE DIFFICULTIES
CX - -	OF HAVING 1022 ON DIFFERENT LOCATIONS ON DIFFERENT MACHINES,
CX - -	SO WE ELIMINATE THIS CAPABILITY OF RUNNING 1022 FROM HERE
CX - -	FOR NOW. THE 'CALL LOADA' STATEMENT BELOW WOULD ORDINARILY BE
CX - -	LINE 4691.

	CALL LOADA(1,37,'WANT TO RUN REPORT NOW?  (Y/<CR>=N)  ') 
	CALL WRITER(37,0) 
	CALL YESNO 
	IF(RBUFA5(1) .EQ. 'Y') GO TO 4692 
4699	CALL OUTPUT('N','N') 
	CALL EXIT 
4692	CALL LOADA(1,43,'     WANT TO BE LEFT IN 1022?  (Y/<CR>=N)  ') 
	CALL WRITER(43,0) 
	CALL YESNO 
	IF(RBUFA5(1) .NE. 'Y') GO TO 4693 
	CALL OUTPUT('Y','Y') 
	CALL EXIT 
4693	CALL OUTPUT('Y','N') 
	CALL EXIT 
	END 
C *************************************************************
CX - -	THE CALL TO OUTPUT HAS TWO ARGUMENTS- THE FIRST IS 
CX - -	WHETHER THE REPORT IS TO BE RUN IMMEDIATELY, AND THE SECOND 
CX - -	IS WHETHER THE USER WANTS TO REMAIN IN 1022 AFTER THE REPORT 
CX - -	FINISHES. THE SECOND ARGUMENT IS ALWAYS 'N' IF THE FIRST 
CX - -	ARGUMENT IS 'N'. THE CALLS TO EXIT FOLLOWING THE CALLS TO 
CX - -	OUTPUT ARE NOT ALWAYS NECESSARY; HOWEVER, BETTER TO HAVE THEM 
CX - -	IN CASE OUTPUT DOES RETURN. 


 
 
	SUBROUTINE OUTPUT(R1022,L1022) 
	IMPLICIT INTEGER(A-Z) 
 
	COMMON /CHANS/ILOGCH, OLOGCH, OCTLCH
	COMMON /LDBUF/LDBUF(150) 
	COMMON /RDCNT/RDCNT 
	COMMON /FIELD/FIELD(10,8) 
	COMMON /LTHING/LTHING 
	COMMON /SEMBUF/SEMBUF(150) 
	COMMON /THING/THING(4000),THGPTR 
	COMMON /LBUFA1/LBUFA1(150) 
	COMMON /RBUFA5/RBUFA5(30) 
	COMMON /LOGIN/LOGIN 
 
 
	COMMON /ARRAYS/FLNM2(10),FLNM1(10),FTTEXT(2),SUPMAT(6) 
	COMMON /ARRAYS/ETOTAL(10),ETITLE(2),EFRMAT(11) 
	COMMON /ARRAYS/MAT1(5,10),MAT2(5,12),ONCHNG(5,4) 
	COMMON /ARRAYS/SRTLST(6),HDING(11),CVPAGE(21) 
	COMMON /ARRAYS/UPDOWN(5) 
 
 
	COMMON /SCALAR/BLANKS,MXSLEV,MXFLDS,MXHLIN 
	COMMON /SCALAR/OUTP3,LWIDTH,WNTFOT,FNDSTR 
	COMMON /SCALAR/WNTDAT,WNTSRT,VERSIN,MXCLIN 
	COMMON /SCALAR/OMXSLV,OUTFIL,DATNAM,FLINES 
	COMMON /SCALAR/WNTTIM,SUMARY,WGRTOT,OMXFLD 
	COMMON /SCALAR/PAGLEN,WSSRTD,WPGNUM,WNTTOT 
	COMMON /DELIM/ENDCHR
 
 
	DOUBLE PRECISION LEFT1, WHOLE
 
 
CX - -	**************************************************************** 
CX - -	THE INPUT HALF OF THE PROGRAM IS NOW FINISHED. THE 
CX - -	CODE FROM HERE ON IN WILL FORM THE LINES 
CX - -	THAT WILL BE OUTPUT INTO THE REPORT CONTROL FILE. 
CX - -	THE TWO ARGUMENTS TO OUTPUT ARE R1022 AND L1022, 
CX - -	RESPECTIVELY, WHETHER THE USER WANTS TO RUN THE REPORT 
CX - -	IMMEDIATELY OR NOT, AND WHETHER HE WANTS TO REMAIN IN 1022 
CX - -	AFTER THE REPORT HAS FINISHED. 
 
 
	N = (OUTFIL-OUTP3)*5 
 
CX - -	N IS THE LENGTH OF THE REPORT CONTROL FILE FILENAME. 
 
	CALL A5A1(THING(OUTP3),LBUFA1,N,1)
	CALL MKFLNM(LBUFA1,LEFT1,RIGHT1) 
	IF(RIGHT1 .EQ. ' ') RIGHT1 = 'DMC' 
 
CX - -	DEFAULT EXTENSIONS ARE CHANGED TO 'DMC'. 
 
	CALL DPFLNM(WHOLE, LEFT1, RIGHT1)
	OPEN(UNIT=OCTLCH, ACCESS='SEQOUT', FILE=WHOLE)
 
CX - -	OPENING UP THE CONTROL FILE. 
 
 
	IF(THING(DATNAM) .EQ. '^') GO TO 4760


CX - -	THIS IS THE SIGNAL FOR NO 'OPEN ...' COMMAND.


	CALL LOADA(1,5,'OPEN ') 
	N = (FNDSTR - DATNAM)*5 
 
CX - -	N IS THE LENGTH OF THE DATABASE NAME. 
 
	CALL A5A1(THING(DATNAM),LDBUF,N,6)
	DO 4740 PTR0 = 5+N,1,-1 
	PTR = PTR0
4740	IF(LDBUF(PTR) .NE. 1H ) GO TO 4745 
4745	CALL LOADA(PTR+1,1,'.') 
	CALL DUMP(PTR+1) 
 
 
4760	IF(THING(OUTFIL) .EQ. '^') GO TO 4890 
 
CX - -	THIS IS THE SIGNAL FOR NO 'INIT ...' COMMAND. 
 
	CALL LOADA(1,7,'INIT 1 ') 
	N = (DATNAM - OUTFIL)*5 
	CALL A5A1(THING(OUTFIL),LDBUF,N,8)
	DO 4830 PTR0 = 7+N,1,-1 
	PTR = PTR0
4830	IF(LDBUF(PTR) .NE. 1H ) GO TO 4835 
4835	CALL LOADA(PTR+1,1,'.') 
	CALL DUMP(PTR+1) 
 
 
4890	WRITE(OCTLCH,4900) 
4900	FORMAT('SET FMSG OFF.') 
 
 
CX - -	THIS TURNS OFF ALL UNNECESSARY MESSAGES WHILE 1022 
CX - -	IS RUNNING, LIKE '100 RECS FOUND', ETC. 
 
 
 
	IF(THING(FNDSTR) .EQ. 1H^) GO TO 5000 
 
 
CX - -	THIS ^ SHOWS THAT NO 'FIND ...' COMMAND IS WANTED. 
 
	CALL LOADA(1,5,'FIND ') 
	N = (SRTLST(1) - FNDSTR)*5 
	CALL A5A1(THING(FNDSTR),LDBUF,N,6)
	DO 4940 PTR0 = 5+N,1,-1 
	PTR = PTR0
4940	IF(LDBUF(PTR) .NE. 1H ) GO TO 4945 
4945	CALL LOADA(PTR + 1,1,'.') 
	CALL DUMP(PTR+1) 
 
 
5000	IF(WSSRTD .EQ. 1HY) GO TO 5120 
	CALL LOADA(1,8,'SORT BY ') 
	POS = 8 
	DO 5100 LINE0 = 1,MXSLEV 
	LINE = LINE0
	CALL UNPACK(SRTLST,LINE,PTR) 
	DO 5032 A0 = POS+1,POS+PTR 
	A = A0
5032	LDBUF(A) = LBUFA1(A-POS) 
	CALL LOADA(POS+PTR+1,1,' ') 
	POS = POS+PTR+1 
	IF(UPDOWN(LINE) .NE. 'D') GO TO 5100 
	CALL LOADA(POS+1,11,'DESCENDING ') 
	POS = POS + 11 
5100	CONTINUE 
	CALL LOADA(POS,1,'.') 
	CALL DUMP(POS) 
 
 
5120	WRITE(OCTLCH,5130) 
5130	FORMAT('REPORT START.') 
 
 
	CALL LOADA(1,14,'HEADING PRINT ') 
	Q = 14 
	IF(WNTDAT .EQ. 1HN) GO TO 5175 
	CALL LOADA(Q+1,8,'SYSDATE ') 
	Q = Q + 8 
5175	IF(WPGNUM .EQ. 1HN) GO TO 5176 
	CALL LOADA(Q+1,8,'SYSPAGE ') 
	Q = Q + 8 
5176	IF(WNTTIM .EQ. 1HN) GO TO 5177 
	CALL LOADA(Q+1,8,'SYSTIME ') 
	Q = Q + 8 
5177	CALL DUMP(Q) 
 
 
	CALL LOADA(1,12,'     FORMAT ') 
	Q = 12 
	IF(WNTDAT .EQ. 1HN) GO TO 5271 
	CALL LOADA(Q+1,6,'1T D1 ') 
 
 
CX - -	PUTS DATE AT LEFT SIDE OF PAGE. 
 
	Q = Q + 6 
5271	IF(WPGNUM .EQ. 1HN) GO TO 5272 
	F = (LWIDTH-8)/2 
	IF(F .GT. 0) GO TO 5274
	WRITE(5,5275) LWIDTH
5275	FORMAT(' ERROR - CAN''T HANDLE HEADING PAGE NUMBERS IN',/,
	2' LINE WIDTH OF ',I3)
	GO TO 5272
5274	CALL Q3DIG(Q+1,1HR,F) 
 
 
CX - -	PUTS PAGE NUMBER IN CENTER OF PAGE. 
 
	CALL LOADA(Q+4,13,'T "PAGE " I3 ') 
	Q = Q + 16 
5272	IF(WNTTIM .EQ. 1HN) GO TO 5273 
	G = LWIDTH - 10 
	IF(G .GT. 0) GO TO 5276
	WRITE(5,5277) LWIDTH
5277	FORMAT(' ERROR - CAN''T HANDLE HDING TIME IN',/,
	2' LINE WIDTH OF ',I3)
	GO TO 5273
5276	CALL Q3DIG(Q+1,1HR,G) 
 
 
CX - -	PUTS TIME AT RIGHT SIDE OF PAGE. 
 
	CALL LOADA(Q+4,5,'T G8 ') 
	Q = Q + 8 
5273	CALL DUMP(Q) 
 
 
	IF(THING(HDING(1)) .EQ. 4HDONE) GO TO 5560 
 
 
CX - -	IF NO HDING TEXT AT ALL, PROCEED. 
 
 
	DO 5520 LINNU0 = 1,MXHLIN 
	LINNUM = LINNU0
	CALL UNPACK(HDING,LINNUM,PTR) 
	IF(PTR .GT. 1) GO TO 5380 
	CALL LOADA(1,9,'        /') 
	CALL DUMP(9) 
	GO TO 5520 
5380	HALF = (LWIDTH-PTR)/2 
 
 
CX - -	THIS FACTOR CENTERS EACH LINE. 
 
	CALL LOADA(1,16,'            X  "') 
	IF(HALF .GT. 0) GO TO 5400 
	CALL Q3DIG(10,1HR,0) 
	GO TO 5470 
5400	CALL Q3DIG(10,1HR,HALF) 
5470	DO 5480	J0 = 17,16+PTR 
	J = J0
5480	LDBUF(J) = LBUFA1(J-16) 
	J = 17+PTR 
	CALL LOADA(J,5,'"  / ') 
	CALL DUMP(J+4) 
5520	CONTINUE 
 
 
CX - -	HERE WE WILL DESCROLL THE FIELD TITLES INTO THEIR 
CX - -	SEPARATE TITLE LINES. THE PROCEDURE IS RATHER SIMPLE, SINCE 
CX - -	WE KNOW BY THIS TIME THAT THE TITLES ARE ALL BROKEN UP INTO 
CX - -	PACKETS THAT WILL FIT WITHIN THEIR FIELD WIDTHS, AND THE 
CX - -	PACKETS ARE SEPARATED BY BYTES CONTAINING A '4', THE NUMBER, 
CX - -	NOT THE CHARACTER. SO, FOR EACH TITLE LINE, WE STEAL THE 
CX - -	LEFTMOST PACKET OF EACH TITLE STORED IN 'THING', AND 
CX - -	DEPOSIT IT INTO ITS PLACE IN LDBUF, THEN DUMP LDBUF. 
CX - -	AS WE EXHAUST THE TITLES, WE GO DOWN MORE LINES, UNTIL 
CX - -	ALL THE TITLES ARE FINISHED. THEN WE UNDERLINE. THE FLAG 
CX - -	AFLAG IS USED TO STOP THE UNDERLINING IF NO TITLES ARE 
CX - -	PRINTED. THE NUMBER "21004020100 IS MERELY A DECIMAL 4 
CX - -	RIGHT-JUSTIFIED IN THE LEFTMOST 7 BITS OF A WORD, OR 
CX - -	WHAT A PACKED 4 WOULD EXPAND INTO IN A1 FORMAT. 
 
 
5560	DO 5570 G0 = 1,150 
	G = G0
5570	LDBUF(G) = 1H 
 
CX - -	CLEAR THE BUFFER. 
 
	CALL LOADA(9,1,'"') 
11310	POS = 9 
	FLAG3 = 0 
 
 
CX - -	FLAG3 TELLS WHETHER OR NOT ANYTHING HAS BEEN PLACED ON THE 
CX - -	CURRENT LDBUF LINE. 
 
	DO 11510 VAR0 = 1,MXFLDS 
	VAR = VAR0
	FWIDTH = FIELD(VAR,4) 
	IF(THING(FIELD(VAR,6)) .EQ. 1H^) GO TO 11500 
 
CX - -	NO TITLE FOR THIS FIELD. 
 
	IF(FIELD(VAR,1) .NE. 1HE) GO TO 11500 
 
CX - -	IT IS A TEXT FIELD, HENCE NO TITLE. 
 
	CALL UN2PCK(FIELD,OMXFLD,8,VAR,6,N) 
 
CX - -	UNPACK THE TITLE. 
 
	DO 11390 PTR0 = 1,FWIDTH 
	PTR = PTR0
11390	IF(LBUFA1(PTR) .EQ. ENDCHR) GO TO 11410 
 
CX - -	SEARCH FOR THE END OF A SEGMENT. 
 
	GO TO 11500 
 
CX - -	THERE WAS NO SEGMENT IN THIS TITLE ANY MORE. 
 
11410	FLAG3 = 1 
 
CX - -	THERE WAS NOW. 
 
	IF(PTR .EQ. 1) GO TO 11460 
 
CX - -	THIS TAKES CARE OF BLANK LINES IN THE TITLES. 
 
	DO 11430 A0 = POS+1,POS+PTR-1 
	A = A0
11430	LDBUF(A) = LBUFA1(A-POS) 
 
CX - -	PLACE THE TITLE IN POSITION. 
 
11460	DO 11470 A0 = PTR+1,150 
	A = A0
11470	LBUFA1(A-PTR) = LBUFA1(A) 
 
CX - -	MOVE THE REST OF THE TITLE OVER TO THE LEFT END OF THE LBUFA1, 
CX - -	HENCE DELETING IT, SINCE WE ARE FINISHED WITH IT. 
 
	DO 11490 J0 = N-PTR+1,150 
	J = J0
11490	LBUFA1(J) = 1H 
	CALL A1A5(THING(FIELD(VAR,6)),LBUFA1,N,1)
 
CX - -	PUT THE REST OF THE FIELD BACK IN 'THING' FOR THE NEXT 
CX - -	TIME AROUND. 
 
11500	POS = POS + FWIDTH 
11510	CONTINUE 
	IF(FLAG3 .EQ. 0) GO TO 11590 
 
CX - -	IF FLAG3 IS 0, THEN NO SEGMENTS HAVE BEEN LOADED. HENCE, GET 
CX - -	THEE TO THE UNDERLINING. 
 
	CALL LOADA(POS+1,3,'" /') 
	CALL DUMP(POS+3) 
	DO 11560 G0 = 1,150 
	G = G0
11560	LDBUF(G) = 1H 
	CALL LOADA(9,1,'"') 
	GO TO 11310 
 
 
CX - -	UNDERLINING SECTION. 
 
11590	DO 11600 G0 = 1,150 
	G = G0
11600	LDBUF(G) = 1H 
	CALL LOADA(9,1,'"') 
	POS = 9 
	AFLAG = 0 
 
CX - -	THIS FLAG WILL TELL US WHETHER WE HAVE TO UNDERLINE OR NOT. 
 
	DO 11690 VAR0 = 1,MXFLDS 
	VAR = VAR0
	FWIDTH = FIELD(VAR,4) 
	IF(FIELD(VAR,1) .NE. 1HE) GO TO 11680 
	IF(THING(FIELD(VAR,6)) .EQ. 1H^) GO TO 11680 
 
CX - -	TWO CASES WHERE UNDERLINING IS NOT REQUIRED. 
 
	AFLAG = 1 
 
CX - -	UNDERLINING IS REQUIRED, SO SET AFLAG. 
 
	DO 11670 LP0 = POS+1,POS+FWIDTH-1 
	LP = LP0
11670	LDBUF(LP) = 1H- 
11680	POS = POS + FWIDTH 
11690	CONTINUE 
	CALL LOADA(POS+1,1,'"') 
	IF(AFLAG .EQ. 0) GO TO 11720 
 
CX - -	IF AFLAG IS 0, THEN WE DON'T DUMP THE LINE OF UNDERLINING. 
 
	CALL DUMP(POS+1) 
 
11720	POS = 8 
	DO 11731 J0 = 1,BLANKS 
	J = J0
	LDBUF(POS+1) = '/' 
11731	POS = POS + 1 
	CALL DUMP(POS) 
	CALL LOADA(1,12,'        END.') 
	CALL DUMP(12) 
 
 
CX - -	THE END OF THE HDING. 
 
 
 
	IF(WNTFOT .EQ. 1HN  .OR. WNTFOT .EQ. 1H ) GO TO 6010 
	CALL LOADA(1,26,'FOOTING     PRINT FORMAT "') 
	POS = 26 
	CALL Q3DIG(9,1HR,FLINES) 
	IF(FTTEXT(1) .EQ. 1H^) GO TO 6000 
	CALL UNPACK(FTTEXT,1,PTR) 
	DO 5995 A0 = POS+1,POS+PTR 
	A = A0
5995	LDBUF(A) = LBUFA1(A-POS) 
	CALL LOADA(POS+PTR+1,7,'" END. ') 
	CALL DUMP(POS+PTR+7) 
	GO TO 6010 
6000	CALL LOADA(POS,5,' END.') 
	CALL DUMP(POS+4) 
 
 
CX - -	THE END OF THE FOOTING. 
 
 
 
6010	WRITE(OCTLCH,6020) PAGLEN 
6020	FORMAT('PAGE ',I3,'.') 
 
 
	IF(THING(CVPAGE(1)) .EQ. 4HDONE) GO TO 6400 
 
 
CX - -	IF THERE ARE NO LINES OF TEXT FOR THE COVER PAGE, CONTINUE 
CX - -	ONWARD. 
 
	WRITE(OCTLCH,6050) 
6050	FORMAT('ON START PRINT FORMAT $3') 
	FOURTH = (PAGLEN - MXCLIN)/2 
	CALL LOADA(1,13,'          (/)') 
	IF(FOURTH .GT. 0) GO TO 6080 
	CALL Q3DIG(8,1HR,0) 
	GO TO 6150 
6080	CALL Q3DIG(8,1HR,FOURTH) 
6150	CALL DUMP(13) 
 
 
 
CX - -	THIS IS THE CENTERING FACTOR FOR THE BODY OF LINES ON THE 
CX - -	THE COVER PAGE. 
 
 
	CALL LOADA(1,14,'          X  "') 
	DO 6320 LINNU0 = 1,MXCLIN 
	LINNUM = LINNU0
	CALL UNPACK(CVPAGE,LINNUM,PTR) 
	IF(PTR .GT. 1) GO TO 6200 
	CALL LOADA(1,9,'        /') 
	CALL DUMP(9) 
	GO TO 6320 
6200	HALF = (LWIDTH - PTR)/2 
 
 
CX - -	THIS IS THE CENTERING FACTOR FOR EACH LINE. 
 
 
	CALL Q3DIG(8,1HR,HALF) 
	DO 6290 A0 = 15,14+PTR 
	A = A0
6290	LDBUF(A) = LBUFA1(A-14) 
	CALL LOADA(15+PTR,3,'" /') 
	CALL DUMP(17+PTR) 
6320	CONTINUE 
	CALL LOADA(1,17,'     C1 $ $4 END.') 
	CALL DUMP(17) 
 
 
 
 
CX - -	THE ON START SECTION IS DONE. NOW FOR THE ON CHANGES ... 
 
 
6400	IF(WNTSRT .EQ. 1HN) GO TO 6640 
 
 
CX - -	IF THE USER DOESN'T WANT ANY 'ON CHANGE' COMMANDS, THEN WE 
CX - -	SHOULD SKIP OVER THE FOLLOWING SECTION. 
 
 
	DO 6600 VAR0 = 1,MXSLEV 
	VAR = VAR0
	IF(THING(ONCHNG(VAR,1)) .EQ. 1H^) GO TO 6600 
	CALL UNPACK(SRTLST,VAR,N) 
	CALL LOADA(1,10,'ON CHANGE ') 
	POS = 10 
	DO 6460 A0 = POS+1,POS+N 
	A = A0
6460	LDBUF(A) = LBUFA1(A-POS) 
	CALL LOADA(POS+N+1,7,' PRINT ') 
	POS = POS + N + 7 
	CALL UN2PCK(ONCHNG,OMXSLV,4,VAR,1,N) 
	DO 6510 A0 = POS+1,POS+N 
	A = A0
6510	LDBUF(A) = LBUFA1(A-POS) 
	CALL DUMP(POS+N) 
 
 
CX - -	THE ABOVE SECTION PUT THE SORT LIST EXPRESSION AND THE 
CX - -	PRINT LIST IN THE COMMAND, SO IT NOW LOOKS SOMETHING LIKE: 
CX - - 
CX - -	ON CHANGE [SORT EXPRESSION] PRINT [PRINT LIST] 
CX - - 
CX - -	THE SECTION BELOW WILL PLACE A FORMAT LINE AFTER THIS. 
 
 
	CALL LOADA(1,15,'        FORMAT ') 
	POS = 15 
	IF(THING(ONCHNG(VAR,3)) .NE. 1H^) GO TO 6550 
	N = 0 
	GO TO 6580 
6550	CALL UN2PCK(ONCHNG,OMXSLV,4,VAR,3,N) 
	DO 6570 A0 = POS+1,POS+N 
	A = A0
6570	LDBUF(A) = LBUFA1(A-POS) 
6580	CALL LOADA(POS+N+1,5,' END.') 
	CALL DUMP(POS+N+5) 
6600	CONTINUE 
 
 
CX - -	ALL THE ON CHANGE STATEMENTS ARE FINISHED. THEY WERE 
CX - -	ALMOST TRIVIAL, INVOLVING LITTLE MANIPULATION AND EVERYTHING 
CX - -	CLUSTERED, POINTED AT SOMEWHERE IN THE ONCHNG MATRIX. 
CX - -	THE FOLLOWING SECTION WILL OUTPUT THE PRINT COMMAND. 
CX - -	IF THE VARBLE 'SUMARY' WAS SET, THEN WE HAVE ONLY TO 
CX - -	WRITE 'PRINT.' AND WE ARE DONE. OTHERWISE, WE HAVE TO 
CX - -	GO INTO THE FIELDS AND EXTRACT THE EXPRESSIONS 
CX - -	TO BE PRINTED, AND THE TEXT FIELDS, ALSO. 
 
 
6640	IF(SUMARY .NE. 1HY) GO TO 6680 
	WRITE(OCTLCH,6660) 
6660	FORMAT('PRINT.') 
	GO TO 7160 
 
 
CX - -	THAT WAS EASY. NOW CONTINUE. 
 
6680	CALL LOADA(1,6,'PRINT ') 
	POS = 6 
	DO 6780 I0 = 1,MXFLDS 
	I = I0
	IF(FIELD(I,1) .NE. 1HE) GO TO 6780 
	CALL UN2PCK(FIELD,OMXFLD,8,I,2,N) 
	DO 6720 A0 = POS+1,POS+N 
	A = A0
6720	LDBUF(A) = LBUFA1(A-POS) 
	CALL LOADA(POS+N+1,1,' ') 
	POS = POS + N + 1 
6780	CONTINUE 
	CALL DUMP(POS) 
 
 
	CALL LOADA(1,15,'        FORMAT ') 
	POS = 15 
	DO 6960 VAR0 = 1,MXFLDS 
	VAR = VAR0
	FWIDTH = FIELD(VAR,4) 
	IF(FIELD(VAR,1) .NE. 1HE) GO TO 7080 
	IF(THING(FIELD(VAR,5)) .NE. 1H^) GO TO 7010 
	CALL LOADA(POS+1,1,'G') 
	POS = POS + 1 
	CALL Q3DIG(POS+1,1HL,FWIDTH) 
	LDBUF(POS+4) = 1H 
	POS = POS + 4 
6960	CONTINUE 
	GO TO 7140 
7010	CALL UN2PCK(FIELD,OMXFLD,8,VAR,5,N) 
	DO 7040 A0 = POS+1,POS+N 
	A = A0
7040	LDBUF(A) = LBUFA1(A-POS) 
	CALL LOADA(POS+N+1,1,' ') 
	POS = POS + N + 1 
	GO TO 6960 
7080	CALL LOADA(POS+1,2,' "') 
	CALL UN2PCK(FIELD,OMXFLD,8,VAR,2,N) 
	DO 7100 A0 = POS+3,POS+2+FWIDTH 
	A = A0
7100	LDBUF(A) = LBUFA1(A-POS-2) 
	CALL LOADA(POS+3+FWIDTH,2,'" ') 
	POS = POS + FWIDTH + 4 
	GO TO 6960 
7140	CALL LOADA(POS+1,5,' END.') 
	CALL DUMP(POS+5) 
 
 
 
CX - -	THE ABOVE WAS ALSO RATHER TRIVIAL. THE PRINT LIST WAS 
CX - -	ALL ON ONE LINE, AND THE FORMATS AND TEXT STRINGS WERE ALL 
CX - -	ON THE NEXT LINE. DEFAULT FORMATS, INDICATED BY UP-ARROWS 
CX - -	STORED IN 'THING' IN THE FORMAT POSITIONS OF THESE FIELDS, 
CX - -	WERE PRINTED OUT AS 'GXXX', WHERE XXX WAS THE 
CX - -	FIELD WIDTH. 
 
 
7160	IF(WNTTOT .EQ. 1HN) GO TO 8170 
 
 
CX - -	THIS TELLS THAT NO TOTALS WERE WANTED, SO WE SKIP 
CX - -	THIS SECTION ENTIRELY. 
 
 
	DO 7830 ROB0 = MXSLEV,1,-1 
	ROB = ROB0
	CALL LOADA(1,10,'ON CHANGE ') 
	POS = 10 
	IF(MAT1(ROB,1) .EQ. 1H^) GO TO 7830 
	CALL UNPACK(SRTLST,ROB,PTR) 
	DO 7240 A0 = POS+1,POS+PTR 
	A = A0
7240	LDBUF(A) = LBUFA1(A-POS) 
	CALL LOADA(POS+PTR+1,7,' PRINT ') 
	POS = POS + PTR + 7 
	DO 7370 STEVE0 = 1,MXFLDS 
	STEVE = STEVE0
	IF(MAT1(ROB,STEVE) .NE. 1HY) GO TO 7370 
	CALL LOADA(POS+1,4,'TOT ') 
	POS = POS + 4 
	CALL UN2PCK(FIELD,OMXFLD,8,STEVE,2,PTR) 
	DO 7340 A0 = POS+1,POS+PTR 
	A = A0
7340	LDBUF(A) = LBUFA1(A-POS) 
	CALL LOADA(POS+PTR+1,1,' ') 
	POS = POS + PTR + 1 
7370	CONTINUE 
	CALL DUMP(POS) 
 
 
CX - -	THE ABOVE PRINTS OUT SOMETHING LIKE: 
CX - - 
CX - -	ON CHANGE [SORT EXPRESSION] PRINT TOT VAR1 TOT VAR2 TOT ... 
CX - - 
CX - -	WHERE VAR1, VAR2, ... ARE ALL THE TOTALLABLE FIELDS THAT WERE 
CX - -	SUPPOSED TO BE PRINTED, AS DENOTED BY A 'Y' IN MAT1(ROB, 
CX - -	STEVE). THE FOLLOWING CALL TO PLIST WILL CHECK TO SEE IF 
CX - -	THERE ARE SUPERTOTALS AT THIS LEVEL, AND IF THERE ARE, PLIST 
CX - -	WILL PRINT OUT ALL THE EXPRESSIONS THAT ARE TO BE PRINTED OUT 
CX - -	IN THIS ON CHANGE LEVEL. 
 
 
	IF(SUPMAT(ROB) .NE. 1H^) CALL PLIST(SUPMAT(ROB)) 
 
 
 
CX - -	NEXT WE WILL PRINT OUT INTO THE CONTROL 
CX - -	FILE THE FORMATS OF ALL THE ABOVE THINGS. CHECKING AGAIN 
CX - -	TO SEE IF THERE IS A SUPERTOTALS SERIES AT THIS LEVEL, WE 
CX - -	CALL FLIST TO PRINT OUT THE FORMATS OF THE EXPRESSIONS THAT 
CX - -	WERE PREVIOUSLY PRINTED OUT BY PLIST. 
 
 
	CALL LOADA(1,17,'        FORMAT / ') 
	POS = 17 
	SUM = 0 
 
 
CX - -	THE SUM FACTOR IS IMPORTANT HERE. THIS CHECKS TO SEE IF THE 
CX - -	TEXT SUPPOSED TO BE PRINTED OUT AT THIS LEVEL CAN FIT ON 
CX - -	THE SAME LINE AS THE TOTALS, OR MUST BE ON THE LINE ABOVE. 
CX - -	IF THE FIRST FIELD TO BE PRINTED IS OVER TO 
CX - -	THE LEFT OF THE LINE TOO FAR FOR THE TEXT TO FIT IN, A SLASH IS 
CX - -	PRINTED OUT TO LET THE TEXT APPEAR ON ONE LINE, AND THE TOTALS 
CX - -	ON THE NEXT. THE STEPS FROM 7950-7970 ADD THE SLASH. 
 
 
	DO 7440 I0 = 1,MXFLDS 
	I = I0
	IF(MAT1(ROB,I) .EQ. 1HY) GO TO 7460 
7440	SUM = SUM + FIELD(I,4) 
	GO TO 7850 
7460	IF(THING(MAT2(ROB,MXFLDS+1)) .EQ. 1H^) GO TO 7560 
	CALL LOADA(POS+1,1,'"') 
	POS = POS + 1 
	CALL UN2PCK(MAT2,OMXSLV,OMXFLD+2,ROB,MXFLDS+1,PTR) 
	DO 7520 A0 = POS+1,POS+PTR 
	A = A0
7520	LDBUF(A) = LBUFA1(A-POS) 
	CALL LOADA(POS+PTR+1,2,'" ') 
	POS = POS + PTR + 2 
	IF(PTR .GE. SUM) GO TO 7950 
7560	SUM = SUM + 1 
 
CX - -	YOU ADD ONE TO SUM BECAUSE YOU 'T' TO THAT SPACE 
CX - -	ON THE LINE, YOU DON'T MOVE OVER N SPACES. 
 
	CALL Q3DIG(POS+1,1HR,SUM) 
	POS = POS + 3 
	CALL LOADA(POS+1,2,'T ') 
	POS = POS + 2 
	DO 7800 J0 = I,MXFLDS 
	J = J0
	IF(MAT1(ROB,J) .NE. 1HY) GO TO 8060 
	IF(THING(MAT2(ROB,J)) .NE. 1H^) GO TO 7990 
	CALL LOADA(POS+1,1,'G') 
	POS = POS + 1 
	CALL Q3DIG(POS+1,1HL,FIELD(J,4)) 
	POS = POS + 4 
	LDBUF(POS) = 1H 
7800	CONTINUE 
7810	CALL DUMP(POS) 
	IF(SUPMAT(ROB) .NE. 1H^) CALL FLIST(SUPMAT(ROB)) 
	L = MXSLEV-ROB+1 
	CALL LOADA(1,8,'        ') 
	POS = 8 
	DO 7813 J0 = 1,L 
	J = J0
7813	LDBUF(POS+J) = 1H/ 
 
 
CX - -	THIS ADDS THE PROPER AMOUNT OF SLASHES AT THE END OF THE 
CX - -	TOTALS. THE CONNECTION BETWEEN THE NUMBER OF SLASHES AND THE 
CX - -	ON CHANGE LEVEL, IS ONE SLASH FOR EACH LEVEL BELOW THE 
CX - -	PRINT STATEMENT. THEREFORE, THE THIRD ON CHANGE COMMAND 
CX - -	BELOW THE PRINT COMMAND PRINTS OUT THREE BLANK LINES AFTER 
CX - -	ALL THE TOTALS ARE FINISHED. 
 
	CALL LOADA(POS+L+1,6,' END. ') 
	CALL DUMP(POS+L+6) 
7830	CONTINUE 
	GO TO 8170 
 
 
CX - -	PROCEED ON TO THE GRAND TOTALS. 
 
CX - -	YOU GET HERE IF THERE WERE NO TOTALLABLES TO BE 
CX - -	PRINTED AT THIS LEVEL. YOU WANT TO SEE IF THERE IS A 
CX - -	TITLE (ANY TEXT) TO BE PRINTED OUT, THEN LEAVE THIS LEVEL. 
 
 
7850	IF(THING(MAT2(ROB,MXFLDS+1)) .EQ. 1H^) GO TO 7810 
 
 
CX - -	IF THAT IS TRUE, BECAUSE THERE IS NO TEXT, GO TO DUMP THAT 
CX - -	LINE. ELSE, PRINT OUT THE TEXT. 
 
	CALL LOADA(POS+1,2,' "') 
	POS = POS + 2 
	CALL UN2PCK(MAT2,OMXSLV,OMXFLD+2,ROB,MXFLDS+1,PTR) 
	DO 7910 A0 = POS+1,POS+PTR 
	A = A0
7910	LDBUF(A) = LBUFA1(A-POS) 
	CALL LOADA(POS+PTR+1,2,'" ') 
	POS = POS + PTR + 2 
	GO TO 7810 
 
 
CX - -	THIS IS WHERE YOU ADD THE SLASH TO CARRY THE TOTALS OVER 
CX - -	TO THE NEXT LINE, IF THEY AND THE TEXT CAN'T BOTH FIT 
CX - -	ON THE SAME LINE. 
 
 
7950	CALL LOADA(POS+1,3,' / ') 
	POS = POS + 3 
	GO TO 7560 
 
 
CX - -	YOU GET HERE IF THERE WAS A SPECIAL TEXT TO BE EXTRACTED 
CX - -	AND PRINTED, WHICH YOU ARE ABOUT TO DO. 
 
7990	CALL UN2PCK(MAT2,OMXSLV,OMXFLD+2,ROB,J,PTR) 
	DO 8020 A0 = POS+1,POS+PTR 
	A = A0
8020	LDBUF(A) = LBUFA1(A-POS) 
	CALL LOADA(POS+PTR+1,1,' ') 
	POS = POS + PTR + 1 
	GO TO 7800 
 
 
CX - -	THIS IS WHERE YOU GO IF THERE WAS A TEXT FIELD THAT 
CX - -	YOU WANT TO SPACE OVER, SO YOU PRINT AN 'X' 
CX - -	FACTOR THAT WILL CARRY YOU OVER THAT FIELD. 
 
 
8060	CALL Q3DIG(POS+1,1HR,FIELD(J,4)) 
	POS = POS + 3 
	CALL LOADA(POS+1,2,'X ') 
	POS = POS + 2 
	GO TO 7800 
 
 
 
 
 
CX - -	CHECK HERE TO SEE IF THERE ARE ANY GRAND TOTALS DESIRED, AND 
CX - -	IF NOT, SKIP OVER THIS SECTION ENTIRELY. 
CX - -	THE SITUATION IS BASICALLY THE SAME AS IT WAS FOR THE 
CX - -	ON CHANGE TOTALS COMMANDS ABOVE, EXCEPT THAT IT IS FOR THE 
CX - -	ON END COMMAND NOW. THE DEFAULT PROCEDURES ARE SIMILAR. 
 
 
 
8170	IF(WGRTOT .EQ. 1HN) GO TO 8780 
	CALL LOADA(1,13,'ON END PRINT ') 
	POS = 13 
	DO 8300 LP170 = 1,MXFLDS 
	LOOP17 = LP170
	IF(ETOTAL(LOOP17) .NE. 1HY) GO TO 8300 
	CALL UN2PCK(FIELD,OMXFLD,8,LOOP17,2,PTR) 
	CALL LOADA(POS+1,4,'TOT ') 
	POS = POS + 4 
	DO 8270 A0 = POS+1,POS+PTR 
	A = A0
8270	LDBUF(A) = LBUFA1(A-POS) 
	CALL LOADA(POS+PTR+1,1,' ') 
	POS = POS + PTR + 1 
8300	CONTINUE 
	CALL DUMP(POS) 
 
 
	IF(SUPMAT(MXSLEV+1) .NE. 1H^) CALL PLIST(SUPMAT( 
	2MXSLEV+1)) 
	CALL LOADA(1,17,'        FORMAT / ') 
	POS = 17 
	SUM = 0 
	DO 8460 J0 = 1,MXFLDS 
	J = J0
	IF(ETOTAL(J) .EQ. 1HY) GO TO 8340 
8460	SUM = SUM + FIELD(J,4) 
	GO TO 8760 
8340	IF(THING(ETITLE(1)) .EQ. 1H^) GO TO 8510 
	CALL UNPACK(ETITLE,1,PTR) 
	CALL LOADA(POS+1,1,'"') 
	POS = POS + 1 
	DO 8400 A0 = POS+1,POS+PTR 
	A = A0
8400	LDBUF(A) = LBUFA1(A-POS) 
	CALL LOADA(POS+PTR+1,2,'" ') 
	POS = POS + PTR + 2 
	IF(SUM .GT. PTR) GO TO 8510 
	CALL LOADA(POS+1,3,' / ') 
	POS = POS + 3 
8510	SUM = SUM + 1 
	CALL Q3DIG(POS+1,1HR,SUM) 
	POS = POS + 3 
	CALL LOADA(POS+1,2,'T ') 
	POS = POS + 2 
	DO 8750 K0 = J,MXFLDS 
	K = K0
	IF(ETOTAL(K) .NE. 1HY) GO TO 8810 
	IF(THING(EFRMAT(K)) .EQ. 1H^) GO TO 8630 
	CALL UNPACK(EFRMAT,K,PTR) 
	DO 8624 A0 = POS+1,POS+PTR 
	A = A0
8624	LDBUF(A) = LBUFA1(A-POS) 
	POS = POS + PTR + 1 
	CALL LOADA(POS,1,' ') 
	GO TO 8750 
8630	CALL LOADA(POS+1,1,'G') 
	POS = POS + 1 
	CALL Q3DIG(POS+1,1HL,FIELD(K,4)) 
	POS = POS + 4 
	LDBUF(POS) = 1H 
8750	CONTINUE 
8760	CALL DUMP(POS) 
	IF(SUPMAT(MXSLEV+1) .NE. 1H^) CALL FLIST(SUPMAT( 
	2MXSLEV+1)) 
	CALL LOADA(1,15,'        // END.') 
	CALL DUMP(15) 
 
 
CX - -	THIS IS THE END OF THE LINE. HERE WE FINISH UP. 
 
8780	WRITE(OCTLCH,8790) 
8790	FORMAT('REPORT END.') 
	IF(R1022 .NE. 'N') GO TO 9875 
 
CX - -	WANT TO STOP HERE AND ANNOUNCE THAT FACT. 
 
	WRITE(5,9874) 
9874	FORMAT(/,' PROGRAM COMPLETED.',//) 
 
	CALL EXIT 
 
 
 
CX - -	IF YOU DON'T WANT TO RUN THE REPORT NOW THERE'S NO SENSE IN 
CX - -	HANGING AROUND, SO YOU DON'T. 
 
 
9875	IF(L1022 .EQ. 'N') WRITE(OCTLCH,8792) 
8792	FORMAT('QUIT.') 
 
CX - -	A TEMPORARY CLUDGE TO STOP THE PROGRAM AND 1022 IF THE USER 
CX - -	WANTS. 
 
 
CX - -	CLOSE THE FILES. 
 
	CLOSE(UNIT=ILOGCH)
	CLOSE(UNIT=OLOGCH)
	CLOSE(UNIT=OCTLCH)
	WRITE(5,9876) 
9876	FORMAT(/,' PROGRAM COMPLETED. ENTERING 1022.'//) 
 
	CALL RUN22(0,THING(OUTP3)) 
	CALL EXIT 
 
 
CX - -	THAT'S ALL! 
 
 
8810	CALL Q3DIG(POS+1,1HR,FIELD(K,4)) 
	POS = POS + 3 
	CALL LOADA(POS+1,2,'X ') 
	POS = POS + 2 
	GO TO 8750 
	END 



CX - -	****************************************************************
CX
CX - - 	THIS SUBROUTINE TAKES A STRING IN A5 FORMAT SOMEWHERE IN
CX - -	'THING', POINTED AT BY 'MATRIX(VARBLE)', AND CHANGES IT
CX - -	TO A1 FORMAT WHILE LOADING IT INTO 'LBUFA1'. SINCE
CX - -	'MATRIX(VARBLE)' POINTS TO THE END OF THE DESIRED STRING,
CX - -	THE VALUE OF 'MATRIX(VARBLE+1)-MATRIX(VARBLE)' YIELDS
CX - -	THE NUMBER OF WORDS IN THE STRING, AND THAT VALUE TIMES FIVE(5)
CX - -	IS THE MAXIMUM NUMBER OF CHARACTERS TO BE SWITCHED TO A1
CX - -	FORMAT IN LBUFA1. THE SIGNIFICANT LENGTH OF THE RESULT IS
CX - -	RETURNED IN 'COUNT'.
CX
CX - -	EXAMPLE:
CX
CX - -	SAMPLE CALL IS:    CALL UNPACK(ARRAY,K,PTR)
CX
CX - -		THING(J)   = ABCDE		ARRAY(K)   = J
CX - -		THING(J+1) = FGHIJ		ARRAY(K+1) = J+1
CX - -		THING(J+2) = KLM
CX
CX - -	ARRAY(K+1)-ARRAY(K) = 3, OR THE DESIRED NUMBER OF WORDS.
CX - -	NOTICE THAT ARRAY(K+1) POINTS TO THE WORD IMMEDIATELY
CX - -	FOLLOWING THE LAST WORD OF THE STRING, AND NOT TO THE
CX - -	LAST WORD OF THE STRING ITSELF, THAT THIS RELATIONSHIP
CX - -	MIGHT BE STANDARD THROUGHOUT THE PROGRAM. HERE, 'COUNT1' = 15
CX - -	AND PTR RETURNS 13 (BOTH FIGURES DECIMAL).

	SUBROUTINE UNPACK(MATRIX,VARBLE,COUNT)
	IMPLICIT INTEGER(A-Z)
	COMMON /LBUFA1/LBUFA1(150)
	COMMON /THING/THING(4000),THGPTR
	DIMENSION MATRIX(1)
	COUNT1 = (MATRIX(VARBLE+1)-MATRIX(VARBLE))*5
	CALL A5A1(THING(MATRIX(VARBLE)),LBUFA1,COUNT1,1)
	DO 1 COUNT0 = COUNT1,1,-1
	COUNT = COUNT0
1	IF(LBUFA1(COUNT) .NE. 1H ) GO TO 2
2	RETURN
	END


CX - -	****************************************************************
CX
CX - -	THIS SUBROUTINE IS SIMILAR TO 'UNPACK' ABOVE, EXCEPT
CX - -	THAT IT OPERATES ON TWO-DIMENSIONAL MATRICES. SINCE THE
CX - -	'MATRIX' HAS TO BE DIMENSIONED PROPERLY, THE TWO DIMENSIONS
CX - -	ARE PASSED AS THE ARGUMENTS 'DIM1' AND 'DIM2'.
CX
CX - -	SAMPLE CALL:
CX
CX - -	CALL UN2PCK(FIELD,OMXFLD,8,VAR,3,PTR)
CX
CX - -	THIS CAUSES 'MATRIX' TO HAVE THE DIMENSIONS 'OMXFLD,8',
CX - -	SAME AS 'FIELD'. THIS UNPACKS THE STRING POINTED AT BY
CX - -	THE POINTER IN THE VAR'TH ROW, 3'RD COLUMN, OF THE MATRIX
CX - -	'FIELD'. THE SIGNIFICANT LENGTH OF THE MESSAGE IS RETURNED
CX - -	IN 'PTR'.


	SUBROUTINE UN2PCK(MATRIX,DIM1,DIM2,VAR1,VAR2,COUNT)
	IMPLICIT INTEGER(A-Z)
	COMMON /LBUFA1/LBUFA1(150)
	COMMON /THING/THING(4000),THGPTR
	DIMENSION MATRIX(DIM1,DIM2)
	F = MATRIX(VAR1,VAR2)
	G = MATRIX(VAR1,VAR2+1)
	COUNT1 = (G-F)*5
	CALL A5A1(THING(F),LBUFA1,COUNT1,1)
	DO 1 COUNT0 = COUNT1,1,-1
	COUNT = COUNT0
1	IF(LBUFA1(COUNT) .NE. 1H ) GO TO 2
2	RETURN
	END


CX - -	****************************************************************
CX
CX - -	THIS SUBROUTINE LOADS A LITRAL, PASSED AS THE THIRD
CX - -	ARGUMENT, INTO THE ARRAY 'LDBUF', BEGINNING AT THE POSITION
CX - -	SPECIFIED BY THE ARGUMENT 'START'. 'NCHAR' IS THE NUMBER
CX - -	OF A1 CHARACTERS TO BE MOVED.
CX
CX - -	SAMPLE CALL:
CX
CX - -	CALL LOADA(3,11,'HELLO THERE')
CX
CX - -	YIELDS A LDBUF THAT LOOKS LIKE THIS:
CX
CX - -	/   /   / H / E / L / L / O /   / T / H / E / R / E /   /  ...
CX
CX - -	POSITIONS 1,2, AND ALL THOSE AFTER 13, ARE
CX - -	NOT AFFECTED BY THIS CALL.


	SUBROUTINE LOADA(START,NCHAR,THING)
	IMPLICIT INTEGER(A-Z)
	COMMON /LDBUF/LDBUF(150)
	DIMENSION THING(1)
	CALL A5A1(THING,LDBUF,NCHAR,START)
	RETURN
	END



CX - -	****************************************************************
CX
CX - -	IF INPUT TO THE PROGRAM IS COMING FROM THE TELETYPE, THIS
CX - -	SUBROUTINE PLACES THE CONTENTS OF 'LDBUF' INTO THE
CX - -	LOG FILE, WITH A SIGNAL ( A COLON IN THE SIXTH(6)
CX - -	POSITION ) THAT IT'S NOT TO BE USED AS AN ACTIVE INPUT LINE,
CX - -	AND WRITES THE LINE ON THE TELETYPE.
CX - -	IF INPUT IS COMING FROM A LOG FILE, THIS SUBROUTINE DOES
CX - -	NOTHING.
CX
CX - -	IF THE ARGUMENT 'CR' IS = 0, THE <CR> AFTER THE LINE IS
CX - 	SUPPRESSED. THIS INDICATES TO THE USE THAT AN INPUT
CX - -	IS EXPECTED ON THE SAME LINE. IF, HOWEVER, THE ARGUMENT
CX - -	'CR' = 1, THE <CR> IS NOT SUPPRESSED.


	SUBROUTINE WRITER(POS,CR)
	IMPLICIT INTEGER(A-Z)
	COMMON /CHANS/ILOGCH, OLOGCH, OCTLCH
	COMMON /LDBUF/LDBUF(150)
	COMMON /DUMP1/DMPFLG
	COMMON /STACK/STACK(150),STKNUM
	COMMON /LOGIN/LOGIN
	IF(LOGIN .EQ. 1HY) GO TO 4
	IF(DMPFLG .EQ. 'N') GO TO 5
	WRITE(OLOGCH,1),(LDBUF(F),F=1,POS)
1	FORMAT(7H     : ,150A1)
5	IF(STKNUM .GT. 0) GO TO 4
	WRITE(5,2),(LDBUF(G),G=1,POS)
2	FORMAT(1H ,$,150A1)
	IF(CR .EQ. 1) WRITE(5,3)
3	FORMAT(1H+,/)
4	RETURN
	END


CX - -	****************************************************************
CX
CX	THE FOLLOWING SUBROUTINE MAKES FILENAMES FROM ASCII
CX - -	STRINGS. THE FIRST ARGUMENT IS AN ARRAY CONTAINING
CX - -	AT MOST 6 CHARACTERS, FOLLOWED OPTIONALLY BY A PERIOD,
CX - -	THEN AT MOST 3 CHARACTERS. THE SECOND ARGUMENT IS A DOUBLE-
CX - -	PRECISION VARBLE WHICH WILL RECEIVE THE FIRST
CX - -	SIX CHARACTERS OF THE FILENAME, AND THE THIRD ARGUMENT
CX - -	IS A SINGLE-PRECISION VARBLE THAT WILL RECEIVE THE
CX - -	THREE-CHARACTER EXTENSION, IF THERE IS ONE.


	SUBROUTINE MKFLNM(ARRAY,LEFT,RIGHT)
	IMPLICIT INTEGER(A-Z)
	DIMENSION ARRAY(1)
	DOUBLE PRECISION LEFT
	DO 1 A0 = 1,10
	A = A0
1	IF(ARRAY(A) .EQ. 1H.) GO TO 2
	CALL A1A5(LEFT,ARRAY,6,1)
	RIGHT = 1H 
	RETURN
2	CALL A1A5(LEFT,ARRAY,A-1,1)
	CALL A1A5(RIGHT,ARRAY,3,A+1)
	RETURN
	END



CX - -	*********************************************************
CX - -	SUBROUTINE TO CHANGE A DOUBLE PRECISION LEFT, AND A RIGHT,
CX - -	INTO AN A5-FORMAT DOUBLE PRECISION FILENAME.

	SUBROUTINE DPFLNM(DPWRD, LEFT, RIGHT)
	IMPLICIT INTEGER(A-Z)
	DOUBLE PRECISION DPWRD, LEFT
	DIMENSION FOO(10)

	CALL A5A1(LEFT,FOO,6,1)
	DO 2 B = 1, 7
	IF(FOO(B) .EQ. ' ') GO TO 3
2	CONTINUE

CX - -  NEVER FALL THRU.

3	FOO(B) = '.'
	CALL A5A1(RIGHT,FOO,3,B+1)
	CALL A1A5(DPWRD,FOO,10,1)
	RETURN
	END
CX - -	****************************************************************
CX
CX - -	IF INPUT IS FROM A LOG FILE, THIS SUBROUTINE READS
CX - -	IN A LINE FROM THE LOG FILE. IF THE SIXTH(6TH) PLACE
CX - -	CONTAINS A COLON (:), SIGNIFYING IT IS NOT AN ACTIVE INPUT
CX - -	LINE, ANOTHFR LINE IS READ IN AND TESTED, OTHERWISE IT
CX - -	RETURNS THIS LINE. RDCNT IS A VARBLE THAT COUNTS
CX - -	HOW MANY LINES ARE READ IN FROM THE LOG FILE, FOR ERROR-
CX - -	MESSAGE PURPOSES. IF INPUT IS COMING FROM THE TELETYPE, A
CX - -	LINE IS READ IN FROM THE TELETYPE.
CX - -	THE LINE READ IN IS ULTIMATELY RETURNED IN 'RBUFA5'.

	SUBROUTINE READER
	IMPLICIT INTEGER(A-Z)
	COMMON /CHANS/ILOGCH, OLOGCH, OCTLCH
	COMMON /RBUFA5/RBUFA5(30)
	COMMON /LBUFA1/LBUFA1(150)
	COMMON /SEMBUF/SEMBUF(150)
	COMMON /SFLAG/SCRFLG
	COMMON /DUMP1/DMPFLG
	COMMON /STACK/STACK(150),STKNUM
	COMMON /LOGIN/LOGIN
	COMMON /RDCNT/RDCNT
	COMMON /DELIM/ENDCHR

	IF(LOGIN .NE. 'Y') GO TO 8

1	READ(ILOGCH,2,END=800),(RBUFA5(A),A=1,30)
2	FORMAT(30A5)

	RDCNT = RDCNT + 1
	CALL A5A1(RBUFA5,LBUFA1,150,1)
	IF(LBUFA1(6) .EQ. ':') GO TO 1

CX - -	ANSWER IS IN RBUFA5. THERE WAS NO STACKING IN THE LOG FILE
CX - -	ALLOWED, SO WE KNOW THERE IS ONLY ONE ANSWER HERE.
CX - -	PROCESSING LOOP FOR REMOVING EXTRANEOUS UP-ARROWS:

7	PTR = 1
	SB = 1
3	IF(LBUFA1(PTR) .EQ. '^') GO TO 20
	IF(SCRFLG .EQ. 'T' .AND. LBUFA1(PTR) .EQ. '/') GO TO 22
15	SEMBUF(SB) = LBUFA1(PTR)
16	PTR = PTR + 1
	SB = SB + 1
	IF(PTR .LE. 150) GO TO 3

CX - -	WE GET HERE WHEN WE HAVE PROCESSED THE ENTIRE THING.
CX - -	PROCESSED ANSWER IS IN SEMBUF, UNPROCESSED ANSWER IN
CX - -	RBUFA5 AND LBUFA1. NOW WE PRINT OUT LBUFA1 INTO THE LOG
CX - -	FILE, (THE UNPROCESSED VERSIN), AND THE PROCESSED VERSIN
CX - -	IS RETURNED IN RBUFA5. WE USE THE UNPROCESSED VERSIN IN
CX - -	THE LOG FILE BECAUSE WE PROCESS IT WHEN WE RETRIEVE IT
CX - -	FROM THE LOG FILE.

	IF(LOGIN .EQ. 'Y' .OR. DMPFLG .EQ. 'N') GO TO 6

	DO 4 Q0 = 150,1,-1
	Q = Q0
4	IF(LBUFA1(Q) .NE. 1H ) GO TO 19
19	WRITE(OLOGCH,5),(LBUFA1(S),S=1,Q)
5	FORMAT(150A1)

6	CALL A1A5(RBUFA5,SEMBUF,SB-1,1)

CX - -	RETURNING PROCESSED ANSWER HERE.

300	RETURN




20	PTR = PTR + 1
	GO TO 15

22	SEMBUF(SB) = ENDCHR
	GO TO 16




8	IF(STKNUM .GT. 0) GO TO 100

CX - -	INPUT FROM TTY, AND NO STACKED ANSWERS WAITING NOW.

	READ(5,9,END=900),(RBUFA5(F),F=1,30)
9	FORMAT(30A5)

CX - -	CHECK TO SEE IF THERE ARE STACKED ANSWERS.

	CALL A5A1(RBUFA5,LBUFA1,150,1)
	LK = 1
10	IF(LBUFA1(LK) .EQ. '^') GO TO 40
	IF(LBUFA1(LK) .EQ. ';') GO TO 42
	LK = LK + 1
11	IF(LK .LE. 150) GO TO 10

CX - -	GET HERE WHEN THERE IS ONLY ONE ANSWER ON THE LINE.

	GO TO 7


40	LK = LK + 2
	GO TO 11

42	CALL PSHSTK
	GO TO 100




CX - -	THIS IS TO GET AN ANSWER FROM THE STACK AND THEN PROCESS IT.

100	LK = 1
12	IF(STACK(LK) .EQ. '^') GO TO 102
	IF(STACK(LK) .EQ. ';') GO TO 77
	LK = LK + 1
13	IF(LK .LE. 150) GO TO 12

CX - -	WE NEVER FALL THROUGH BECAUSE WE CAME HERE KNOWING
CX - -	THAT AT LEAST ONE ENTRY AWAITED US ON THE STACK.
CX - -	THE NEXT TWO CALLS ARE TO SET UP RBUFA5 AND LBUFA1
CX - -	FOR THE PROCESSING AT STEP 7.

77	DO 23 FREE0 = 1,30
	FREE = FREE0
	RBUFA5(FREE) = ' '
23	LBUFA1(FREE) = ' '
	DO 24 FREE0 = 31,150
	FREE = FREE0
24	LBUFA1(FREE) = ' '
	IF(LK .EQ. 1) GO TO 14
	CALL A1A5(RBUFA5,STACK,LK-1,1)
	CALL A5A1(RBUFA5,LBUFA1,LK-1,1)
14	DO 17 J0 = LK+1,150
	J = J0
17	STACK(J-LK) = STACK(J)

	STKNUM = STKNUM - 1

	DO 18 JL0 = 151-LK,150
	JL = JL0
18	STACK(JL) = 1H 
	IF(LK .GT. 1) GO TO 7

	WRITE(OLOGCH,55)
55	FORMAT()
	RETURN

CX - -	HAD TO DO THIS SPECIAL RETURN BECAUSE OTHERWISE NOTHING
CX - -	WOULD HAVE BEEN PRINTED IN THE LOG FILE FOR A BLANK LINE.



102	LK = LK + 2
	GO TO 13


800	WRITE(5,810)
810	FORMAT(' HAVE REACHED END OF FILE IN INPUT.
	2 EXECUTION TERMINATED.',//)
	CALL EXIT

900	WRITE(5,910)
910	FORMAT(' HAVE REACHED END OF FILE IN LOG FILE INPUT.',/,
	2 ' EXECUTION TERMINATED.',//)
	CALL EXIT
	END




CX - -	****************************************************************
CX
CX - -	ACTS ON SOMETHING IN ARRAY 'RBUFA5'. IN FACT, IT IS
CX - -	ASSUMED THAT THE DESIRED OBJECT OF THIS SUBROUTINE IS THERE
CX - -	BEFORE THE SUBROUTINE IS CALLED. THE ACTION OF THE SUB-
CX - -	ROUTINE IS TO DUMP THE FIRST 'NUM' WORDS OF RBUFA5 INTO
CX - -	'THING', AT THE PRESENT 'THGPTR', INCREMENTING
CX - -	'THGPTR' APPROPRIATELY. THE CALL TO ALLOC WOULD NOTIFY THE
CX - -	USER IF HE WERE APPROACHING THE END OF HIS FREE
CX - -	SPACE IN 'THING', I.E. IF HE WERE RUNNING OUT OF ROOM. IT
CX - -	IS A STANDARD CONVENTION IN THIS PROGRAM TO ALWAYS CALL
CX - -	ALLOC WHEN SOMETHING IS ABOUT TO BE DEPOSITED IN 'THING'.


	SUBROUTINE PSHTHG(NUM)
	IMPLICIT INTEGER(A-Z)
	COMMON /THING/THING(4000),THGPTR
	COMMON /RBUFA5/RBUFA5(30)
	CALL ALLOC(NUM)
	DO 1 A0 = THGPTR+1,THGPTR+NUM
	A = A0
1	THING(A) = RBUFA5(A-THGPTR)
	THGPTR = THGPTR + NUM
	RETURN
	END



C - -	****************************************************************
CX
CX - -	THIS FUNCTION EXPANDS THE CONTENTS OF 'RBUFA5' INTO A
CX - -	GARBAGE ARRAY, TO FIND THE END OF THE SIGNIFICANT
CX - -	CONTENTS OF RBUFA5. IT RETURNS THE LENGTH OF THE MESSAGE
CX - -	IN 'ENDBUF', HENCE THE REASON THIS IS A
CX - -	FUNCTION, NOT A SUBROUTINE.
CX
CX - -	EXAMPLE:
CX
CX - -	IF RBUFA5 CONTAINS THE WORDS
CX
CX - -		HOW M
CX - -		ANY S
CX - -		IGNIF
CX - -		ICANT
CX - -		 CHAR
CX - -		S ARE
CX - -		HERE?
CX
CX - -	THE FUNCTION WOULD EXPAND THAT TO
CX
CX - -	HOW MANY SIGNIFICANT CHARS ARE HERE?
CX
CX - -	AND RETURN 7 WORDS AS THE ANSWER.


	FUNCTION ENDBUF(I)
	IMPLICIT INTEGER(A-Z)
	COMMON /RBUFA5/RBUFA5(30)
	COMMON /LBUFA1/LBUFA1(150)
	CALL A5A1(RBUFA5,LBUFA1,150,1)
	DO 1 PTR0 = 150,1,-1
	PTR = PTR0
1	IF(LBUFA1(PTR) .NE. 1H ) GO TO 2
2	ENDBUF = (PTR/5)+1
	RETURN
	END



CX - -	****************************************************************
CX
CX - -	THIS SUBROUTINE DUMPS THE FIRST 'POS' A1 CHARACTERS IN
CX - -	THE ARRAY 'LDBUF' INTO THE REPORT GENERATOR FILE,
CX - -	AS A COMPLETE LINE.


	SUBROUTINE DUMP(POS)
	IMPLICIT INTEGER(A-Z)
	COMMON /CHANS/ILOGCH, OLOGCH, OCTLCH
	COMMON /LDBUF/LDBUF(150)
	WRITE(OCTLCH,1),(LDBUF(G),G=1,POS)
1	FORMAT(150A1)
	RETURN
	END




CX - -	****************************************************************
CX
CX - -	THIS SUBROUTINE SIMPLY LEAVES AN UP-ARROW IN THE NEXT
CX - -	LOCATION FREE IN 'THING', AND INCREMENTS 'THGPTR'
CX - -	APPROPRIATELY. THIS IS MAINLY USED TO STORE DEFAULT INDICATORS
CX - -	IN 'THING'.



	SUBROUTINE DPAROW
	IMPLICIT INTEGER(A-Z)
	COMMON /THING/THING(4000),THGPTR
	CALL ALLOC(1)
	THING(THGPTR+1) = 1H^
	THGPTR = THGPTR + 1
	RETURN
	END




CX - -	****************************************************************
CX
CX - -	SINCE, WHENEVER ANYTHING IS DEPOSITED IN 'THING', A CALL
CX - -	FOR THAT MANY WORDS IS MADE TO ALLOC, A CAREFUL TRACK IS
CX - -	KEPT OF HOW MUCH FREE SPACE IS LEFT TO THE PROGRAM
CX - -	IN 'THING'. THE USER CAN ALTER HIS FREESPACE BY
CX - -	ALTERING THE DIMENSIONING OF 'THING', AND HE CAN ALSO HAVE
CX - -	THIS SUBROUTINE WARN HIM WHEN HE APPROACHES THE END OF 'THING'
CX - -	BY A DIFFERENT NUMBER THAN 200. THE NOTIFICATION IS NON-FATAL.


	SUBROUTINE ALLOC(HWMANY)
	IMPLICIT INTEGER(A-Z)
	COMMON /THING/THING(4000),THGPTR
	COMMON /LTHING/LTHING
	IF(THGPTR+HWMANY .GE. LTHING-200) WRITE(5,1)
1	FORMAT(' YOU ARE WITHIN 200 OF THE END OF YOUR FREE
	2 STORAGE SPACE!')
	RETURN
	END




CX - -	****************************************************************
CX
CX - -	THIS SUBROUTINE TAKES AN A5 STRING IN RBUFA5, EXPANDS
CX - -	IT INTO A1 IN LBUFA1, AND BREAKS IT UP INTO SEGMENTS,
CX - -	STORED IN SEMBUF, SEPARATED BY SEMICOLONS, WHICH
CX - -	DENOTE ENDS OF SEGMENTS. THE PARTITIONING IS DONE BY
CX - -	ATTEMPTING TO FIT THE TITLE INTO THE DECLARED FIELD WIDTH.
CX - -	AFTER IT IS PARTITIONED, IT IS STORED FOR USE LATER. THE
CX - -	USER CAN DO THIS PARTITIONING HIMSELF, AS THE SUBROUTINE
CX - -	CHECKS FOR ANY SEMICOLONS INPUT IN THE STRING, AND IF IT
CX - -	FINDS ANY, ASSUMES THE USER HAS DONE THE SEGMENTING
CX - -	HIMSELF.
CX
CX - -	EXAMPLE:
CX
CX - -	FIELD WIDTH IS 12. STRING IS 'SUPERLONGWORDS CANNOT BE BROKEN
CX - -	UP EASILY.' THE SUBROUTINE CHANGES IT TO 
CX
CX - -	'SUPERLONGW-;ORDS CANNOT;BE BROKEN;UP EASILY;'
CX
CX - -	THE ALGORITHM IS SIMPLE - AS MUCH OF THE SENTENCE AS CAN
CX - -	BE FITTED ON ONE LINE IS DONE SO, WITHOUT BREAKING UP ANY
CX - -	WORDS, UNLESS THE WORD IS SO LONG THAT IT CANNOT FIT ON ONE
CX - -	LINE. ANY WORDS THAT ARE BROKEN UP ARE AUTOMATICALLY
CX - -	HYPHENATED. THE MAXIMUM LENGTH ON ONE LINE OF ANY SEGMENT
CX - -	IS THE FIELD WIDTH - 1, LEAVING ROOM FOR A SPACE BETWEEN
CX - -	ABUTTING TITLES AUTOMATICALLY.


	SUBROUTINE SCROLL(FWIDTH)
	IMPLICIT INTEGER(A-Z)
	COMMON /LBUFA1/LBUFA1(150)
	COMMON /SEMBUF/SEMBUF(150)
	COMMON /RBUFA5/RBUFA5(30)
	COMMON /DELIM/ENDCHR

10700	DO 10710 FREE0 = 1,150
	FREE = FREE0
10710	LBUFA1(FREE) = 1H 
10715	CALL A5A1(RBUFA5,LBUFA1,150,1)
10720	POS = 0
10723	N = 150
10725	DO 10730 LKUP0 = 1,N
	LOOKUP = LKUP0
10730	IF(LBUFA1(LOOKUP) .EQ. ENDCHR) GO TO 10900


CX - -	THIS TESTS IF THE USER HAS DONE THE PARTITIONING HIMSELF,
CX - -	AND EXITS THE SUBROUTINE IF HE HAS.


10735	DO 10740 A0 = N,1,-1
	A = A0
10740	IF(LBUFA1(A) .NE. 1H ) GO TO 10745
10745	IF(A .LT. FWIDTH) GO TO 10835


CX - -	IF THE REMAINING PART OF THE TITLE CAN FIT ON ONE LINE,
CX - -	FIT IT IN AND LEAVE THE SUBROUTINE, CAUSE YOU HAVE THEN
CX - -	PROCESSED THE ENTIRE MESSAGE.


10750	DO 10755 B0 = FWIDTH,1,-1
	B = B0
10755	IF(LBUFA1(B) .EQ. 1H ) GO TO 10795


CX - -	THERE WERE NO SPACES IN THE SEGMENT, SO YOU MUST
CX - -	PUT (FIELD WIDTH - 2) CHARACTERS OF IT, FOLLOWED BY A ; INTO
CX - -	SEMBUF FOR THIS SEGMENT.


10760	DO 10765 C0 = POS+1,POS+FWIDTH-2
	C = C0
10765	SEMBUF(C) = LBUFA1(C-POS)
10770	SEMBUF(POS+FWIDTH-1) = 1H-
10775	SEMBUF(POS+FWIDTH) = ENDCHR
10780	POS = POS + FWIDTH
10785	HOWFAR = FWIDTH - 2
10790	GO TO 10820
10795	HOWFAR = B
10800	DO 10805 D0 = POS+1,POS+HOWFAR-1
	D = D0
10805	SEMBUF(D) = LBUFA1(D-POS)
10810	SEMBUF(POS+HOWFAR) = ENDCHR
10815	POS = POS + HOWFAR
10820	DO 10825 E0 = HOWFAR+1,N
	E = E0
10825	LBUFA1(E-HOWFAR) = LBUFA1(E)


CX - -	THIS PART MOVES THE TITLE OVER ITSELF, IN EFFECT. THE
CX - -	PART AFTER THE SEGMENT YOU JUST FIT INTO SEMBUF IS STILL
CX - -	NEEDED, BUT THE PART YOU FIT IS NOT, SO YOU MOVE THE RIGHT-
CX - -	HAND PART OVER THE LEFT-HAND PART, TO MAKE THE NEW
CX - -	LEFT-HAND PART AVAILABLE FOR THE REST OF THE SUBROUTINE
CX - -	TO ACT ON.


10827	DO 10828 FREE0 = N-HOWFAR+1,150
	FREE = FREE0
10828	LBUFA1(FREE) = 1H 
10830	GO TO 10735
10835	DO 10840 G0 = POS+1,POS+A
	G = G0
10840	SEMBUF(G) = LBUFA1(G-POS)
10845	SEMBUF(A+POS+1) = ENDCHR
10850	POS = POS+A+1
10865	CALL A1A5(RBUFA5,SEMBUF,POS,1)


CX - -	THE SUBROUTINE HAS COLLECTED THE VARIOUS SEGMENTS OF THE
CX - -	TITLE IN SEMBUF. THE TITLE HAS NOW BEEN COMPLETELY PRO-
CX - -	CESSED. YOU TURN IT BACK INTO A5 AND PUT IT
CX - -	BACK IN RBUFA5, WHERE IT STARTED, BUT IT IS NOW
CX - -	PARTITIONED.


10875	RETURN

10900	DO 10910 F0 = 150,1,-1
	F = F0
10910	IF(LBUFA1(F) .NE. 1H ) GO TO 10920
10920	LBUFA1(F+1) = ENDCHR
10930	CALL A1A5(RBUFA5,LBUFA1,F+1,1)
	RETURN

CX - -	THIS PART ADDS AN EXTRA LINE BREAK CHAR AT THE END OF THE BUFFER
CX - -	BUT ONLY IF THERE WAS ALREADY AT LEAST ONE OTHER SLASH
CX - -	IN THE STRING.

	END




CX - -	****************************************************************
CX
CX - -	THIS SUBROUTINE IS CALLED TO ALLOW THE USER TO INPUT A
CX - -	SERIES OF SUPERTOTALS. ONE SERIES IS COMPOSED OF AN ARBITRARY
CX - -	NUMBER OF LINES, EACH LINE IS COMPOSED OF AN ARBITRARY NUMBER
CX - -	EXPRESSIONS. ANY EXPRESSION CAN BE USED HERE, NOT 
CX - -	SIMPLY ONE OF THE 'TOT XXX' KIND. THE READER SHOULD REFER
CX - -	TO A DIAGRAM OF HOW A SUPERTOTALS SERIES IS STORED IN 'THING'
CX - -	BEFORE READING THROUGH THE FOLLOWING CODE.
CX
CX - -	MOST OF THE CODE IS QUITE STRAIGHTFORWARD. THE UNUSUAL THING
CX - -	IS HOW THE POINTERS ARE MANAGED. SINCE THE TOTAL NUMBER
CX - -	OF EXPRESSIONS ON ANY ONE LINE IS NOT KNOWN IN ADVANCE, A
CX - -	STRUCTURE CALLED AN 'ESXPRESSION BLOCK' IS USED TO
CX - -	CONTAIN ALL THE INFORMATION PERTINENT TO ANY EXPRESSION.
CX - -	IN THE EXPRESSION BLOCK ARE POINTERS TO THE EXPRESSION
CX - -	ITSELF, ITS FORMAT, AND ITS TITLE, BUT ALSO THE START/END
CX - -	POSITIONS ON THE LINE IT OCCUPIES. IT LOOKS SOMETHING LIKE THIS:
CX
CX - -		THING(J):	EXPRE
CX - -		THING(J+1):	SSION
CX - -		THING(J+2):	-ONE
CX - -		THING(J+3):	14
CX - -		THING(J+4):	29
CX - -		THING(J+5):	TITLE
CX - -		THING(J+6):	 OF T
CX - -		THING(J+7):	HIS
CX - -		THING(J+10):	FORMA
CX - -		THING(J+11):	T
CX - -		THING(J+12):	J
CX - -		THING(J+13):	J+3
CX - -		THING(J+14):	J+5
CX - -		THING(J+15):	J+10
CX - -		THING(J+16):	J+12
CX - -		THING(J+17):	J+42
CX
CX - -	A POINTER TO THE EXPRESSION BLOCK WOULD POINT AT J+12.
CX
CX - -	ANYTHING PERTAINING TO THIS EXPRESSION CAN NOW BE
CX - -	ACCESSED BY POINTING OFF FROM THE POINTER TO THE EX-
CX - -	PRESSION BLOCK. (LET'S CALL IT PTR1 FOR NOW).
CX
CX - -	TO GET THE EXPRESSION, USE:	  THING(THING(PTR1))
CX - -	TO GET THE START, USE:		  THING(THING(PTR1+1))
CX - -	TO GET THE END, USE:		  THING(THING(PTR1+1)+1)
CX - -	TO GET THE TITLE, USE:		  THING(THING(PTR1+2))
CX - -	TO GET THE FORMAT, USE:		  THING(THING(PTR1+3))
CX - -	TO GET THE POINTER TO THE NEXT EXPRESSION BLOCK, USE:
CX - -	THING(THING(PTR1+5)). IF THE CONTENTS OF THIS WERE AN
CX - -	UP-ARROW, INSTEAD OF A NUMBER, THIS WOULD SIGNIFY THE END OF
CX - -	THIS LINE OF SUPERTOTALS, BUT NOT THE END OF THIS SUPERTOTALS
CX - -	SERIES. THUS, AN EXPRESSION BLOCK CONTAINS SIX POINTERS.
CX - -	THE PLACEHOLDER AT THING(PTR1+4) IS USED
CX - -	TO STORE THE POINTER OF THE END OF THE FORMAT, EXPECIALLY
CX - -	USEFUL WHEN YOU 'UNPACK' AND NEED THE END-POINTER AT
CX - -	'MATRIX(VAR+1)'. THE SITUATION IS THE SAME FOR CEXP AND CPH1.


	SUBROUTINE MKSUPR(MXFLDS,STPTR)
	IMPLICIT INTEGER(A-Z)
	COMMON /THING/THING(4000),THGPTR
	COMMON /SFLAG/SCRFLG
	COMMON /LDBUF/LDBUF(150)
	COMMON /RBUFA5/RBUFA5(30)
	COMMON /FIELD/FIELD(10,8)

	LINPTR = STPTR
	EXPPTR = STPTR + 1
	THGPTR = STPTR + 1
	CALL ALLOC(2)
230	CLNNUM = 1


CX - -	CLNNUM IS THE LINE COUNTER, AND CXPNUM IS
CX - -	THE EXPRESSION COUNTER.


240	CXPNUM = 1
250	CALL LOADA(1,23,'SUPER TOTALS LINE #   :')
	CALL Q3DIG(20,1HR,CLNNUM)
320	CALL WRITER(23,1)
330	CALL LOADA(1,38,'     EXPRESSION: (<CR> FOR NEW LINE)  ')  
340	CALL WRITER(38,0)
350	CALL READER
360	IF(RBUFA5(1) .EQ. 1H ) GO TO 930
370	CEXP = THGPTR + 1
380	CALL PSHTHG(ENDBUF(0))
	CALL ALLOC(ENDBUF(0))
390	CPH1 = THGPTR + 1
400	CALL LOADA(1,38,'          FIELD: (<CR> FOR START/END) ')
410	CALL WRITER(38,0)
420	CALL READER
430	IF(RBUFA5(1) .EQ. 1H ) GO TO 520
440	DECODE(30,450,RBUFA5) COLNUM
450	FORMAT(I)
	IF(COLNUM .GT. 0) GO TO 451
	CALL ERROR(2,3,'FIELD NUMBER   ',0)
	GO TO 400
451	IF(COLNUM .LE. MXFLDS) GO TO 455
	CALL ERROR(8,0,0,0)
1	COLNUM = 0
2	DO 3 FREE0 = 1,30
	FREE = FREE0
3	RBUFA5(FREE) = 1H 
454	GO TO 400
455	SUM = 0
456	IF(COLNUM .GT. 1) GO TO 460
457	START = 1
458	END = FIELD(1,4)
459	GO TO 620
460	DO 470 FCOL0 = 1,COLNUM-1
	FCOL = FCOL0
470	SUM = SUM + FIELD(FCOL,4)
490	START = SUM + 1
500	END = SUM + FIELD(COLNUM,4)
510	GO TO 620
520	CALL LOADA(1,23,'               START:  ')
530	CALL WRITER(23,0)
540	CALL READER
550	DECODE(30,560,RBUFA5) START
560	FORMAT(I)
	IF(START .GT. 0) GO TO 570
	CALL ERROR(2,2,'START     ',0)
	GO TO 520
570	CALL LOADA(1,21,'               END:  ')
580	CALL WRITER(21,0)
590	CALL READER
600	DECODE(30,610,RBUFA5) END
610	FORMAT(I)
	IF(END .GT. 0) GO TO 620
	CALL ERROR(2,1,'END  ',0)
	GO TO 570
620	THING(THGPTR+1) = START
630	THING(THGPTR+2) = END
632	THGPTR = THGPTR + 2
	CALL ALLOC(2)
640	CTITLE = THGPTR+1
650	CALL LOADA(1,36,'          TITLE?  (Y/<CR>=N/TITLE)  ')
660	CALL WRITER(36,0)
	SCRFLG = 'T'
	CALL READER
	SCRFLG = 'N'
680	IF(RBUFA5(1) .EQ. 1HY) GO TO 690
	IF(RBUFA5(1) .EQ. 1H  .OR. RBUFA5(1) .EQ. 1HN) GO TO 1040
	GO TO 713
690	CALL LOADA(1,50,'               INPUT TITLE:  
	2(<CR> = EXPRESSION)  ')
700	CALL WRITER(50,0)
	SCRFLG = 'T'
710	CALL READER
	SCRFLG = 'N'
713	IF(RBUFA5(1) .NE. 1H ) GO TO 712
	DO 711 A0 = CEXP,CPH1-1
	A = A0
711	RBUFA5(A-CEXP+1) = THING(A)
712	CALL SCROLL(END-START)
720	CALL PSHTHG(ENDBUF(0))
	CALL ALLOC(ENDBUF(0))
730	CFMT = THGPTR + 1
740	CALL LOADA(1,38,'          FORMAT?  (Y/<CR>=N/FORMAT)  ')
750	CALL WRITER(38,0)
	CALL READER
770	IF(RBUFA5(1) .EQ. 1HY) GO TO 780
	IF(RBUFA5(1) .EQ. 1H  .OR. RBUFA5(1) .EQ. 1HN) GO TO 1060
	GO TO 810
780	CALL LOADA(1,30,'               INPUT FORMAT:  ')
790	CALL WRITER(30,0)
800	CALL READER
810	CALL PSHTHG(ENDBUF(0))
	CALL ALLOC(ENDBUF(0))
812	CPH2 = THGPTR + 1
820	IF(CXPNUM .EQ. 1) THING(EXPPTR) = THGPTR + 1
830	IF(CXPNUM .GT. 1) THING(NEXPB) = THGPTR + 1


CX - -	YOU HAVE ALREADY INPUT ALL THE DATA FOR THE EXPRESSION,
CX - -	WHILE SAVING ALL THE POINTERS IN CEXP, CPH1, CTITLE, CFMT,
CX - -	AND CPH2. NOW YOU HAVE THE CHANCE, SINCE ALL
CX - -	THE STUFF YOU NEED HAS ALREADY BEEN STORED IN THING, TO STORE
CX - -	ALL THE POINTERS IN THE BLOCK. NEXPB IS LEFT BLANK, BECAUSE
CX - -	YOU DON'T KNOW IF THERE WILL BE ANOTHER EXPRESSION ON THIS
CX - -	LINE OR NOT.


840	THING(THGPTR+1) = CEXP
850	THING(THGPTR+2) = CPH1
860	THING(THGPTR+3) = CTITLE
870	THING(THGPTR+4) = CFMT
880	THING(THGPTR+5) = CPH2
890	NEXPB = THGPTR + 6
900	THGPTR = THGPTR + 6
	CALL ALLOC(6)
910	CXPNUM = CXPNUM + 1
920	GO TO 330



CX - -	THIS IS THE END OF THE CURRENT SUPERTOTALS LINE. AN
CX - -	UP-ARROW IS STORED AT NEXPB, SHOWING THAT IT IS THE
CX - -	LAST EXPRESSION ON ITS LINE, AND A NEW LINE IS BEGUN.
CX - -	THE FORMAT IS LIKE THIS:
CX
CX - -		THING(K):	G
CX - -		THING(K+1):	H
CX
CX - -		THING(H):	(AN EXPRESSION BLOCK)
CX
CX - -		THING(F):	(AN EXPRESSION BLOCK WITH A ^)
CX - -		THING(G):	Q
CX - -		THING(G+1):	D

CX - -		THING(D):	(AN EXPRESSION BLOCK)
CX
CX
CX - -	POINTERS TO THE NEXT LINE, AND THE FIRST EXPRESSION BLOCK
CX - -	OF THE CURRENT LINE, ARE STORED AFTER THE LAST EXPRESSION
CX - -	BLOCK ON THE LAST LINE. AT THING(K), G POINTS TO THE NEXT LINE
CX - -	AND H POINTS TO THE FIRST EXPRESSION BLOCK OF THE CURRENT
CX - -	LINE. AT THING(G), Q POINTS TO THE NEXT LINE, WHILE D POINTS
CX - -	TO THE FIRST EXPRESSION BLOCK ON THE CURRENT LINE. THE
CX - -	SITUATION REPEATS ITSELF UNTIL THE LAST LINE OF THE SUPERTOTALS
CX - -	SERIES IS REACHED, WHEN AN UP-ARROW IS PLACED, INSTEAD
CX - -	OF A NUMBER, IN THE POSITION NORMALLY USED FOR THE NEXT LINE 
CX - -	POINTER.
CX - -	THE PROCEDURE FOR CHECKING IF NEXPB IS 0 AND CALLING
CX - -	AN ERRIR IF IT IS, IS TO PREVENT SOMEONE FROM CALLING FOR
CX - -	SUPERTOTALS, THEN LEAVING THE FIRST LINE AT THE FIRST
CX - -	CHANCE, AND NOT ASKING FOR ANOTHER LINE, IN SHORT, LYING
CX - -	ABOUT WANTING SUPERTOTALS. THIS CAUSES AN ILL-MEM-REF, SO
CX - -	WE PRECLUDE THAT CHANCE BY CHECKING HERE.




930	IF(NEXPB .NE. 0) GO TO 931
	CALL ERROR(10,0,0,0)
	GO TO 240
931	THING(NEXPB) = 1H^
932	THING(LINPTR) = THGPTR + 1
940	LINPTR = THGPTR + 1
950	THGPTR = THGPTR + 1
952	EXPPTR = THGPTR + 1
954	THGPTR = THGPTR + 1
960	CLNNUM = CLNNUM + 1
	CALL ALLOC(2)
970	CALL LOADA(1,34,'WANT ANOTHER LINE?  (Y/<CR> = N)  ')
980	CALL WRITER(34,0)
	CALL YESNO
1000	IF(RBUFA5(1) .EQ. 1HY) GO TO 240
1020	THING(LINPTR) = 1H^
1030	GO TO 2000

1040	CALL DPAROW
1050	GO TO 730

1060	CALL DPAROW
1070	GO TO 812



CX - -	HERE WE HAVE A BUBBLE-SORTER THAT OPERATES ON THE START
CX - -	FIELDS OF THE EXPRESSIONS. SINCE WE HAVE ALLOWED THE USER
CX - -	TO INPUT HIS EXPRESSIONS IN RANDOM ORDER. I.E. NOT NECESSARILY
CX - -	LINEARLY ASCENDING BY 'START', WE MUST SORT THEM INTO THIS
CX - -	ORDER TO FACILITATE OUTPUT OF THE EXPRESSIONS IN THIS ORDER.
CX - -	BECAUSE THE LINKS TO EXPRESSIONS ARE ALL POINTERS, OUR TASK
CX - -	IS MADE SIMPLE. ALL WE HAVE TO DO IS DO A SIMPLE BUBBLE-SORT
CX - -	ALONG THE SUCCESSIVE START FIELDS OF ALL THE EXPRESSIONS ON
CX - -	EACH SUPERTOTALS LINE. WE WALK ALONG THE EXPRESSION BLOCKS BY
CX - -	USING THING(PTR+5) -> PTR, WHERE PTR ALWAYS POINTS TO THE FIRST
CX - -	WORD IN THE EXPRESSION BLOCK. WE HAVE REACHED THE END OF THE
CX - -	SUPERTOTALS LINE WHEN THE PTR IS A ^.
CX
CX - -	OLPTR = OLD LINE PTR.
CX - -	CLPTR = CURRENT LINE PTR
CX - -	NLPTR = NEW LINE PTR.
CX - -	EB0PTR = LOCATION OF EB1PTR.
CX - -	EB1PTR = PTR TO FIRST EXPRESSION BLOCK.
CX - -	EB2PTR = PTR TO SECOND EXPRESSION BLOCK.
CX - -	EB3PTR = PTR TO THIRD EXPRESSION BLOCK.
CX
CX - -	THE PROCEDURE IS SIMPLE. IF IT IS DETERMINED THAT A
CX - -	SWITCH IS NECESSARY, ALL WE HAVE TO DO IS REARRANGE THE
CX - -	POINTERS. LINE 2090 DETERMINES WHETHER OR NOT A SWITCH
CX - -	IS NECESSARY, AND LINES 2120 - 2180 PERFORM THE ACTUAL
CX - -	REARRANGING OF THE POINTERS. FLAG7 DENOTES THAT A SWITCH
CX - -	HAS BEEN MADE, SO THAT IF WE EVER GET TO THE END OF THE
CX - -	SUPERTOTALS LINE AND FLAG7 = 0, THEN WE KNOW WE HAVE
CX - -	FINISHED THE SORT.


2000	OLPTR = STPTR
2010	CLPTR = THING(OLPTR+1)
2011	EB0PTR = OLPTR + 1
2020	NLPTR = THING(OLPTR)
2030	IF(CLPTR .EQ. 1H^) GO TO 2210
2040	FLAG7 = 0
2041	EB0PTR = OLPTR + 1
2042	EB1PTR = THING(EB0PTR)
2050	EB2PTR = THING(EB1PTR+5)
2060	IF(EB2PTR .EQ. 1H^) GO TO 2210
2061	EB3PTR = THING(EB2PTR+5)
2070	START1 = THING(THING(EB1PTR+1))
2080	START2 = THING(THING(EB2PTR+1))
2090	IF(START1 .GT. START2) GO TO 2120
2091	EB0PTR = THING(EB0PTR) + 5
2092	EB1PTR = EB2PTR
2093	EB2PTR = EB3PTR
2094	GO TO 2060
2100	OLPTR = NLPTR
2102	IF(THING(OLPTR) .EQ. 1H^) GO TO 2220
2110	GO TO 2010
2120	FLAG7 = 1
2122	PTR1 = EB1PTR
2130	PTR2 = THING(PTR1+5)
2140	PTR3 = THING(PTR2+5)
2150	THING(EB0PTR) = PTR2
2160	THING(PTR2+5) = PTR1
2170	THING(PTR1+5) = PTR3
2171	EB0PTR = THING(EB0PTR) + 5
2180	EB2PTR = EB3PTR
2181	GO TO 2060
2210	IF(FLAG7 .NE. 0) GO TO 2040
2212	GO TO 2100
2220	RETURN
	END




CX - -	****************************************************************
CX
CX - -	THIS SUBROUTINE OUTPUTS THE LIST OF EXPRESSIONS IN A
CX - -	SUPERTOTALS SERIES. THE FORMAT IS TO PRINT ALL THE EXP-
CX - -	RESSIONS THAT ARE ON A SINGLE SUPERTOTALS LINE, IN A SINGLE
CX - -	LINE OF THE REPORT GENERATOR FILE, THUS KEEPING THEM
CX - -	VISUALLY DISTINCT. AT LINE 1, P1 GETS A POINTER TO THE
CX - -	FIRST EXPRESSION BLOCK. ITS EXPRESSION IS UNPACKED,
CX - -	AND LOADED INTO LDBUF. IF IT'S NOT THE LAST EXPRESSION ON
CX - -	THE LINE, THEN ANOTHER ONE IS UNPACKED, ELSE THE LINE
CX - -	IS DUMPED. THIS PROCESS CONTINUES UNTIL THE SUPERTOTALS
CX - -	LIST HAS BEEN EXHAUSTED.


	SUBROUTINE PLIST(LSTPLC)
	IMPLICIT INTEGER(A-Z)
	COMMON /THING/THING(4000),THGPTR
	COMMON /LDBUF/LDBUF(150)
	COMMON /LBUFA1/LBUFA1(150)

	POS = 4
	CALL LOADA(1,4,'    ')
	LINPTR = LSTPLC
1	P1 = THING(LINPTR+1)
2	CALL UNPACK(THING,P1,PTR)
	DO 3 A0 = POS+1,POS+PTR
	A = A0
3	LDBUF(A) = LBUFA1(A-POS)
	POS = POS + PTR + 1
	LDBUF(POS) = 1H 
	IF(THING(P1+5) .EQ. 1H^) GO TO 4
	P1 = THING(P1+5)
	GO TO 2
4	CALL DUMP(POS-1)
	LINPTR = THING(LINPTR)
	IF(THING(LINPTR) .EQ. 1H^) GO TO 5
	POS = 4
	CALL LOADA(1,4,'    ')
	GO TO 1
5	RETURN
	END




CX - -	****************************************************************
CX
CX - -	THIS SUBROUTINE PRINTS OUT ALL THE FORMATS OF THE SUPERTOTALS
CX - -	TO MATCH THE EXPRESSIONS OUTPUT IN PLIST. THE TITLES ARE
CX - -	FIRST SCROLLED, THEN UNDERLINED. IF THERE ARE NO TITLES
CX - -	ON A GIVEN LINE, NO TITLES OR UNDERLINES ARE GENERATED.
CX - -	THEN A LINE OF FORMATS ARE GENERATED, WHERE EACH FORMAT
CX - -	CONSISTS OF A 'T' FACTOR, TO BRING THE OUTPUT UNDER THE DESIRED
CX - -	PLACE, AND EITHER A 'G' FACTOR, OR THE ACTUAL FORMAT DONATED
CX - -	BY THE USER.


	SUBROUTINE FLIST(LSTPLC)
	IMPLICIT INTEGER(A-Z)
	COMMON /THING/THING(4000),THGPTR
	COMMON /LDBUF/LDBUF(150)
	COMMON /LBUFA1/LBUFA1(150)
	COMMON /DELIM/ENDCHR


	CALL LOADA(1,10,'        //')
	CALL DUMP(10)


CX - -	HERE WE WILL DO THE SCROLLING OF THE TITLES.


100	AFLAG = 0
110	LINPTR = LSTPLC
120	DO 130 FREE0 = 1,150
	FREE = FREE0
130	LDBUF(FREE) = 1H 
140	CALL LOADA(9,1,'"')
150	POS = 9
160	FLAG = 0
170	EXPPTR = THING(LINPTR+1)
180	TTLPTR = THING(EXPPTR+2)
190	FWIDTH = THING(THING(EXPPTR+1)+1)-THING(THING(EXPPTR+1))+1
200	IF(THING(TTLPTR) .EQ. 1H^) GO TO 380
210	AFLAG = 1
220	IF(THING(TTLPTR) .EQ. 1H ) GO TO 380
230	DO 240 FREE0 = 1,150
	FREE = FREE0
240	LBUFA1(FREE) = 1H 
250	CALL UNPACK(THING,EXPPTR+2,NC)
260	FLAG = 1
270	DO 280 FIND0 = 1,FWIDTH
	FIND = FIND0
280	IF(LBUFA1(FIND) .EQ. ENDCHR) GO TO 290
290	START = THING(THING(EXPPTR+1))
292	IF(FIND .EQ. 1) GO TO 320
291	DO 300 A0 = POS+START,POS+START+FIND-2
	A = A0
300	LDBUF(A) = LBUFA1(A-START-POS+1)
320	DO 330 MOVE0 = FIND+1,NC
	MOVE = MOVE0
330	LBUFA1(MOVE-FIND) = LBUFA1(MOVE)
340	DO 350 A0 = NC-FIND+1,150
	A = A0
350	LBUFA1(A) = 1H 
360	CALL A1A5(THING(THING(EXPPRT+2)),LBUFA1,NC,1)
380	EXPPTR = THING(EXPPTR+5)
390	IF(EXPPTR .NE. 1H^) GO TO 180
400	IF(FLAG .EQ. 0) GO TO 440
401	DO 402 FREE0 = 150,1,-1
	FREE = FREE0
402	IF(LDBUF(FREE) .NE. 1H ) GO TO 403
403	IF(FREE .EQ. 9) GO TO 607
	CALL LOADA(FREE+1,3,'" /')
420	CALL DUMP(FREE+3)
430	GO TO 120
440	IF(AFLAG .EQ. 0) GO TO 6


CX - -	HERE WE WILL DO THE UNDERLINING.


450	DO 451 FREE0 = 1,150
	FREE = FREE0
451	LDBUF(FREE) = 1H 
	POS = 9
	CALL LOADA(9,1,'"')
452	EXPPTR = THING(LINPTR+1)
453	START = THING(THING(EXPPTR+1))
454	END = THING(THING(EXPPTR+1)+1)
	IF(THING(THING(EXPPTR+2)) .EQ. 1H^) GO TO 458
455	DO 456 A0 = POS+START,POS+END-1
	A = A0
456	LDBUF(A) = 1H-
458	EXPPTR = THING(EXPPTR+5)
459	IF(EXPPTR .NE. 1H^) GO TO 453
	DO 457 FREE0 = 150,1,-1
	FREE = FREE0
457	IF(LDBUF(FREE) .NE. 1H ) GO TO 460
460	CALL LOADA(FREE+1,3,'" /')
461	CALL DUMP(FREE+3)


CX	THIS IS WHERE THE FORMATS WILL BE OUTPUT.


6	DO 1000 FREE0 = 1,150
	FREE = FREE0
1000	LDBUF(FREE) = 1H 
1010	POS = 8
1020	EXPPTR = THING(LINPTR+1)
1030	START = THING(THING(EXPPTR+1))
1040	P1 = EXPPTR + 3
1050	CALL UNPACK(THING,P1,PTR)
1060	IF(LBUFA1(1) .NE. 1H^) GO TO 1160
1070	CALL Q3DIG(POS+1,1HR,START)
1080	CALL LOADA(POS+4,3,'T G')
1090	FWIDTH = THING(THING(EXPPTR+1)+1) - START + 1
1100	CALL Q3DIG(POS+7,1HL,FWIDTH)
1110	CALL LOADA(POS+10,1,' ')
1120	POS = POS + 10
1130	EXPPTR = THING(EXPPTR+5)
1140	IF(EXPPTR .NE. 1H^) GO TO 1030
1150	GO TO 4
1160	CALL Q3DIG(POS+1,1HR,START)
1161	CALL LOADA(POS+4,2,'T ')
1162	POS = POS + 5
1163	DO 1170 A0 = POS+1,POS+PTR
	A = A0
1170	LDBUF(A) = LBUFA1(A-POS)
1180	POS = POS + PTR + 1
1190	LDBUF(POS) = 1H 
1200	GO TO 1130
4	CALL LOADA(POS+1,3,' //')
	CALL DUMP(POS+3)
	AFLAG = 0
5	LINPTR = THING(LINPTR)
500	IF(THING(LINPTR) .NE. 1H^) GO TO 120
600	RETURN


607	CALL LOADA(1,9,'        /')
	CALL DUMP(9)
	GO TO 120
	END




CX - -	****************************************************************
CX
CX - -	THIS SUBROUTINE TAKES A THREE-DIGIT NUMBER(MAXIMUM), A
CX - -	PLACE TO START IN LDBUF, AND A SIGNAL AS TO WHETHER
CX - -	THE NUMBER IS TO BE RIGHT- OR LEFT-JUSTIFIED IN THE
CX - -	THREE PLACES IT IS ALLOTTED SHOULD THE NUMBER HAVE LESS THAN
CX - -	THREE DIGITS.


	SUBROUTINE Q3DIG(STRTPS,LORR,NUM)
	IMPLICIT INTEGER(A-Z)
	COMMON /LDBUF/LDBUF(150)
	LOCAL = NUM
310	LOC = STRTPS
320	IF(LOCAL .LT. 100) GO TO 4601
330	H100S = LOCAL/100
340	LOCAL = LOCAL - H100S*100
350	ENCODE(1,2,LDBUF(LOC)) H100S
2	FORMAT(I1)
3704	LOC = LOC + 1
3805	IF(LOCAL .LT. 10) GO TO 5003
390	TENS = LOCAL/10
400	LOCAL = LOCAL - TENS*10
410	ENCODE(1,2,LDBUF(LOC)) TENS
4206	LOC = LOC + 1
4307	ENCODE(1,2,LDBUF(LOC)) LOCAL
440	RETURN

4601	LDBUF(LOC) = 1H 
	IF(LORR .EQ. 1HR) GO TO 3704
470	LOC = STRTPS
	LDBUF(STRTPS+2) = 1H 
480	GO TO 3805

5003	LDBUF(LOC) = 1H 
	IF(LORR .EQ. 1HR) GO TO 4206
510	LOC = STRTPS
	LDBUF(STRTPS+1) = 1H 
520	GO TO 4307


	END




CX - -	****************************************************************
CX
CX - -	THE FOLLOWING SUBROUTINE TAKES CARE OF ALL THE ERROR-MESSAGES.
CX - -	THE OUTPUT IS OF THE FORM: 
CX
CX - -	?ERROR -- XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
CX
CX - -	WHERE XXXXXXXXXXXXXXXXXXXXXXXXXXX IS SPECIFIC ACCORDING
CX - -	TO THE NUMBER IN ERRNUM. 'LITRAL' IS EXACTLY THAT, A
CX - -	LITRAL THAN SOME OF THE ERROR MESSAGES WILL TYPE
CX - -	OUT TO NOTIFY THE USER AS TO EXACTLY WHAT IS WRONG.
CX - -	NUMWDS IS THE NUMBER OF WORDS IN THE LITRAL.
CX - -	IF INPUT IS FROM A LOG FILE, THEN THE PROGRAM HALTS
CX - -	EXECUTION AFTER OUTPUTTING THE ERRORMESSAGE (IF IT IS A
CX - -	FATAL ERROR) BECAUSE THE PROGRAM CANNOT CONTINUE
CX - -	AFTER A FATAL MESSAGE - IF THE LOGFILE IS CORRECT, THEN THE
CX - -	NEXT THING TO BE INPUT MIGHT HAVE NO RELATION WHATSOEVER TO
CX - -	WHAT THE ERROR INPUT MIGHT BE. THE SAFEST THING IS TO HALT
CX - -	EXECUTION, NOTIFY THE USER OF WHAT LINE IN THE LOG FILE
CX - -	THE ERROR OCCURRED ON, AND HALT.

	SUBROUTINE ERROR(ERRNUM,NUMWDS,LITRAL,MISC)
	IMPLICIT INTEGER(A-Z)
	COMMON /LOGIN/LOGIN
	COMMON /RDCNT/RDCNT
	DIMENSION LITRAL(10)


	STKNUM = 0
	WRITE(5,1)
1	FORMAT($,' ?ERROR -- ')
	GO TO (10,20,30,40,50,60,70,80,90,100),ERRNUM

10	WRITE(5,11)
11	FORMAT(1H+,'MUST HAVE AT LEAST ONE SORT LEVEL.',/)
	GO TO 900


20	WRITE(5,21),(LITRAL(F),F=1,NUMWDS)
21	FORMAT(1H+,$,10A5)
	WRITE(5,22)
22	FORMAT(1H+,' CANNOT BE ZERO/BLANK. TRY AGAIN.',/)
	GO TO 900


30	WRITE(5,31)
31	FORMAT(1H+,$,' INPUT WAS NOT ONE OF LISTED OPTIONS.
	2 TRY AGAIN --  ')
	GO TO 900

40	WRITE(5,41)
41	FORMAT(1H+,'MUST HAVE AT LEAST ONE FIELD.',/)
	GO TO 900


50	WRITE(5,51) MISC
51	FORMAT(1H+,'YOU HAVE EXCEEDED YOUR DECLARED LWIDTH.',
	2/,' NEW LWIDTH IS ',I3,'. THIS ERROR IS NON-FATAL.',/)
	RETURN


60	WRITE(5,61)
61	FORMAT(1H+,' INPUT WAS NOT ONE OF LISTED OPTIONS. TRY
	2 AGAIN.',/)
	GO TO 900

70	WRITE(5,71)
71	FORMAT(1H+,' VERSION NUMBER OF LOGFILE DOESN''T MATCH THIS',
	2/,' PROGRAM''S VERSION NUMBER. EXECUTION TERMINATED.',//)
	CALL EXIT

80	WRITE(5,81)
81	FORMAT(1H+,' YOU HAVEN''T DECLARED THAT MANY FIELDS. TRY A 
	2SMALLER NUMBER.',/)
	GO TO 900


90	WRITE(5,91)
91	FORMAT(1H+,'TEXT NOT ENDED WITH A QUOTE.',/)
	GO TO 900

100	WRITE(5,101)
101	FORMAT(1H+,'CAN''T LEAVE BLANK IF YOU WANTED SUPERTOTALS.',/)
	GO TO 900

900	IF(LOGIN .NE. 1HY) GO TO 1000
	WRITE(5,910) RDCNT
910	FORMAT(/,' EXECUTION TERMINATED.',/,' PLEASE REPAIR LOG FILE 
	2AT LINE ',I3)
	CALL EXIT
1000	RETURN
	END




CX - -	****************************************************************
CX
CX - -	THIS SUBROUTINE IS USED WHEN THE PROGRAM SPECIFICALLY NEEDS
CX - -	A YES OR NO ANSWER TO A QUESTION. THE USER IS ALLOWED TO TYPE
CX - -	IN EITHER 'Y', 'N', OR <CR>. ANYTHING ELSE WILL CAUSE THE
CX - -	PROGRAM TO RESPOND WITH AN ERROR MESSAGE, AND ALLOW THE USER
CX - -	ANOTHER CHANCE TO INPUT CORRECTLY.


	SUBROUTINE YESNO
	IMPLICIT INTEGER(A-Z)
	COMMON /RBUFA5/RBUFA5(30)

1	CALL READER
	IF(RBUFA5(1) .EQ. 1HY) GO TO 3
	IF(RBUFA5(1) .EQ. 1HN) GO TO 3
	IF(RBUFA5(1) .EQ. 1H ) GO TO 3
	CALL ERROR(3,0,0,0)
	GO TO 1
3	RETURN
	END




	SUBROUTINE PSHSTK
	IMPLICIT INTEGER(A-Z)
	COMMON /STACK/STACK(150),STKNUM
	COMMON /RBUFA5/RBUFA5(30)
	CALL A5A1(RBUFA5,STACK,150,1)
	DO 100 PTR0 = 150,1,-1
	PTR = PTR0
100	IF(STACK(PTR) .NE. 1H ) GO TO 101
101	STACK(PTR+1) = 1H;
	PTR = PTR + 1
103	PTR2 = 1
	STKNUM = 0
104	IF(STACK(PTR2) .EQ. 1H^) GO TO 110
	IF(STACK(PTR2) .EQ. 1H;) STKNUM = STKNUM + 1
	PTR2 = PTR2 + 1
105	IF(PTR2 .LE. PTR) GO TO 104
	RETURN
110	PTR2 = PTR2 + 2
	GO TO 105
	END



CX - -	*******************************************************

CX - -	THIS SUBROUTINE TAKES A TEXT FIELD IN A5 FORMAT AND
CX - -	REWRITES IT IN A1 FORMAT.
CX - -	THE USER CAN EASILY REPLACE THIS WITH A MORE
CX - -	EFFIECIENT MACRO SUBROUTINE.

	SUBROUTINE A5A1(A5BUF,A1BUF,LEN,START)
	IMPLICIT INTEGER (A-Z)
	DIMENSION A5BUF(1),A1BUF(150)

	DECODE(LEN,1,A5BUF) (A1BUF(I),I=START,START+LEN-1)
1	FORMAT(150A1)
	RETURN
	END



CX - -	****************************************************

CX - -	THIS SUBROUTINE TAKES A TEXT FIELD IN A1 FORMAT AND
CX - -	REWRITES IT IN A5 FORMAT.
CX - -	THE USER CAN EASILY REPLACE THIS WITH A MORE
CX - -	EFFICIENT MACRO SUBROUTINE.

	SUBROUTINE A1A5(A5BUF,A1BUF,LEN,START)
	IMPLICIT INTEGER (A-Z)
	DIMENSION A5BUF(1),A1BUF(150)

	ENCODE(LEN,1,A5BUF) (A1BUF(I),I=START,START+LEN-1)
1	FORMAT(150A1)
	RETURN
	END
'