Google
 

Trailing-Edge - PDP-10 Archives - BB-H580C-SB_1981 - srtsta.mac
There are 10 other files named srtsta.mac in the archive. Click here to see a list.
SUBTTL	SRTSTA - NON-COBOL ROUTINES FOR SORT
SUBTTL	D.M.NIXON/DMN/DZN/DLC/BRF/CLRH	4-Jun-81



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;
;COPYRIGHT (C) 1975, 1981 BY DIGITAL EQUIPMENT CORPORATION


IFN FTPRINT,<PRINTX [Entering SRTSTA.MAC]>
SUBTTL	TABLE OF CONTENTS FOR SRTSTA


;                    Table of Contents for SRTSTA
;
;
;                             Section                             Page
;
;   1  SRTSTA - NON-COBOL ROUTINES FOR SORT .....................   1
;   2  TABLE OF CONTENTS FOR SRTSTA .............................   2
;   3  DEFINITIONS
;        3.1  Flags .............................................   3
;        3.2  Low Segment Data ..................................   4
;   4  START ADDRESS AND OUTER LOOP
;        4.1  Entry Points ......................................   5
;        4.2  V/M Fortran Entry and Exit Points .................   6
;        4.3  Outer Loop ........................................   7
;   5  INITIALIZATION PROCEDURE .................................   8
;   6  SCAN CONTROL ROUTINES ....................................   9
;   7  SWITCH HANDLING
;        7.1  /FORMAT:xn.m ......................................  12
;   8  COLLATING SEQUENCE TABLE ROUTINES ........................  13
;   9  PSORT.
;        9.1  SORT Initialization Following Command Scanning ....  18
;        9.2  SETMOD - Set Up Recording Mode for SORT ...........  19
;        9.3  KEYEXT - Generate Key Extraction Code .............  21
;        9.4  Dispatch Tables for Key Extraction ................  22
;        9.5  KEYGEN - Generate Key Comparison Code .............  23
;  10  HPURE SEGMENT ERROR MESSAGES .............................  25
;  11  FATAL ERROR CLEAN-UP ROUTINES ............................  26
;  12  RELES.
;       12.1  Add Input Record to Tree ..........................  27
;       12.2  Merge Initialization ..............................  28
;       12.3  End of Input File
;            12.3.1  SORT Case ..................................  29
;            12.3.2  MERGE Case .................................  30
;            12.3.3  Check End Lables ...........................  31
;  13  MERGE. ...................................................  32
;  14  RETRN.
;       14.1  End of Output File ................................  33
;       14.2  MSTEOT - EOT Detected on Output Tape ..............  34
;       14.3  RETRNM - Return Record From First-pass Merge Files   35
;  15  TAPE LABEL ROUTINES
;       15.1  CHKLBL - Check Header Labels ......................  37
;       15.2  WRTLBL - Write Header Labels ......................  41
;       15.3  CHKEND - Check End Labels .........................  44
;       15.4  WRTEND - Write End-of-file Labels .................  47
;       15.5  WRTEOT - Write End-of-tape Labels .................  48
;  16  ENDS.
;       16.1  Clean Up After SORT ...............................  48
;  17  LPURE SEGMENT ERROR MESSAGES .............................  50
SUBTTL	DEFINITIONS -- Flags 


IFE FTFORTRAN,<

LOC	137
EXP	V%SORT
RELOC

>;END IFE FTFORTRAN

DEFINE	COMPARE	(R,J)<
	JSP	P4,@.CMPAR	;;[OK]
>
IF1,<
DEFINE	$JRST$	<BLOCK	1>	;KEEP MACRO HAPPY
>
SUBTTL	DEFINITIONS -- Impure Data


	SEGMENT	IMPURE		;[C20]

IFE FTFORTRAN,<			;ONLY IN STAND-ALONE SORT
STACK:	BLOCK	PDLEN		;PUSHDOWN STACK
>

ZCOR:!				;START OF DATA TO CLEAR
FSTKEY:	BLOCK	1		;POINTER TO LIST OF KEYS & ORDER
LSTKEY:	BLOCK	1		;POINTER TO LAST BLOCK OF KEYS
TEMPSW:	BLOCK	1		;THIS IS A TEMP FILE SPEC
COLSW:	BLOCK	1		;THIS IS A COLLATING SEQUENCE FILE SPEC
				;FORM= FLAGS1B12,27B17,LABEL ADDRSSB35
COLADR:	BLOCK	1		;[C20] COLLATING SEQUENCE ADDRESS IF IN CORE
COLCHN:	BLOCK	1		;CHANNEL IN THE AC FIELD FOR  READING
COLPTR:	BLOCK	4		;POINTER TO INPUT BUFFER FOR ALT COL SEQ
QOTCHR:	BLOCK	1		;[N25] EITHER " OR ' IN COLLATING SEQUENCE
F.OXBK:	BLOCK	1		;[215] WHERE TO FIND X. BLOCK FOR OUTPUT
F.OUZR:	BLOCK	1		;START OF SCAN OUTPUT CHAIN
F.INZR:	BLOCK	1		;START OF SCAN INPUT CHAIN
F.TMZR:	BLOCK	1		;START OF SCAN TEMP SPEC CHAIN
F.SPC==.-1			;START OF TEMP SWITCHES
F.BLKF:	BLOCK	1		;BLOCKING FACTOR
F.LABL:	BLOCK	1		;STANDARD, OMITTED, NONSTANDARD
F.VARI:	BLOCK	1		;VARIABLE RECORD SIZE
F.INDU:	BLOCK	1		;INDUSTRY COMPATIBLE MODE
F.STDA:	BLOCK	1		;STANDARD ASCII MODE
F.REW:	BLOCK	1		;[372] REWIND BEFORE USE
F.POSI:	BLOCK	1		;[C11] /POSITION: VALUE
F.UNL:	BLOCK	1		;[372] UNLOAD AFTER USE
F.FMT:	BLOCK	0		;[372]FORMAT STATEMENT

P.BLKF:	BLOCK	1		;DEFAULT BLOCKING FACTOR
P.LABL:	BLOCK	1		;STANDARD, OMITTED, NONSTANDARD
P.VARF:	BLOCK	1		;DEFAULT VARIABLE/FIXED RECORD SIZE
				;-1=UNKNOWN, 0=FIXED, +1=VARIABLE
P.INDU:	BLOCK	1		;INDUSTRY COMPATIBLE MODE
P.STDA:	BLOCK	1		;STANDARD ASCII MODE
BPWORD:	BLOCK	1		;NO. OF BYTES PER WORD
CORSIZ:	BLOCK	1		;SIZE IF /CORE SEEN
ALIGN:	BLOCK	1		;+1 IF OUTPUT TO BE WORD ALIGNED (ASCII)
STATSW:	BLOCK	1		;[C20] +1 IF STATISTICS REQUESTED
IBUFNO:	BLOCK	1		;NUMBER OF BUFFERS FOR INPUT FILE
RECSIZ:	BLOCK	1		;NUMBER OF WORDS IN RECORD
RECOUT:	BLOCK	1		;OUTPUT RECORD SIZE IN BYTES
MODE:	BLOCK	1		;RECORDING MODE BITS ,, INDEX
MODEM:	BLOCK	1		;MASK (SET BY SCAN)
IOMODE:	BLOCK	1		;[201] = RH OF MODE UNLESS /BIN, THEN = MODBINARY
P4SAV:	BLOCK	1
RECSAV:	BLOCK	1
INSREC:	BLOCK	1
.CMPAR:	BLOCK	1		;POINTER TO COMPARE CODE SEQUENCES
EXTORG:	BLOCK	1		;[C13] ADDRESS OF EXTRACT CODE SEQUENCES
EXTSZ:	BLOCK	1		;[C13] SIZE OF EXTRACT CODE SEQUENCES
XTRBYT:	BLOCK	1		;NO. OF EXTRA BYTES IN RECORD
MAXKEY:	BLOCK	1		;MIN. NO. OF WORDS TO HOLD ALL KEYS IN RECORD
MINKEY:	BLOCK	1		;MINIMUM SIZE VAR. LEN. REC. MUST BE
ADVFLG:	BLOCK	1		;[N11] POSITIVE IF WRITE AFTER ADVANCING REQUIRED
NOCRLF:	BLOCK	1		;[N11] POSITIVE IF ASCII FILES HAVE NO CRLF
LEAVES:	BLOCK	1		;[N11] NON ZERO IF /LEAVES SEEN
IFE FTOPS20,<
PRIORI:	BLOCK	1		;GLOBAL DSK PRIORITY
>
;
;	NOTE THAT BLT IN SCNSLT RUNS TO HERE!!!!!
SEQNO:	BLOCK	1		;[110] -1 = NO SEQ NO. ,+1 = SEQUENCE NO.
MXDVSZ:	BLOCK	1		;MAX. OF I.DVSZ FOR ALL INPUT FILES
COLITS==5*200			;ALLOW 128 WORDS FOR LITERAL
COLITB:	BLOCK COLITS/5		;BUFFER FOR COLLATE SEQUENCE LITERAL
COLBUF:	BLOCK	200		;HOLD THE ALTERNATE COLLATING SEQUENCE
EZCOR==.-1			;END OF DATA AREA TO ZERO

KEYZ	LAB,<STANDARD,OMITTED,NONSTANDARD,DEC,ANSI,IBM>
KEYZ	COL,<ASCII,EBCDIC,FILESPEC,LITERAL,ADDRESS,UASCII,UEBCDIC>
KEYZ	MOD,<SIXBIT,ASCII,EBCDIC,BINARY>
KEYZ	SUP,<NONE,INFORMATION,WARNING,FATAL,ALL>
SUBTTL	ENTRY POINTS

IFE FTFORTRAN,<
	SEGMENT	HPURE		;[C20]

BEGIN
  PROCEDURE	(,START)
  IFE FTOPS20,<
	PORTAL	.+3		;[C20] NORMAL ENTRY
	PORTAL	.+3		;[C20] CCL ENTRY
	PORTAL	FORENT		;[C20] V/M FORTRAN ENTRY

	TDZA	P1,P1		;NORMAL OFFSET
	MOVEI	P1,1		;CCL OFFSET
  IFE FTVM,<
	MOVEM	.SGNAM,RUNNAM	;[C20] SAVE INITIAL ACCS FOR GETSEG UUO
	MOVEM	.SGPPN,RUNDIR	;[C20]   ..
	MOVEM	.SGDEV,RUNDEV	;[C20]   ..
  >
	FASTSKIP		;[C20] SKIP BECAUSE FIRST TIME
RSTART:	SETZ	P1,		;[C20] NO OFFSET ON RESTARTS
	RESET			;[C20] [C13] RESET THE UNIVERSE
  IFN FTVM,<
	MOVEI	T2,1		;[C20] PAGE. UUO ARGUMENT COUNT
	MOVEI	T3,LOWORG/PGSIZ	;[C29] [C20] GET FIRST PAGE NUMBER
  $1%	MOVE	T0,[XWD .PAGCD,T2]	;[C20] GET ALL THE PAGES
	PAGE.	T0,		;[C20]   ..
	  NOOP			;[C20]   ..
	ADDI	T3,1		;[C20]   ..
	CAIG	T3,LOWEND/PGSIZ	;[C20]   ..
	JRST	$1		;[C20]   ..
  >
  	MOVEM	P1,OFFSET	;[C20] STORE ENTRY OFFSET
  >
  IFN FTOPS20,<
RSTART:	RESET%			;[C13] [335] THE KNOWN UNIVERSE
	MOVE	T1,[SIXBIT /SORTV4/]
	MOVE	T2,T1
	SETSN%			;[335] COLLECT PAGING STATISTICS
	  NOOP			;[C20]   ..
  >
	SETZM	FORRET		;[C20] DID NOT GET CALLED BY FORTRAN
	JSP	P4,INITIALIZE	;INITIALIZE
  IFE FTOPS20,<
	MOVE	T1,.ISBLK	;DATA BLOCK FOR ISCAN
	PUSHJ	P,.ISCAN##	;INITIALIZE SCANNER
  >
	JRST	LOOP		;[C20] START SORT
END;
;VIRTUAL MEMORY FORTRAN SORT ENTRY AND EXIT POINTS

BEGIN
  PROCEDURE	(JSP	T4,FORENT)
  IFE FTOPS20,<
	MOVEI	T2,1		;[C20] PAGE. UUO ARGUMENT COUNT
	MOVEI	T3,LOWORG/PGSIZ	;[C29] [C20] GET FIRST PAGE NUMBER
  $1%	MOVE	T0,[XWD .PAGCD,T2]	;[C20] GET ALL THE PAGES
	PAGE.	T0,		;[C20]   ..
	  JFCL			;[C20]   ..
	ADDI	T3,1		;[C20]   ..
	CAIG	T3,LOWEND/PGSIZ	;[C20]   ..
	JRST	$1		;[C20]   ..
  >
	MOVEM	T1,FORFUN	;[C20] SAVE FUNCT. ADDRESS
	MOVEM	T4,FORRET	;[C20] SAVE RETURN ADDRESS
	MOVEM	L,FORARG	;[C20] SAVE L
	MOVE	T1,FORARG	;[C20] GET ARG COUNT
	SUBI	T1,1		;[C20]   ..
	HLRE	T1,@T1		;[C20]   ..
	MOVMM	T1,FORCNT	;[C20] STORE FOR SCANNER
	MOVEM	P,FORPDP	;[C20] SAVE P
	MOVE	T1,HIORG+.JBHSM##	;[C20] EXCHANGE SYMBOL TABLES
	EXCH	T1,.JBSYM##	;[C20]   ..
	MOVEM	T1,FORSYM	;[C20]   ..
	JSP	P4,INITIALIZE	;[C20]
	MOVE	T1,FORARG	;[C20] GET FIRST ARG ADDRESS
	HRR	T1,@T1		;[C20]   ..
IFN FTKI10!FTKL10,<
	DMOVE	T2,[POINT 7,@T1	;[C20] GET INPUT BYTE POINTER
		POINT 7,BUFFER]	;[C20] OUTPUT BYTE POINTER
>
IFE FTKI10!FTKL10,<
	MOVE	T2,[POINT 7,@T1]	;[C20] GET INPUT BYTE POINTER
	MOVE	T3,[POINT 7,BUFFER]	;[C20] OUTPUT BYTE POINTER
>
  IFE FTOPS20,<
	MOVEM	T3,CMDPTR	;[C20] STORE IT FOR LATER
  >
	MOVNI	T4,5*BUFSIZ-2	;[C20] NO. OF CHARACTERS (NOT INCLUDING LF,NUL)
  $2%	TLNN	T2,(70B5)	;[C20] NEED TO ADVANCE INDIRECT BYTE POINTER?
	AOJA	T1,[SOJA T2,.+1]	;[C20] YES, ADVANCE IT PROPERLY
	ILDB	T0,T2		;[C20] GET CHAR
	JUMPE	T0,$3		;[C20] END ON NUL
	IDPB	T0,T3		;[C20] STORE
	AOJL	T4,$2		;[C20] LOOP
	$ERROR	(?,CTL,<Command string too long>)	;[C20]

  $3%	MOVEI	T0,.CHLFD	;[C20] LF
	IDPB	T0,T3		;[C20]
	SETZ	T0,		;[C20]
	IDPB	T0,T3		;[C20] END WITH NUL
	ADDI	T4,5*BUFSIZ-1	;[C20] DONT COUNT THE NULL
	MOVEM	T4,CMDLEN	;[C20] STORE SIZE
  IFN FTOPS20,<
	SETZM	FOR2ND		;[C20] RESET COMMAND SEEN BEFORE
  >
  IFE FTOPS20,<
	SETZM	QBUFER		;[C20] RESET FORTRAN OUTPUT BUFFER STATUS
	MOVE	T1,.ISFBK	;[C20] FORTRAN DATA BLOCK FOR ISCAN
	PUSHJ	P,.ISCAN##	;[C20] INITIALIZE SCANNER
  >
	JRST	LOOP		;[C20] GO TO SORT
END;

BEGIN
  PROCEDURE	(PUSHJ	P,FORXIT)
	MOVE	P,FORPDP	;[C20] RESTORE ORIGINAL P
	MOVE	T1,FORSYM	;[C20] RESTORE SYMBOL TABLE
	MOVEM	T1,.JBSYM##	;[C20]   ..
	AOS	FORRET		;[C20] SKIP RETURN
	JRST	@FORRET		;[C20]   ..
END;

BEGIN
  PROCEDURE	(PUSHJ	P,FORERR)
	MOVE	P,FORPDP	;[C20] RESTORE ORIGINAL P
	MOVE	T1,FORSYM	;[C20] RESTORE SYMBOL TABLE
	MOVEM	T1,.JBSYM##	;[C20]   ..
	SKIPLE	ERRADR		;[C20] A USER RETURN ADDRESS?
	JRST	@ERRADR		;[C20] YES
	JRST	@FORRET		;[C20] NO
END;

BEGIN
  PROCEDURE	(PUSHJ P,FUNCT.)
	JRST	@FORFUN		;[C20] CALL THE REAL FUNCT.
END;

>;END IFE FTFORTRAN

	SEGMENT	IMPURE		;[C20]

FORRET:	BLOCK	1		;[C20] RETURN ADDRESS
FORPDP:	BLOCK	1		;[C20] AC P
FORARG:	BLOCK	1		;[C20] ARGUMENT ADDRESS
FORCNT:	BLOCK	1		;[C20] ARGUMENT COUNT
FORFUN:	BLOCK	1		;[C20] ADDRESS OF FUNCT.
FORSYM:	BLOCK	1		;[C20] FORTRAN SYMBOL TABLE POINTER
IFN FTOPS20,<
FORHI:	BLOCK	1		;[N27] START OF HI-SEG, OTS, OR SORT
>

	SEGMENT	HPURE		;[C20]
SUBTTL	OUTER LOOP

	SEGMENT LPURE		;[C20]

BEGIN
  PROCEDURE	(PUSHJ	P,LOOP)
	PUSHJ	P,SSTATS	;[C20] SETUP STATS LOCS
	PUSHJ	P,SETSPC	;[C13] SETUP MEMORY LOCS
  	PUSHJ	P,SCAN		;CALL SCAN
				;  OR FORTRAN SCAN WHICH DOESN'T RETURN
	PUSHJ	P,PSORT.	;INITIALIZE SORT
	PUSHJ	P,RELES.	;READ INPUT FILES
	PUSHJ	P,MERGE.	;MERGE TEMP FILES
	PUSHJ	P,RETRN.	;WRITE OUTPUT FILES
	PUSHJ	P,ENDS.		;CLEAN UP
IFN FTFORTRAN,<
	SKIPG	ATSFLG		;
	RETURN
>
	JSP	P4,INITIALIZE	;DATA
	JRST	$B		;GET NEXT LINE
END;

	SEGMENT	HPURE		;[C20]
SUBTTL	INITIALIZATION PROCEDURE


	BLOCK	1			;[427] LINK TO NEXT
	ZCOR,,EZCOR			;[427] DATA TO ZERO
	.LINK	S.LNK,.-2		;[427] TELL LINK TO LINK TOGETHER


BEGIN
  PROCEDURE	(JSP	P4,INITIALIZE)
IFE FTOPS20,<
	PORTAL	.+1			;INCASE EXECUTE ONLY
>
IFE FTFORTRAN,<
 IFN FTVM,<
	XMOVEI	P,STACK-1		;[C20] SET UP STACK
 >
 IFE FTVM,<
	MOVE	P,[IOWD PDLEN,STACK]	;[N21] SET UP STACK
>>
	JSP	T4,ZDATA		;[134] ZERO COMMON DATA AREAS
	JSP	T4,CPUTST		;[134] MAKE SURE IF CPU OK
  IFE FTFORTRAN!FTVM,<
	BEGIN				;GET WHERE WE REALLY CAME FROM
		HRROI	T1,.GTRDV
		GETTAB	T1,		;GET DEVICE
		  JRST	$E		;PRE 6.03
		JUMPE   T1,$E		;[343] 6.03A
		MOVEM	T1,RUNDEV	;SAVE ACTUAL DEVICE
		HRROI	T1,.GTRDI
		GETTAB	T1,		;GET DIRECTORY
		  JRST	$E
		MOVEM	T1,RUNDIR	;SAVE ACTUAL PPN
		HRROI	T1,.GTRS0
		GETTAB	T1,		;GET SFD #1
		  JRST	$E		;PRE 6.04
		JUMPE	T1,$E		;NO SFD
		MOVEM	T1,RUNSFD	;SAVE SFD
		MOVEI	T1,RUNPTH	;GET POINTER
		EXCH	T1,RUNDIR	;SWAP WITH PPN
		MOVEM	T1,RUNPPN	;SAVE PPN
		HRROI	T1,.GTRS1
		GETTAB	T1,		;NEXT SFD
		  JRST	$E
		MOVEM	T1,RUNSFD+1
		JUMPE	T1,$E		;ALL DONE
		HRROI	T1,.GTRS2
		GETTAB	T1,		;NEXT SFD
		  JRST	$E
		MOVEM	T1,RUNSFD+2
		JUMPE	T1,$E		;ALL DONE
		HRROI	T1,.GTRS3
		GETTAB	T1,		;NEXT SFD
		  JRST	$E
		MOVEM	T1,RUNSFD+3
		JUMPE	T1,$E		;ALL DONE
		HRROI	T1,.GTRS4
		GETTAB	T1,		;NEXT SFD
		  JRST	$E
		MOVEM	T1,RUNSFD+4
		SETZM	RUNSFD+5	;TERMINATE WITH ZERO
	END;
  >;END IFE FTFORTRAN!FTVM
IFE FTOPS20,<
	PUSHJ	P,MONSPC		;[N12] SEE IF 7-SERIES MONITOR
>
IFN FTOPS20,<
	SETO	T1,			;GET JOB INFO FOR THIS JOB
	HRROI	T2,DFMTRS		;[407] SAVE DEFAULT MTA RECSIZE
	MOVX	T3,.JIRS		;GET DEFAULT MTA RECORD SIZE
	GETJI%				;[335]   ..
	 ERJMP	[$ERROR (?,GJF,<GETJI% failure at initialization time>)]
	SETO	T1,			;[C03] GET JOB INFO FOR THIS JOB
	HRROI	T2,DFMTMD		;[C03] SAVE DEFAULT MTA MODE
	MOVX	T3,.JIDM		;[C03]   ..
	GETJI%				;[C03]   ..
	 ERJMP	E$$GJF			;[C03]
	SETZM	MOUNTR			;[C12] CLEAR MOUNTR AROUND FLAG
>
	BEGIN				;SETUP INITIAL VALUES
		SETOM	P.BLKF		;BLOCKING FACTOR
		SETOM	P.VARF		;VARIABLE/FIXED RECORDS
		SETOM	P.INDU		;[143] /INDUSTRY
		SETOM	P.LABL		;[353] /LABEL
IFN FTOPS20,<
		SETOM	P.DENS		;[372] /DENSITY: (SCAN DOES THESE ON -10)
		SETOM	P.PARI		;[372] /PARITY:
		SETOM	P.REW		;[372] /REWIND
		SETOM	P.UNL		;[372] /UNLOAD
>
		PUSHJ	P,GETJOB	;[C20] GET JOB NUMBER
	END;
	RETURN
END;
SUBTTL	SCAN CONTROL ROUTINES

IFE FTFORTRAN,<
BEGIN
  PROCEDURE	(PUSHJ	P,CLRFIL)
	SETOM	TEMPSW		;RESET NOT SEEN FLAG
  IFE FTOPS20,<
	SKIPGE	T1,P.BLKF	;ALREADY SEEN A DEFAULT?
	SKIPL	T1,F.BLKF	;NO, TRY TEMP  BLOCKING FACTOR?
	MOVEM	T1,P.BLKF	;YES, USE THIS AS IT
	SKIPG	T1,P.LABL	;ALREADY SEEN LABEL?
	SKIPL	T1,F.LABL	;NO, TRY TEMP
	MOVEM	T1,P.LABL	;AS DEFAULT
	SKIPGE	T1,P.VARF	;[143] ALREADY SEEN DEFAULT?
	SKIPL	T1,F.VARI	;[143] NO--TRY FILE VAR/FIX
	MOVEM	T1,P.VARF	;[143] YES--USE THIS AS IT
	SKIPGE	T1,P.INDU	;ALREADY GOT A DEFAULT
	SKIPL	T1,F.INDU	;NO, DO WE NOW?
	MOVEM	T1,P.INDU	;YES
	SKIPGE	T1,P.STDA
	SKIPL	T1,F.STDA
	MOVEM	T1,P.STDA
  >;END IFE FTOPS20
	PJRST	CLRLOC		;FALL INTO CLRLOC
END;

>;END IFE FTFORTRAN
BEGIN
  PROCEDURE	(PUSHJ	P,CLRANS)
	;SET ALL FULL WORD QUANTITIES TO NULL
	; THAT IS -1 (FOR SCAN)
	;CALLED FROM SCAN BEFORE EACH "*" ONLY
	SETZM	F.INZR
	SETZM	F.OUZR
	SETZM	F.TMZR
	SETZM	FSTKEY
	SETZM	LSTKEY
IFE FTOPS20,<
	SETZM	PRIORI
>
	SETZM	COLSW
	SETOM	CORSIZ	
	SETOM	ALIGN
	SETOM	STATSW		;[C20]
	SETOM	RECORD
IFE FTOPS20,<			;[454] DON'T SET THIS AGAIN ON -20
	SETOM	MRGSW		;[454]
>				;[454]
	SETOM	WSCSW
	SETOM	NUMRCB
	SETOM	ERRADR		;[OK]
	SETOM	FERCOD		;[OK]
	SETOM	SUPFLG		;[351]
	SETOM	ADVFLG		;[N11]
	SETOM	NOCRLF		;[N11]
	SETOM	MAXTMP		;[N20]
IFE FTOPS20!FTFORTRAN,<
	MOVE	T1,[IOWD STCKSZ,CSTACK]	;[N06] MEMORY STACK MIGHT NOT BE IN INITIAL STATE
	MOVEM	T1,CORSTK	;[N06] BECAUSE OF A BUG IN SCAN IF COMMAND CONTAINED AN ERROR
>;END IFE FTOPS20!FTFORTRAN
;	PJRST	CLRLOC		;COMMON RETURN
END;


BEGIN
  PROCEDURE	(PUSHJ	P,CLRLOC)
	SETOM	F.BLKF
	SETOM	F.LABL
	SETOM	F.VARI
	SETOM	F.INDU
	SETOM	F.STDA
	SETOM	F.REW
	SETOM	F.POSI		;[C11]
	SETOM	F.UNL
IFN FTOPS20,<
	SETOM	F.DENS		;[372]
	SETOM	F.PARI		;[372]
>
	RETURN
END;
IFE FTFORTRAN,<
BEGIN
  PROCEDURE	(PUSHJ	P,MEMSTK)
	;ROUTINE TO MEMORIZE STICKY DEFAULTS
	;STORE RESULTS IN P.????

	SKIPL	T1,F.BLKF	;GET BLOCKING FACTOR
	MOVEM	T1,P.BLKF
	SKIPL	T1,F.LABL	;GET LABEL
	MOVEM	T1,P.LABL
	SKIPL	T1,F.VARI	;[143] GET FIX/VAR
	MOVEM	T1,P.VARF	;[143] STORE IF IT WAS SET
	SKIPL	T1,F.INDU
	MOVEM	T1,P.INDU
	SKIPL	T1,F.STDA
	MOVEM	T1,P.STDA
IFN FTOPS20,<
	SKIPL	T1,F.DENS	;[372] GET /DENSITY: VALUE AND SAVE IF IT
	MOVEM	T1,P.DENS	;[372]   WAS SET (SCAN DOES THIS ON TOPS10)
	SKIPL	T1,F.PARI	;[372] GET /PARITY: VALUE AND SAVE IF IT
	MOVEM	T1,P.PARI	;[372]   WAS SET
	SKIPL	T1,F.REW	;[372] GET /REWIND VALUE AND SAVE IF IT
	MOVEM	T1,P.REW	;[372]   WAS SET
	SKIPL	T1,F.UNL	;[372] GET /UNLOAD VALUE AND SAVE IF IT
	MOVEM	T1,P.UNL	;[372]   WAS SET
>
	RETURN
END;

DEFINE	APPLY (X,Y)<
	MOVE	T1,X		;DEFAULT
	SKIPGE	Y		;PARTICULAR SET
	MOVEM	T1,Y		;NO, APPLY DEFAULT
>

BEGIN
  PROCEDURE	(PUSHJ	P,APPSTK)
	APPLY	P.BLKF,F.BLKF
	APPLY	P.LABL,F.LABL
	APPLY	P.VARF,F.VARI
	APPLY	P.INDU,F.INDU
	APPLY	P.STDA,F.STDA
IFN FTOPS20,<
	APPLY	P.DENS,F.DENS	;[372]
	APPLY	P.PARI,F.PARI	;[372]
	APPLY	P.REW,F.REW	;[372]
	APPLY	P.UNL,F.UNL	;[372]
>
	RETURN
END;

BEGIN
  PROCEDURE	(PUSHJ	P,CLRSTK)	;ROUTINE TO CLEAR STICKY DEFAULTS
				;JUST A NO-OP FOR NOW
	RETURN
END;
>;END IFE FTFORTRAN
SUBTTL	SWITCH HANDLING -- /FORMAT:xn.m

BEGIN
  PROCEDURE	(PUSHJ	P,USRFMT)	;STORE THE /FORMAT ARGUMENT
	SKIPN	T1,LSTKEY		;GET POINTER TO KEY BLOCK
	JRST	E$$FSM			;/KEY BEFORE /FORMAT
	SKIPE	KY.FMT(T1)		;[OK] ONLY ONE /FORMAT PER /KEY
	JRST	E$$OOF			;COMPLAIN

	MOVX	T4,RM.FPA		;[C13] [203] MODE IS FLOATING POINT ASCII
	IORM	T4,MODE			;[C13]  ..
	IORM	T4,MODEM		;[C13]  ..

	MOVE	T0,[POINT 6,.NMUL]	;POINT AT FORMAT TYPE
	ILDB	T4,T0			;[C13] GET A CHAR

	PUSHJ	P,$5			;[C13] LOOK FOR A SCALING FACTOR
	  JRST	$1			;[C13] NOT FOUND, SKIP IT
	CAIE	T4,'P'			;[C13] FOUND IT, A P?
	JRST	E$$FSA			;[C13] NO, COMPLAIN
	HRRM	T3,KY.FMT+2(T1)		;[OK] [C13] SAVE SCALING FACTOR
	ILDB	T4,T0			;[C13] YES, GET A CHAR

  $1%	CAIL	T4,'D'			;[C13] MUST BE A D, E, F, OR G
	CAILE	T4,'G'			;[C13]  ..
	JRST	E$$FSA			;[C13] NO, COMPLAIN
	MOVE	T2,T4			;[C13] SAVE IT
	ILDB	T4,T0			;[C13] GET A CHAR

	PUSHJ	P,$5			;[C13] GET FIELD WIDTH
	  JRST [SETOM KY.FMT(T1)		;[OK] [C13] CAN'T, FREE FORMAT
		JRST $2]			;[C13] SKIP DECIMAL PLACES
	SKIPLE	T3			;[C13] WIDTH .LE. 0?
	CAMLE	T3,KY.SIZ(T1)		;[OK] [C13] OR WIDTH .GT. KEY SIZE?
	JRST	E$$FSA			;[C13] ERROR
	MOVEM	T3,KY.FMT(T1)		;[OK] [C13] SAVE FIELD WIDTH

	CAIE	T4,'.'			;[C13] DECIMAL PLACES SPECIFIED?
	JRST	$2			;[C13] NO, ASSUME ZERO
	ILDB	T4,T0			;[C13] YES, GET CHAR

	PUSHJ	P,$5			;[C13] GET DECIMAL PLACES
	  JRST	E$$FSA			;[C13] CAN'T, COMPLAIN
	SKIPL	T3			;[C13] DECIMAL PLACES .LT. 0?
	CAMLE	T3,KY.FMT(T1)		;[OK] [C13] OR DECIMAL PLACES .GT. WIDTH?
	JRST	E$$FSA			;[C13] ERROR
	MOVEM	T3,KY.FMT+1(T1)		;[OK] [C13] SAVE DECIMAL PLACES

  $2%	JUMPN	T4,E$$FSA		;[C13] MUST TERMINATE WITH A NULL

	CAIN	T2,'D'			;[C13] D TYPE?
	JRST	$3			;[C13] YES, MUST BE DOUBLE PRECISION
	CAIE	T2,'G'			;[C13] G TYPE
	JRST	$4			;[C13] NO, CAN'T BE DOUBLE PRECISION
	SKIPG	T2,KY.FMT(T1)		;[OK] [C13] YES, GET WIDTH
	MOVE	T2,KY.SIZ(T1)		;[OK] [C13] ONE WAY OR ANOTHER
	CAIG	T2,^D10			;[C13] WIDTH .GT. 10?
	JRST	$4			;[C13] NO, CAN'T BE DOUBLE PRECISION
  $3%	MOVX	T2,1B0			;[C13] DOUBLE PRECISION, REMEMBER THIS
	IORM	T2,KY.FMT+2(T1)		;[OK] [C13]  ..

  $4%	RETURN				;[C13] DONE

;	GET A POSITIVE NON-ZERO NUMBER SUBROUTINE

  $5%	SETZ	T3,			;[C13] START WITH A ZERO
	PUSH	P,T3			;[C13] PUT A ZERO ON THE STACK
	CAIN	T4,'+'			;[C13] PREFIXED BY A '+'?
	JRST   [ILDB	T4,T0			;[C13] YES, GET A CHAR
		JRST	$6]			;[C13] RESUME AT LOOP
	CAIN	T4,'-'			;[C13] PREFIXED BY A '-'?
	JRST   [SETOM	(P)			;[C13] YES, REMEMBER IT
		ILDB	T4,T0			;[C13] GET A CHAR
		JRST	$6]			;[C13] RESUME AT LOOP
	CAIL	T4,'0'			;[C13] NO SIGN, A DIGIT?
	CAILE	T4,'9'			;[C13]  ..
	JRST   [POP	P,(P)			;[C13] NO, RESTORE STACK
		POPJ	P,]			;[C13] ERROR RETURN
  $6%	CAIL	T4,'0'			;[C13] DONE?
	CAILE	T4,'9'			;[C13]  ..
	JRST	$7			;[C13] YES
	IMULI	T3,^D10			;[C13] ADD DIGIT TO NUMBER
	SUBI	T4,'0'			;[C20]   ..
	ADD	T3,T4			;[C20] [C13]  ..
	ILDB	T4,T0			;[C13] GET NEXT CHAR
	JRST	$6			;[C13] LOOP AROUND
  $7%	SKIPE	(P)			;[C13] NEGATIVE NUMBER?
	MOVNS	T3			;[C13] YES
	POP	P,(P)			;[C13] RESTORE STACK
	AOS	(P)			;[C13] SKIP RETURN
	POPJ	P,			;[C13]  ..

END;
SUBTTL	COLLATING SEQUENCE TABLE ROUTINES

BEGIN
  PROCEDURE	(PUSHJ	P,CHKCOL)
	HRRZ	T1,COLSW	;GET INDEX
  CASE COLLATING SEQUENCE OF (ASCII,EBCDIC,FILESPEC,LITERAL,ADDRESS)
	JRST	@[IFIWS <$1,$2,COLTRX,COLTRL,COLTRA>]-1(T1)	;[C20] DISPATCH ON KEY WORD

  $1%	;ASCII
	  CASE I/O MODE OF (ASCII,SIXBIT,EBCDIC,BINARY)
		HRRZ	T1,MODE
		MOVE	T1,[EXP 0,0,<IFIW ALP.97>,0]-1(T1)	;[C20]
	  ESAC;
	JRST	$C

  $2%	;EBCDIC
	  CASE I/O MODE OF (ASCII,SIXBIT,EBCDIC,BINARY)
		HRRZ	T1,MODE
		MOVE	T1,[EXP <IFIW ALP.69>,<IFIW ALP.79>,0,0]-1(T1)	;[C20]
	  ESAC;
;	JRST	$C

  ESAC;
	MOVEM	T1,COLSW	;STORE POINTER
	RETURN
END;
BEGIN
  PROCEDURE	(PUSHJ P,BLDCOL)
;CALL	MOVE	T1,LOCATION OF THE NEW TABLE
;	MOVEI	T2,GET THE NEXT CHARACTER ROUTINE
;	PUSHJ	P,BLDCOL
;RETURN	CPOPJ			;ILLEGAL ARGUMENTS (TABLE INVALID)
;	CPOPJ1			;TABLE IS BUILT

;	AC USAGE	P1=XWD LOCAL FLAGS,CURRENT COLLATING INDEX
			COL.MI==1B1	;PENDING MINUS SIGN
			COL.EQ==1B2	;PENDING EQUAL SIGN
			COL.QU==1B3	;[467] PENDING QUOTE
;			P2=LAST CHARACTER VALUE SEEN
;			P3=ADDRESS OR ROUTINE TO GET THE NEXT CHARACTER
;			P4=LOCATION OF THE COLLATING BLOCK
	PUSHJ	P,.SAVE4	;SAVE THE P'S
	HRRZ	P4,T1		;[C20] COPY THE TABLE ADDRESS
	MOVE	P3,T2		;[C20] COPY NEXT CHARACTER ROUTINE
	MOVE	T1,[XWD 707070,707070]
	MOVEM	T1,(P4)		;[OK] INITIALIZE THE TABLE
	HRLZI	T1,0(P4)	;[OK] MAKE A BLT POINTER
	HRRI	T1,1(P4)	;[OK]
	BLT	T1,177(P4)	;[OK] SET THE TABLE TO 707070,707070
	SETZ	P1,		;START AT COL. INDEX =0
  $1%	TXZ	P1,COL.QU	;[467] CLEAR PENDING QUOTE
	TXZE	P1,COL.MI	;[365] PENDING MINUS SIGN
	JRST	$6		;YES,
	TXZE	P1,COL.EQ	;[365] PENDING EQUAL SIGN
	JRST	$3		;YES
	PUSHJ	P,(P3)		;[OK] GET THE NEXT ALT SEQ CHARACTER
	  JRST	BLDCOE		;END OF INPUT GO FILL THE TABLE
	CAIN	T1,"-"		;IS IT A RANGE OF VALUES
	JRST	$6		;YES
	CAIN	T1,"="		;CHECK FOR AN EQUAL
	JRST	$3		;YES
	CAIE	T1,"'"		;[N25] IS IT A SINGLE QUOTE?
	CAIN	T1,""""		;IS IT A QUOTE
	JRST	[MOVEM	T1,QOTCHR	;[N25] YES, SAVE WHICH ONE
		JRST	$2]		;[N25] AND PROCESS A QUOTED STRING
	CAIE	T1,","		;SEPARATOR
	CAIN	T1," "		;TOP LEVEL BLANK
	JRST	$1		;YES SKIP IT
	CAIL	T1,"0"		;CHECK FOR A DIGIT
	CAILE	T1,"7"		;IN THE OCTAL RANGE
	POPJ	P,		;NO, ERROR NOTHING LEFT TO LOOK AT
	PUSHJ	P,BLDIGT	;GET THE DIGITS
	  POPJ	P,		;ILLEGAL DIGITS
	PUSHJ	P,BLDCOS	;STORE THE VALUE
	AOJA	P1,$1		;UPDATE THE INDEX AND TRY AGAIN
	JRST	$1		;GET THE NEXT CHARACTER

  $2%	TXO	P1,COL.QU	;[467] SET QUOTE FLAG.
	PUSHJ	P,(P3)		;[OK] GET THE NEXT CHARACTER
	  POPJ	P,		;END OF DATA WITH NO ENDING QUOTE
	CAMN	T1,QOTCHR	;[N25] IS IT A MATCHING ENDING QUOTE?
	JRST	$1		;YES, GET THE NEXT CHARACTER
	PUSHJ	P,BLDCOS	;STORE THE INDEX VALUE FOR THE CHARACTER
	AOJA	P1,$2		;INCREMENT THE INDEX GET NEXT CHARACTER

  $3%	SOJL	P1,CPOPJ	;BAKUP THE INDEX TO THE PREVIOUS VALUE
				;(ERROR IF NO PREVIOUS VALUE)
	PUSHJ	P,(P3)		;[OK] GET THE NEXT CHARACTER
	  POPJ	P,		;ILLEGAL SEQUENCE
	CAIE	T1,""""		;[N25] A STRING
	CAIN	T1,"'"		;[N25] ...
	TRNA			;[N25] YES
	JRST	$5		;NO
	MOVEM	T1,QOTCHR	;[N25] SAVE WHICH ONE IT IS
  $4%	PUSHJ	P,(P3)		;[OK] GET THE NEXT CHARACTER OF THE STRING
	  POPJ	P,		;ILLEGAL SEQUENCE
	CAMN	T1,QOTCHR	;[N25] END OF STRING
	AOJA	P1,$1		;YES, RESTORE THE INDEX GET NEXT CHARACTER
	PUSHJ	P,BLDCOS	;STORE THE CHARACTER
	JRST	$4		;NO, GET THE NEXT STRING CHARACTER
  $5%	PUSHJ	P,BLDIGT	;GET THE DIGITS
	  POPJ	P,		;ILLEGAL DIGITS
	PUSHJ	P,BLDCOS	;STORE THE INDEX
	AOJA	P1,$1		;RETURN FOR NEXT CHARACTER

  $6%	PUSHJ	P,(P3)		;[OK] GET THE SECOND VALUE
	  POPJ	P,		;ILLEGAL STRING
	CAIE	T1,""""		;[N25] QUOTED STRING?
	CAIN	T1,"'"		;[N25] ...
	TRNA			;[N25] YES
	JRST	$7		;NOPE
	MOVEM	T1,QOTCHR	;[N25] SAVE WHICH ONE IT IS
	PUSHJ	P,(P3)		;[OK] YES, GET THE CHARACTER
	  POPJ	P,		;ILLEGAL STRING
	PUSH	P,T1		;SAVE THE CHARACTER
	PUSHJ	P,(P3)		;[OK] GET THE NEXT CHARACTER
	  CAIA			;SKIP ON ERROR
	CAME	T1,QOTCHR	;[N25] MUST END WITH QUOTE
	  JRST	[POP	P,(P)	;ILLEGAL STRING REMOVE THE SAVED CHARACTER
		POPJ	P,]	;RETURN
	POP	P,T1		;RESTORE THE CHARACTER
	JRST	$8		;CONTINUE

  $7%	PUSHJ	P,BLDIGT	;CHECK FOR A DIGIT
	  POPJ	P,		;ILLEGAL DIGIT
  $8%	MOVE	T4,T1		;[C20] SAVE THE ENDING CHARACTER
  $9%	AOS	T1,P2		;INCREMENT LAST CHARACTER STORED
	CAMLE	T1,T4		;CHECK THE RANGE
	JRST	$1		;END OF RANGE
	PUSHJ	P,BLDCOS	;STORE IN THE TABLE
	AOJA	P1,$9		;[365] INCREMENT THE INDEX AND CONTINUE UNTIL EQUAL
END;
;SUBROUTINE BLDCOS - STORE THE CURRENT CHARACTER IN THE TABLE
;CALL	PUSHJ	P,BLDCOS
;RETURN	CPOPJ

BEGIN
  PROCEDURE	(PUSHJ	P,BLDCOS)
	MOVE	P2,T1		;[C20] SAVE THE CHARACTER
	HRRZ	T3,IOMODE	;[460] GET EXTERNAL I/O MODE
  CASE I/O MODE OF (SIXBIT, ASCII, EBCDIC, BINARY)
	JRST	@[IFIWS <$2,$1,$3,$3>]-1(T3)	;[460] DISPATCH

  $3%	$ERROR	(?,CNS,<EBCDIC or BINARY collating sequence is not supported.>)

  $2%	CAIL	T3,40		;[460] MAKE SURE ITS IN SIXBIT RANGE
	CAILE	T1,137		;[460] ...
	JRST	E$$ICS		;[460] ITS NOT
	SUBI	T1,40		;[460] CONVERT TO SIXBIT
  $1%	IDIVI	T1,2		;[460] GET THE TABLE INDEX AND WHICH HALF
	ADD	T1,P4		;[C20] TABLE OFFSET
	XCT	[HRLM	P1,(T1)	     ;[OK] STORE IN THE LEFT HALF (EVEN)
		HRRM	P1,(T1)](T2) ;[OK] STORE IN THE RIGHT HALF (ODD)
	RETURN
  ESAC;
END;

;SUBROUTINE BLDCOE - WILL FILL IN THE MISSING ELEMENTS OF THE TABLE
;CALL	PJRST	BLDCOE WHEN END OF THE COLLATING STRING
;RETURN	CPOPJ1

BEGIN
  PROCEDURE	(PUSHJ	P,BLDCOE)
	MOVEI	T4,200		;[C20] SIZE OF THE TABLE
  $1%	HLRZ	T1,(P4)		;[OK] GET THE LEFT HALF ENTRY
	CAIE	T1,707070	;CHECK FOR A NULL ENTRY
	JRST	$2		;NO, IT WAS USED
	HRLM	P1,(P4)		;[OK] STORE THE CURRECT INDEX
	ADDI	P1,1		;[365] INCREMENT THE INDEX
  $2%	HRRZ	T1,(P4)		;[OK] GET THE RIGHT HALF
	CAIE	T1,707070	;IS IT EMPTY
	JRST	$3		;NO
	HRRM	P1,(P4)		;[OK] YES, SET THE INDEX
	ADDI	P1,1		;[365] STEP THE INDEX
  $3%	AOS	P4		;[C20] CONTINUE THRU THE TABLE
	SOJG	T4,$1		;[C20]   ..
	JRST	CPOPJ1		;[365] SKIP RETURN
END;
BEGIN
;SUBROUTINE BLDIGT - CONVERT A STRING OF DIGITS
;CALL	MOVEI	T1,FIRST DIGIT
;	PUSHJ	P,BLDIGT
;RETURN	CPOPJ			;NOT DIGITS
;	CPOPJ1			;T1=BINARY DIGITS
  PROCEDURE	(PUSHJ	P,BLDIGT)
	SETZ	T2,		;CLEAR THE OUTPUT WORD
	JRST	$1		;CONTINUE BELOW

  $5%	PUSHJ	P,(P3)		;[OK] GET THE CHARACTER
	  JRST	$2		;END OF INPUT
  $1%	CAIN	T1,"="		;CHECK FOR SEPARATORS
	JRST	$3		;YES
	CAIN	T1,"-"
	JRST	$4		;YES
	CAIE	T1," "		;OR BLANKS (FORTRAN LITERALS)
	CAIN	T1,","		;MUST END WITH A COMMA
	JRST	$2		;YES, END OF STRING
	CAIL	T1,"0"		;DID A DIGIT ARRIVE
	CAILE	T1,"7"
	POPJ	P,		;ERROR ILLEGAL SEPARATOR
	LSH	T2,3		;YES, MAKE ROOM FOR THE DIGITS
	SUBI	T1,"0"		;[C20] ACCUMULATE THE SUM
	ADD	T2,T1		;[C20]   ..
	JRST	$5		;GET THE NEXT DIGITS

  $3%	TXOA	P1,COL.EQ	;[365]
  $4%	TXO	P1,COL.MI	;[365]
  $2%	MOVE	T1,T2		;COPY THE RESULT
	JRST	CPOPJ1		;[365] SKIP RETURN
END;
BEGIN
 PROCEDURE	(PUSHJ	P,COLTRL)
	MOVE	T1,[POINT 7,COLITB]	;FORM BYTE POINTER
	MOVEM	T1,COLPTR+2
	MOVE	T1,[IFIW COLBUF]	;[C20]
	MOVEM	T1,COLSW	;POINT TO TABLE
	MOVEI	T2,COLLCH	;INPUT ROUTINE
	PUSHJ	P,BLDCOL	;BUILD THE TABLE
	  JRST	E$$ICS
	RETURN
END;

BEGIN
 PROCEDURE	(PUSHJ	P,COLTRA)
	MOVSI	T1,(POINT 7,(T1))	;[C20] GET BYTE POINTER
	MOVEM	T1,COLPTR+2
	MOVE	T1,[IFIW COLBUF]	;[C20]
	MOVEM	T1,COLSW	;POINT TO TABLE
	MOVEI	T2,COLLCH	;INPUT ROUTINE
	PUSHJ	P,BLDCOL	;BUILD THE TABLE
	  JRST	E$$ICS
	RETURN
END;

BEGIN
  PROCEDURE	(PUSHJ	P,COLLCH)
	MOVE	T1,COLADR	;[C20] IN CASE ITS NEEDED FOR BYTE PTR
	ILDB	T1,COLPTR+2	;GET A CHAR
	JUMPE	T1,CPOPJ	;STOP ON NULL
	CAIGE	T1," "		;IGNORE CONTROL CHAR
	JRST	$B
	JRST	CPOPJ1		;[365]
END;
SUBTTL	PSORT. -- SORT Initialization Following Command Scanning

BEGIN
  PROCEDURE	(PUSHJ	P,PSORT.)
IFE FTOPS20,<
	SKIPN	T1,LSTKEY	;GET LAST KEY SEEN
	JRST	E$$OKR		;AT LEAST ONE KEY REQUIRED
	MOVE	T2,MODE		;GET MODE OF LAST KEY
	MOVEM	T2,KY.MOD(T1)	;[OK] STORE IT
	MOVE	T2,MODEM	;GET MASK OF ALL MODE BITS
	ANDX	T2,RM.ASC!RM.SIX!RM.EBC!RM.BIN!RM.FOR!RM.FPA
	MOVEM	T2,MODE		;CLEAR TEMP BITS AND RHS
	PUSHJ	P,SETMOD	;SETUP SORT MODE
>
	SKIPE	COLSW		;COLLATING SWITCH SEEN?
	PUSHJ	P,CHKCOL	;YES, SEE WHAT IT WAS
IFE FTFORTRAN,<
	MOVEI	T1,1		;[C20] SET DEFAULT /STATISTICS:YES
	SKIPE	FORRET		;[C20] IF CALLED FROM FORTRAN
	MOVEI	T1,0		;[C20] SET DEFAULT /STATISTICS:NO
	SKIPGE	STATSW		;[C20] IF NECESSARY
	MOVEM	T1,STATSW	;[C20]   ..
	SKIPLE	T1,NUMRCB	;[N11] DID USER SUPPLY /LEAVES:?
	MOVEM	T1,LEAVES	;[N11] YES
>
IFN FTOPS20,<
	MOVEI	T1,MX.TMP	;[N20] ASSUME 26 TEMP FILES
	SKIPG	MAXTMP		;[N20] UNLESS USER SAID OTHERWISE
>
IFE FTOPS20,<
	PUSHJ	P,SETCHN	;[N20] [C19] SETUP CHANNEL ALLOCATOR
	MOVE	T1,CHNFRE	;[N20] [C19] GET CHANNELS AVAILABLE
	SUBI	T1,1		;[N20] [C19] LESS INPUT/OUTPUT FILE
>
	MOVEM	T1,MAXTMP	;[N20] STORE MAX. NO. OF TEMP FILES ALLOWED
	MOVN	T1,MAXTMP	;[N20] [C19] MAKE AN AOBJ POINTER
	HRLZM	T1,TCBIDX	;[N20] [C19] PUT IT AWAY FOR LATER
	SKIPLE	T1,RECORD	;NUMBER OF BYTES IN RECORD
	JRST	$2		;SPECIFIED
	SKIPG	T1,RECOUT	;SEE IF ON OUTPUT SIDE
	JRST	E$$RSR		;ERROR
	MOVEM	T1,RECORD	;STORE IT
  $2%	IDIV	T1,BPWORD	;GET NO. OF WORDS
	SKIPE	T2		;RESIDUE ?
	ADDI	T1,1		;YES, INCREMENT NUMBER OF WORDS
	MOVEM	T1,RECSIZ	;SET RECORD SIZE
	MOVEM	T1,REKSIZ	;INITIAL IN-MEMORY RECORD SIZE
	SKIPLE	NOCRLF		;[N11] IF /NOCRLF SPECIFIED
	SETZM	P.VARF		;[N11] DEFAULT TO /FIXED
  IF I/O MODE IS SIXBIT OR VARIABLE EBCDIC
	HRRZ	T1,IOMODE	;[201] FETCH EXTERNAL I/O MODE INDEX
	CAXN	T1,MODSIXBIT	;[201] SIXBIT?
	JRST	$1		;[201] YES--GO INCLUDE COUNT WORD IN RECSIZ
	CAXN	T1,MODEBCDIC	;[201] EBCDIC?
	SKIPG	P.VARF		;[201] SO FAR SO GOOD. VARIABLE TOO?
	JRST	$F		;[201] NO--NO COUNT WORD THEN
  $1%
  THEN EXTERNAL RECORD INCLUDES A COUNT WORD TOO
	AOS	RECSIZ		;[201] REALLY 4 BYTES (= 1 WORD) FOR EBCDIC
  FI;
	PUSHJ	P,SETTMP	;[214] GET ALL TEMP FILES USER SPECIFIED
IFE FTOPS20,<
	PUSHJ	P,PRUNE		;[214] PRUNE NULL FILES FROM LISTS
>
	PUSHJ	P,SETUPO	;SETUP OUTPUT FILES
	PUSHJ	P,SETUPI	;SETUP INPUT FILES
	MOVX	T1,FTEXSZ	;[C13] GET SIZE OF KEY EXTRACT CODE AREA
	MOVEM	T1,EXTSZ	;[C13] REMEMBER IT
	PUSHJ	P,GETSPC	;[C13] GO ALLOCATE IT
	  JRST	E$$NEC		;[C13] FAILED
	XMOVEI	T1,(T1)		;[C20] MAKE SURE IT HAS THE SECTION
	MOVEM	T1,EXTORG	;[C13] WHERE EXTRACT KEY CODE WILL GO
	PUSHJ	P,KEYEXT	;GENERATE CODE TO EXTRACT KEYS
	PUSHJ	P,KEYGEN	;GENERATE CODE FOR KEY COMPARES
	MOVEI	T1,1		;ACCOUNT FOR HEADER WORD
	ADD	T1,XTRWRD	;PLUS EXTRACTED KEYS
	ADDM	T1,REKSIZ	;NEW RECORD SIZE IN MEMORY
	MOVE	T1,MAXKEY	;GET NO. OF BYTES WE REALLY NEED
	IDIV	T1,BPWORD	;IN WORDS
	SKIPE	T2
	ADDI	T1,1		;COUNT REMAINDER
	MOVEM	T1,MAXKEY	;STORE BACK FOR GTTREC
	MOVN	T1,XTRBYT	;[461] IF WE HAVE ALLOCATED SPACE FOR EXTRACTED KEYS
	ADDM	T1,MINKEY	;[461] REMOVE FROM SIZE OF ORIGINAL RECORD
	MOVEI	T1,MSTEOF	;END OF FILE INTERCEPT ADDRESS
	MOVEM	T1,LOGEOF	;LOGICAL EOF
	MOVEM	T1,PHYEOF	;PHYSICAL EOF
  IF /MERGE
	SKIPLE	MRGSW
  THEN INITIALIZE UP TO MX.TMP OF THE INPUT FILES
	PUSHJ	P,SETMRG	;SETUP DIFFERENTLY
  FI;
	XMOVEI	T1,PSORT%	;[C20] [C13] CHECK AND SET MEMORY SIZE, GOTO LOWSEG
	PUSH	P,T1		;[C20]   ..
	PJRST	CHKCOR		;[C13] DO IT THIS WAY IN CASE WE'RE GONE
END;
SUBTTL	PSORT. -- SETMOD - Set Up Recording Mode for SORT

BEGIN
  PROCEDURE	(PUSHJ	P,SETMOD)
	HLLZ	T1,MODEM	;[C20] GET MASK OF ALL MODE BITS
	SETZ	U,		;[C20] CLEAR INDEX
  IF RECORDING MODE IS BINARY AND NOT FORTRAN
	TXNN	T1,RM.FOR	;[C20] FORTRAN BINARY IS OK
	TXNN	T1,RM.BIN	;[C20] BINARY IS SPECIAL
	JRST	$F
  THEN CHECK /FIX /VARIABLE SETTINGS
	SKIPLE	P.VARF		;CANNOT HAVE /VARIABLE WITH BINARY
	JRST	E$$BNV
	SETZM	P.VARF		;FORCE FIXED LENGTH
  FI;
	LDB	T2,[POINT 3,T1,^L<RM.EBC>]	;[C20] GET ASCII/SIXBIT/EBCDIC SWITCH
	JRST	@.+1(T2)	;[C20] DISPATCH
		IFIW	SETMU	;[C20] UNDEFINED
		IFIW	SETME	;[C20] EBCDIC
		IFIW	SETMS	;[C20] SIXBIT
		IFIW	E$$MSC	;[C20] ERROR
		IFIW	SETMA	;[C20] ASCII
		IFIW	E$$MSC	;[C20] ERROR
		IFIW	E$$MSC	;[C20] ERROR
		IFIW	E$$MSC	;[C20] ERROR

SETMU:	TXNE	T1,RM.BIN	;[C20] BINARY ONLY?
	JRST	SETMB		;YES
	TXNN	T1,RM.COM!RM.PAC	;[C20] COMPUTATIONAL?
	JRST	SETMA		;NO, SO USE ASCII BY DEFAULT
	TXNE	T1,RM.PAC	;[C20] COMP-3?
	JRST	SETME		;YES, EBCDIC BY DEFAULT
SETMS:	TXNE	T1,RM.PAC	;[C20] /SIX /PAC
	JRST	E$$MSC		;ERROR
	MOVEI	U,MODSIXBIT	;[C20] SIXBIT
	TXNN	T1,RM.BIN	;[C20] [203] UNLESS FILE IS ALREADY BINARY,
	MOVEM	U,P.VARF	;[C20] [105] FORCE SIXBIT TO BE VARIABLE
	JRST	RETMOD

SETMA:	TXNE	T1,RM.PAC	;[C20] /ASC /PAC ?
	JRST	E$$MSC		;ERROR
	MOVX	T2,RM.ASC	;[C20] TURN ON ASCII BIT INCASE BY DEFAULT
	IORM	T2,MODE		;[C20] AND STORE BACK IN MODE
	MOVEI	U,MODASCII	;[C20] ASCII
	SKIPGE	P.VARF		;DID USER SPECIFY FIXED LENGTH
	MOVEM	U,P.VARF	;[C20] [105] NO, ASSUME VARIABLE SIZE
	TXNE	T1,RM.FOR	;[C20] FORTRAN ASCII?
	MOVEM	U,ALIGN		;[C20] [105] YES, FORCE WORD ALIGNMENT
	JRST	RETMOD

SETME:	MOVEI	U,MODEBCDIC	;[C20]
IFN FTOPS20,<
	SKIPGE	P.VARF		;[372] DEFAULT TO /FIXED ON TOPS-20
	SETZM	P.VARF		;[372]   ..
>
	JRST	RETMOD

SETMB:	SKIPGE	P.VARF		;DID USER SPECIFY FIXED LENGTH
	MOVEM	U,P.VARF	;[C20] [105] NO, ASSUME VARIABLE SIZE
	MOVEI	U,MODBINARY	;[C20]
;	JRST	RETMOD

RETMOD:	HRRM	U,MODE		;STORE MODE BACK
	MOVE	T2,[EXP 6,5,4,1]-1(U)
	MOVEM	T2,BPWORD	;NO. OF BYTES PER WORD
  IF RECORDING MODE IS BINARY
	TXNE	T1,RM.BIN	;[C20] [201] LEAVE MODE ALONE UNLESS /BINARY
  THEN I/O MODE IS BINARY
	MOVEI	U,MODBINARY	;[C20] [201] /BINARY FORCES BINARY I/O
  FI;
	HRRM	U,IOMODE	;[201] SAVE SO I/O ROUTINES WILL KNOW
	MOVE	T2,[EXP 6,5,4,1]-1(U) ;[300] NUMBER OF I/O BYTES PER WORD
	MOVEM	T2,IOBPW	;[201] SAVE FOR I/O ROUTINES
	MOVE	T2,[EXP 1,5,4,1]-1(U) ;[C03] NUMBER OF I/O BYTES PER WORD USED
	MOVEM	T2,IOBPW2	;[C03] SAVE FOR I/O ROUTINES
	RETURN
END;
BEGIN
  PROCEDURE	(PUSHJ	P,JMODES)
	;ENTER WITH 
	;T1 = MODES + INDEX
	;RETURN WITH
	;J = TYPE INDEX
	HRRZ	T2,T1		;[C20] DISPATCH
	JRST	@.(T2)		;[C20]   ..
		IFIW	SETKS	;[C20] SIXBIT
		IFIW	SETKA	;[C20] ASCII
		IFIW	SETKE	;[C20] EBCDIC
		IFIW	SETKB	;[C20] BINARY

SETKS:	LDB	T2,[POINT 3,T1,^L<RM.NUM>]	;[C20] GET NEXT BITS
	JRST	@.+1(T2)	;[C20] DISPATCH
		IFIW	SETMSU	;[C20] UNDEFINED
		IFIW	SETMSN	;[C20] NUMERIC
		IFIW	SETMSC	;[C20] COMPUTATIONAL
		IFIW	E$$MSC	;[C20] ERROR
		IFIW	SETMSA	;[C20] ALPHANUMERIC
		IFIW	E$$MSC	;[C20] ERROR
		IFIW	E$$MSC	;[C20] ERROR
		IFIW	E$$MSC	;[C20] ERROR

SETMSU:	TXNN	T1,RM.SGN!RM.UNS	;[C20] SIGN SPECIFIED?
	JRST	SETMSA		;NO, ALPHANUMERIC BY DEFAULT
SETMSN:	TXNN	T1,RM.UNS	;[C20] SPECIFICALLY UNSIGNED?
	SKIPA	J,[IX.NSS]	;[C20] NO, NUMERIC SIGNED SIXBIT
	MOVEI	J,IX.NUS	;[C20] YES, NUMERIC UNSIGNED SIXBIT
	RETURN

SETMSC:	TXNN	T1,RM.UNS	;[C20] SPECIFICALLY UNSIGNED?
	SKIPA	J,[IX.CSS]	;[C20] NO, COMPUTATIONAL SIGNED SIXBIT
	MOVEI	J,IX.CUS	;[C20] YES, COMPUTATIONAL UNSIGNED SIXBIT
	RETURN


SETKA:	LDB	T2,[POINT 3,T1,^L<RM.NUM>]	;[C20] GET NEXT BITS
	JRST	@.+1(T2)	;[C20] DISPATCH
		IFIW	SETMAU	;[C20] UNDEFINED
		IFIW	SETMAN	;[C20] NUMERIC
		IFIW	SETMAC	;[C20] COMPUTATIONAL
		IFIW	E$$MSC	;[C20] ERROR
		IFIW	SETMAA	;[C20] ALPHANUMERIC
		IFIW	E$$MSC	;[C20] ERROR
		IFIW	E$$MSC	;[C20] ERROR
		IFIW	E$$MSC	;[C20] ERROR

SETMAU:	TXNE	T1,RM.FPA	;[C20] FORTRAN FLOATING POINT ASCII?
	JRST	SETMAF		;YES
	TXNN	T1,RM.SGN!RM.UNS	;[C20] SIGNED?
	JRST	SETMAA		;NO, ALPHANUMERIC BY DEFAULT
SETMAN:	TXNN	T1,RM.UNS	;[C20] SPECIFICALLY SIGNED?
	SKIPA	J,[IX.NSA]	;[C20] NO, NUMERIC SIGNED ASCII
	MOVEI	J,IX.NUA	;[C20] YES, NUMERIC UNSIGNED ASCII
	RETURN

SETMAC:	TXNN	T1,RM.UNS	;[C20] SPECIFICALLY SIGNED?
	SKIPA	J,[IX.CSA]	;[C20] NO, COMPUTATIONAL SIGNED ASCII
	MOVEI	J,IX.CUA	;[C20] YES, COMPUTATIONAL UNSIGNED ASCII
	RETURN

SETKE:	LDB	T2,[POINT 4,T1,^L<RM.PAC>]	;[C20] GET NEXT BITS
	JRST	@.+1(T2)	;[C20] DISPATCH
		IFIW	SETMEU	;[C20] UNDEFINED
		IFIW	SETMEP	;[C20] COMP-3 PACKED
		IFIW	SETMEN	;[C20] NUMERIC
		IFIW	SETMEP	;[C20] NUMERIC & COMP-3
		IFIW	SETMEC	;[C20] COMPUTATIONAL
		IFIW	E$$MSC	;[C20] ERROR
		IFIW	E$$MSC	;[C20] ERROR
		IFIW	E$$MSC	;[C20] ERROR
		IFIW	SETMEA	;[C20] [450] ALPHANUMERIC
		IFIW	E$$MSC	;[C20] ERROR
		IFIW	E$$MSC	;[C20] ERROR
		IFIW	E$$MSC	;[C20] ERROR
		IFIW	E$$MSC	;[C20] ERROR
		IFIW	E$$MSC	;[C20] ERROR
		IFIW	E$$MSC	;[C20] ERROR
		IFIW	E$$MSC	;[C20] ERROR

SETMEU:	TXNN	T1,RM.SGN!RM.UNS	;[C20] SIGNED?
	JRST	SETMEA		;NO, ALPHANUMERIC BY DEFAULT
SETMEN:	TXNN	T1,RM.UNS	;[C20] SPECIFICALLY UNSIGNED?
	SKIPA	J,[IX.NSE]	;[C20] NO, NUMERIC SIGNED EBCDIC
	MOVEI	J,IX.NUE	;[C20] YES, NUMERIC UNSIGNED EBCDIC
	RETURN

SETMEC:	TXNN	T1,RM.UNS	;[C20] SPECIFICALLY UNSIGNED?
	SKIPA	J,[IX.CSE]	;[C20] NO, COMPUTATIONAL SIGNED EBCDIC
	MOVEI	J,IX.CUE	;[C20] YES, COMPUTATIONAL UNSIGNED EBCDIC
	RETURN

SETMEA:	MOVEI	J,IX.ALE	;[C20] ALPHANUMERIC
	RETURN

SETMEP:	TXNN	T1,RM.UNS	;[C20] SPECIFICALLY UNSIGNED?
	SKIPA	J,[IX.C3S]	;[C20] NO, COMP-3 SIGNED
	MOVEI	J,IX.C3U	;[C20] YES, COMP-3 UNSIGNED
	RETURN

SETMAA:	SKIPA	J,[IX.ALA]	;[C20] ALPHANUMERIC LOGICAL ASCII
SETMSA:	MOVEI	J,IX.ALS	;[C20] ALPHANUMERIC LOGICAL SIXBIT
	RETURN

SETKB:	TXNE	T1,RM.FPA	;[C20] FORTRAN FLOATING POINT ASCII?
	JRST	SETMAF		;YES
	TXNN	T1,RM.COM	;[C20] [330] SPECIFICALLY COMP?
	JRST	SETMBN		;[330] MODE BINARY NONCOMP
;	JRST 	SETMBC		;[330] MODE BINARY COMP
SETMBC:	TXNN	T1,RM.UNS	;[C20] [330] COMP. UNSIGNED?
	SKIPA	J,[IX.CSB]	;[C20] [330] NO- SIGNED.  DEFAULT
	MOVEI	J,IX.CUB	;[C20] [330] YES- UNSIGNED.
	RETURN			;[330]

SETMBN:	TXNN	T1,RM.UNS	;[C20] [330] NONCOMP. UNSIGNED?
	SKIPA	J,[IX.NSB]	;[C20] [330] NO- SIGNED. DEFAULT.
	MOVEI	J,IX.NUB	;[C20] [330] YES- UNSIGNED.
	RETURN			;[330]

SETMAF:	MOVEI	J,IX.FPA	;[C20] FORTRAN FLOATING POINT ASCII
	RETURN

END;
SUBTTL	PSORT. -- KEYEXT - Generate Key Extraction Code

BEGIN
  PROCEDURE	(PUSHJ	P,KEYEXT)
	;GENERATE CODE TO EXTRACT KEYS AT RUN TIME
	MOVE	U,EXTORG	;[C13] ADDRESS OF EXTRACT CODE
	SKIPN	R,FSTKEY	;MUST HAVE SEEN ONE
	JRST	E$$OKR		;ERROR
	MOVE	T1,[POINT 36,1(R)]
	MOVEM	T1,XTRWRD	;SETUP DEPOSIT BYTE PTR
  FOR EACH KEY DO
	BEGIN
		MOVE	T1,KY.MOD(R)	;[C20] GET THIS MODE
		IOR	T1,MODE		;[C20] ADD DEFAULTS
		PUSHJ	P,JMODES	;GET KEY MODE INDEX
		DMOVE	P1,KY.INI(R)	;GET FIRST BYTE AND LENGTH
		MOVE	T2,P1		;GET COPY
	  IF MODE IS NUMERIC OR COMP-3
		TXNE	T1,RM.NUM!RM.PAC	;[C20]
	  THEN CHECK FOR TOO MANY DIGITS
		CAIG	P2,^D18
		JRST	$F
E$$TMD:		$ERROR	(?,TMD,<Too many digits in key>)
	  FI;
	  IF MODE IS COMP OR COMP-3
		TXNN	T1,RM.COM!RM.PAC	;[C20] COMP IS SPECIAL
		JRST	$T
	  THEN	CALCULATE NO. OF WORDS FROM DIGITS GIVEN
		  IF COMP
			TXNN	T1,RM.COM	;[C20]
			JRST	$T
		  THEN
			HRRZ	T3,MODE		;[C20]
			ADD	T2,[EXP 6,5,4,1]-1(T3)	;[OK] ASSUME SINGLE PRECISION
			CAILE	P2,^D10		;IS IT
			ADD	T2,[EXP 6,5,4,1]-1(T3)	;[OK] NO
			JRST	$F
		  ELSE MUST BE COMP-3
			MOVEI	T1,2(P2)	;[OK] NO. OF DIGITS + SIGN + ROUNDING
			LSH	T1,-1		;CUT IN HALF
			ADD	T2,T1		;[C20] NEW LAST BYTE
		  FI;
		JRST	$F
	  ELSE
		ADD	T2,P2		;[C20] LAST BYTE
	  FI;
		CAMLE	T2,RECORD	;SEE IF IN RANGE
		JRST	E$$KOR		;NO
IFN FTKL10,<
		PUSHJ	P,@K.KLX(J)	;[C20]
>
IFE FTKL10,<
		MOVE	T1,CPU		;GET CPU TYPE (KL USES BIS)
		PUSHJ	P,@[IFIWS <@K.EXT(J),@K.EXT(J),@K.KLX(J)>](T1)	;[C20] AND PROCESS IT
>
		MOVE	T1,EXTORG	;[C13] GET END ADDRESS OF EXTRACT SPACE
		ADD	T1,EXTSZ	;[C13]  ..
		SUBI	T1,1		;[C20]  ..
		CAML	U,T1		;[C20] [C13] DID IT GET TOO BIG?
		JRST    [$ERROR	(?,KEB,<KEY extraction code too big>)]	;[C13]
		SKIPE	R,KY.NXT(R)	;NEXT KEY
		JRST	$B		;MORE TO DO
	END;
	$JRST$			;NO, ALL DONE
	XMOVEI	U,(U)		;[C20] MAKE SURE THE SECTION NUMBER IS THERE
	MOVEM	U,.CMPAR	;MARK END OF EXTRACT CODE
	SOS	XTRWRD		;BACKUP BYTE PTR
	HRRZS	XTRWRD		;NO. OF EXTRA WORDS EXTRACTED
  IF ANY EXTRACTED KEYS
	SKIPN	P1,XTRBYT
	RETURN
  THEN ADJUST OTHER KEYS FOR INSERTED EXTRACTED ONES
	MOVE	R,FSTKEY	;START AT FRONT
  FOR EACH KEY DO
	BEGIN
		MOVE	T1,KY.MOD(R)	;[C20] GET THIS MODE
		IOR	T1,MODE		;[C20] ADD DEFAULTS
		PUSHJ	P,JMODES	;GET KEY MODE INDEX
		PUSHJ	P,@K.ADJ(J)	;[OK] PROCESS IT
		  ADDM	P1,KY.INI(R)	;ADJUST  FIRST BYTE
		SKIPE	R,KY.NXT(R)	;GET NEXT
		JRST	$B
	END;
  FI;

;NOW ADJUST EXTRACTED KEYS TO COMPENSATE FOR MOVING ACTUAL RECORD

	MOVE	R,FSTKEY	;START AT FRONT
	MOVE	U,EXTORG	;[C13]
  FOR EACH KEY DO
	BEGIN
		MOVE	T1,KY.MOD(R)	;[C20] GET THIS MODE
		IOR	T1,MODE		;[C20] ADD DEFAULTS
		PUSHJ	P,JMODES	;GET KEY MODE INDEX
		XCT	K.ADX(J)	;[OK] PROCESS IT
		SKIPE	R,KY.NXT(R)	;GET NEXT
		JRST	$B
	END;
	RETURN
END;
SUBTTL	PSORT. -- Dispatch Tables for Key Extraction

DEFINE XX(AA,B)<
 IFIDN <B><N>,<IFIW CPOPJ>		;;[C20]
 IFIDN <B><A>,<IFIW AA'EXT>
 IFIDN <B><C>,<IFIW AA'EXT>		;;[C20]
>

K.EXT:	IXMODE

DEFINE XX(AA,B)<
 IFIDN <B><N>,<IFIW CPOPJ>		;;[C20]
 IFIDN <B><A>,<IFIW AA'KLX>		;;[C20]
 IFIDN <B><C>,<IFIW AA'EXT>		;;[C20]
>

K.KLX:	IXMODE

DEFINE XX(AA,B)<
 IFIDN <B><A>,<IFIW CPOPJ1>		;;[C20]
 IFIDN <B><N>,<IFIW CPOPJ>		;;[C20]
 IFIDN <B><C>,<IFIW CPOPJC>		;;[C20]
>

K.ADJ:	IXMODE

CPOPJC:	SKIPE	COLSW		;CONDITIONAL COLLATING SEQUENCE
	AOS	(P)
	POPJ	P,

DEFINE XX(AA,B)<
 IFIDN <B><A>,<PUSHJ	P,AA'ADX>
 IFIDN <B><N>,<NOOP>
 IFIDN <B><C>,<PUSHJ	P,AA'ADX>
>

K.ADX:	IXMODE
SUBTTL	PSORT. -- KEYGEN - Generate Key Comparison Code

BEGIN
  PROCEDURE	(PUSHJ	P,KEYGEN)
	;GENERATE CODE TO COMPARE KEYS AT RUN TIME
	MOVE	U,.CMPAR	;ADDRESS OF COMPARE/EXTRACT CODE
	MOVE	T1,[AOS	CMPCNT]	;YES, LOAD FIRST INST
	MOVEM	T1,(U)		;INTO GENERATED CODE
	ADDI	U,1		;AND PRESERVE AOS CMPCNT INSTRUCTION
	MOVE	R,FSTKEY	;MUST HAVE SEEN ONE
  FOR EACH KEY DO
	BEGIN
		MOVE	T1,KY.MOD(R)	;[C20] GET THIS MODE
		IOR	T1,MODE		;[C20] PLUS DEFAULTS
		PUSHJ	P,JMODES	;GET INDEX
		DMOVE	P1,KY.INI(R)	;GET ORIGIN & LENGTH
		PUSHJ	P,KEYADJ	;SEE IF NEXT KEY IS ADJACENT
		PUSHJ	P,@K.GEN(J)	;[OK] AND PROCESS IT
		MOVE	T1,EXTORG	;[C13] GET END ADDRESS OF EXTRACT SPACE
		ADD	T1,EXTSZ	;[C13]  ..
		SUBI	T1,1		;[C20]  ..
		CAML	U,T1		;[C20] [C13] DID IT GET TOO BIG?
		JRST    [$ERROR	(?,KCB,<KEY comparison code too big>)]	;[C13]
		SKIPE	R,KY.NXT(R)	;MORE TO DO
		JRST	$B		;YES
	END;
	$JRST$			;NO, ALL DONE
	RETURN
END;

DEFINE XX(AA,B)<
 IFIDN <B><A>,<IFIW CNVGEN>		;;[C20]
 IFIDN <B><C>,<IFIW AA'GEN>		;;[C20]
 IFIDN <B><N>,<IFIW AA'GEN>		;;[C20]
>

K.GEN:	IXMODE
BEGIN
  PROCEDURE	(PUSHJ	P,KEYADJ)
	;SEE IF NEXT KEY IS ADJACENT
	HRREI	T1,-IX.ALE(J)	;ALPHANUMERICS COME FIRST IN TABLE
	JUMPG	T1,$1		;ONLY CHECK FOR ALPHANUMERIC
	MOVE	T2,KY.ORD(R)	;[C20] GET ORDER
	SKIPE	T1,KY.NXT(R)	;ANY MORE TO DO?
	CAME	T2,KY.ORD(T1)	;[C20] YES, CHECK FOR SAME ORDER
  $1%	RETURN			;GIVE UP
	MOVE	T2,KY.INI(T1)	;[OK] GET ORIGIN OF THIS KEY
	SUB	T2,P2		;[C20] SUBTRACT LENGTH OF PREVIOUS
	CAME	T2,P1		;[C20] SAME ORIGIN?
	RETURN			;NO
	PUSH	P,J		;YES, NOW TEST MODE
	MOVE	T1,KY.MOD(T1)	;[C20]
	IOR	T1,MODE		;[C20]
	PUSHJ	P,JMODES	;SET MODE IN J
	MOVE	T1,J
	POP	P,J		;GET BACK PREVIOUS
	CAME	T1,J		;ALL THE SAME?
	RETURN			;NO
	MOVE	T1,KY.NXT(R)
	ADD	P2,KY.SIZ(T1)	;[OK] INCREMENT SIZE
	MOVEM	P2,KY.SIZ(R)	;REMEMBER THAT WE INCREMENTED
	MOVE	T2,KY.NXT(T1)	;[OK]
	MOVEM	T2,KY.NXT(R)	;REMOVE KEY
	JRST	$B		;TRY AGAIN
END;
SUBTTL	HPURE SEGMENT ERROR MESSAGES

E$$RSR:	$ERROR	(?,RSR,<Record size required>)
E$$KLR:	$ERROR	(?,KLR,<Key length required>)
E$$KOR:	$ERROR	(?,KOR,<Key outside of record>)
E$$KAI:	$ERROR	(?,KAI,<Key argument incorrect>)
E$$OKR:	$ERROR	(?,OKR,<At least one key is required>)
E$$MSC:	$ERROR	(?,MSC,<Mode switch conflict>)
E$$INS:	$ERROR	(?,INS,<Input file not specified>)
E$$ONS:	$ERROR	(?,ONS,<Output file not specified>)
E$$MOM:	$ERROR	(?,MOM,<Multiple output specs only on magtapes>)
E$$CWB:	$ERROR	(?,CWB,<Computational key must be on word boundary>)
E$$BNV:	$ERROR	(?,BNV,<BINARY mode does not support variable length records>)
E$$ATF:	$ERROR	(?,ATF,<At least two input files required for MERGE>)
E$$FSM:	$ERROR	(?,FSM,</FORMAT switch must be preceded by /KEY switch>)
E$$FSA:	$ERROR	(?,FSA,</FORMAT switch argument error>)
E$$OOF:	$ERROR	(?,OOF,<Only one /FORMAT switch per /KEY switch>)
E$$MCS:	$ERROR	(?,MCS,<Multiple collating sequences not allowed.>)
E$$CND:	$ERROR	(?,CND,<Collating sequence not defined>)
E$$CFS:	$ERROR	(?,CFS,<Collating sequence file specification in error.>)
E$$CLS:	$ERROR	(?,CLS,<Collating sequence literal specification in error.>)
E$$CFE:	$ERROR	(?,CFE,<Collating sequence input file error.>)
E$$ICS:	$ERROR	(?,ICS,<Illegal user supplied collating sequence>)
SUBTTL	FATAL ERROR CLEAN-UP ROUTINES

	SEGMENT	LPURE		;[C20]

BEGIN
  PROCEDURE	(,DIE)		;HERE ON FATAL ERROR

	$CRLF			;CLOSE OUT LINE

IFE FTOPS20,<
	PUSHJ	P,RELSPC	;[C13] RELEASE ANY RETAINED MEMORY
 IFE FTFORTRAN,<
  IFE FTVM,<
	PUSHJ	P,GETSCN	;[C20] [425] NEED HI-SEG
  >
	SKIPE	FORRET		;[C20] CALLED FROM FORTRAN?
	JRST	FORERR		;[C20] YES
	JRST	RSTART		;[C13] RESTART SORT
 >
 IFN FTFORTRAN,<
	MOVE	P,SAVEP	;RESTORE ORIGINAL PP
  IF USERS WANTS CONTROL
	SKIPG	T1,ERRADR	;[OK] GET RETURN ADDRESS
	JRST	$T
  THEN RETURN TO FORTRAN
	MOVEM	T1,(P)		;[C20] SET USERS RETURN ADDRESS
	POPJ	P,		;RETURN TO FORTRAN

  ELSE DO FORTRAN EXIT 
	MOVEI	L,1+[EXP 0,0]
	PUSHJ	P,EXIT.##
	HALT
  FI;
 >
>
IFN FTOPS20,<
	SKIPE	TAKFLG		;ARE WE TAKING FROM A FILE?
	CALL	TAKEX		;YES, CLOSE TAKE SOURCE AND LOG FILES
	CALL	ERSET$		;[335] CLEAN UP THE MESS
	SKIPE	FORRET		;[C20] CALLED FROM FORTRAN?
	JRST	FORERR		;YES
	JRST	RSTART		;[C13] RESTART SORT
>
END;
SUBTTL	RELES. -- Add Input Record to Tree

BEGIN
  PROCEDURE	(PUSHJ	P,RELES.)
	MOVEM	P,PSAV		;SO WE CAN RECOVER FROM EOF
  IF /MERGE NOT SEEN
	SKIPLE	MRGSW		;MERGE ONLY?
	JRST	$T		;YES
  THEN SETUP FOR SORT
	MOVEI	F,FCBORG	;[215] SET INPUT FILE'S FILE BLOCK
	MOVE	T1,F.INZR	;[C20] [215] GET AND REMOVE FIRST FILE'S X. BLOCK
	MOVE	T1,(T1)		;[C20]   ..
	EXCH	T1,F.INZR	;[215]   ..
	MOVEM	T1,FILXBK(F)	;[215] SAVE IN FILE'S FILE BLOCK
	PUSHJ	P,INIINP	;[215] INITIALIZE FIRST INPUT FILE
	SETOM	BUFALC		;[215] REMEMBER WE SET BUFFERS UP
  $1%	MOVEI	F,FCBORG	;INPUT CHAN#
	JSP	P4,GETREC	;GET RECORD INTO (R)
	  PUSHJ	P,DOEOF		;[C20] HANDLE E-O-F
	PUSHJ	P,RELES%	;GIVE IT TO TREE
	JRST	$1		;LOOP
  ELSE SETUP FOR MERGE
	PUSHJ	P,GETMRG		;SETUP AT MOST MAXTMP FILES
	  IF IT CAN BE DONE IN 1 PASS
		SKIPE	NUMINP		;ANY LEFT TO DO
		JRST	$T		;YES, NEED MULTIPLE PASSES
	  THEN SETUP TO MERGE TO OUTPUT FILE
		MOVEI	T1,EOFMRG
		MOVEM	T1,LOGEOF
		MOVEM	T1,PHYEOF
		PUSHJ	P,INIOUT	;OPEN OUTPUT FILE
		SKIPE	ACTTMP		;[327] ALL FILES EMPTY?!
		JSP	P4,PUTREC	;WE ALREADY HAVE FIRST RECORD IN R
		MOVEI	T1,RETRNM
		SKIPLE	WSCSW		;/CHECK REQUIRED?
		MOVEI	T1,RETWSC	;YES
		MOVEM	T1,$RETRN
		HRRZS	LSTREC		;USED IF /CHECK ON
		MOVE	P,PSAV
		RETURN

	  ELSE SETUP TO DO MULTIPLE MERGE CYCLES
		MOVEI	T1,EOFMNY
		MOVEM	T1,LOGEOF
		MOVEM	T1,PHYEOF
		MOVEI	F,FCBORG
		PUSHJ	P,FSTRUN	;OPEN TEMP FILE
		FASTSKIP		;WE ALREADY HAVE FIRST RECORD IN R
	  $2%	PUSHJ	P,RETRNM	;GET NEXT RECORD
		MOVEI	F,FCBORG
		JSP	P4,PTTREC	;OUTPUT IT
		JRST	$2		;LOOP UNTIL EOF
	  FI;
  FI;
END;
SUBTTL	RELES. -- Merge Initialization

;GETMRG IS CALLED TO INITIALIZE UP TO ACTTMP FILES FOR A MERGE. THIS INVOLVES
;OPENING UP THE FILE, READING ITS FIRST RECORD, AND PUTTING IT IN THE TREE.
;SPECIAL CASES OCCUR WHEN THE FIRST READ GIVES THE END-OF-FILE RETURN, MEANING
;THE FILE WAS NULL. IN THIS CASE, WE SIMPLY CLOSE THE FILE AND USE THE NEXT FILE
;IN ITS PLACE. HOWEVER, IF WE RUN OUT OF FILES, THEN WE FILL THE TREE WITH
;DUMMY RECORDS (RUN = -1), INDICATING END-OF-FILE. IF ALL FILES ARE NULL, THE
;ENTIRE TREE IS FILLED WITH THESE RECORDS, AND ACTTMP IS 0. THUS, SUBSEQUENT
;ROUTINES SHOULD CHECK ACTTMP FOR 0, OR FOR A RECORD WITH A -1 RUN # AT THE TOP
;OF THE TREE. THE SAVING OF BUFALC IS DONE SO THAT A NULL FILE'S BUFFER SPACE IS
;REUSED BY THE NEXT FILE.

BEGIN
  PROCEDURE	(PUSHJ	P,GETMRG)	;[327] INITIALIZE FIRST MERGE FILES
	MOVE	S,TREORG		;GET FIRST "WINNER"
	HRRZ	R,RN.REC(S)		;  AND RECORD
	MOVEI	F,TMPFCB		;[C20] [327] START WITH FIRST FILE BLOCK
	PUSH	P,ACTTMP		;[327] COUNTER FOR MOST WE CAN DO NOW
	PUSH	P,BUFALC		;[327] SAVE BUFFER RE-USE FLAG
  WHILE THERE ARE FILES WE CAN INITIALIZE
	BEGIN
		MOVE	T1,F.INZR		;[C20] [327] REMEMBER THIS FILE
		MOVE	T1,(T1)			;[C20]   ..
		EXCH	T1,F.INZR		;[327]   AND ADVANCE TO NEXT
		MOVEM	T1,FILXBK(F)		;[327] SAVE THIS FILE IN X. BLOCK
		SOS	NUMINP			;[327] ONE LESS FILE LEFT
		PUSHJ	P,INIINP		;[327] INITIALIZE THIS FILE
		MOVE	T1,(P)			;[327] RESTORE BUF RE-USE FLAG
		MOVEM	T1,BUFALC		;[327]   ..
	  IF THIS FILE ISN'T NULL
		JSP	P4,GETREC		;[327] GET FIRST REC FROM FILE
		  JRST	[PUSHJ	P,CHKMTA		;[327] MULTI-REEL TAPE?
			   JRST	.+1			;[327] YES--NOW HAVE REC
			 JRST	$T]			;[327] NO--NULL FILE
	  THEN COUNT FILE & PUT ITS RECORD IN THE TREE
		AOS	RQ			;WILL BE RUN #1
		HRLM	F,RN.FCB(S)		;[327] REMEMBER WHICH FILE REC CAME FROM
		PUSHJ	P,SETTRE		;[327] ADD RECORD TO TREE
		SOS	-1(P)			;[327] ONE LESS REC IN TREE
		HRRZ	R,RN.REC(S)		;[327] SET UP NEXT RECORD POINTER
		ADDI	F,FCBLEN		;[C20] [327] ADVANCE TO NEXT FILE BLOCK
		JRST	$F			;[327]
	  ELSE CLOSE FILE AND REUSE ITS BUFFER SPACE ON NEXT FILE
		PUSHJ	P,CLSMST		;[327] CLOSE THE FILE
		SETOM	BUFALC			;[327] REUSE BUFFER SPACE
	  FI;
		SKIPE	-1(P)			;[327] MORE TREE ROOM?
		SKIPN	F.INZR			;[327]   AND MORE FILES TO DO?
		JRST	$E			;[327] NO--DONE HERE
		JRST	$B			;[327] YES--LOOP
	END;
  WHILE THE TREE ISN'T FULL
	BEGIN
		SKIPN	-1(P)		;[327] MORE ROOM IN TREE?
		JRST	$E		;[327] NO--DONE
		HLLOS	RQ		;[327] YES--FILL WITH DUMMY RECORD
		PUSHJ	P,SETTRE	;[327]   ..
		SOS	ACTTMP		;[327] ONE LESS INPUT FILE
		SOS	-1(P)		;[327] ONE LESS TREE RECORD
		JRST	$B		;[327] LOOP
	END;
	SUB	P,[2,,2]		;[327] CLEAR OFF STACK TEMPS
	AOS	RC			;SET CURRENT RUN TO #1
	SETOM	BUFALC			;[327] SIGNAL TO REUSE BUFFERS
	RETURN				;[327] DONE
END;
SUBTTL	RELES. -- End of Input File -- SORT Case

BEGIN
  PROCEDURE (PUSHJ	P,MSTEOF)	;[215] MASTER INPUT FILE EOF

;[215] CALLED IN ERROR RETURN OF CALL TO GETREC WITH:
;[215] F/	POINTER TO FCB BLOCK FOR THIS FILE

	PUSHJ	P,CHKMTA		;[215] CHECK EOT IF MAGTAPE
	  RETURN			;[215] ANOTHER REEL--CONTINUE
	MOVE	T1,FILSIZ(F)		;[215] UPDATE INPUT RECORD COUNT
	ADDM	T1,INPREC		;[215]   ..
	PUSHJ	P,CLSMST		;CLOSE THE CURRENT MASTER FILE
  IF ANY MORE INPUT FILES
	SKIPN	F.INZR			;[215] LIST EMPTY?
	JRST	$T			;[215] YES--NO MORE INPUT FILES
  THEN INITIALIZE THE NEXT ONE
	MOVE	T1,F.INZR		;[C20] [215] GET POINTER TO NEXT
	MOVE	T1,(T1)			;[C20]   ..
	EXCH	T1,F.INZR		;[215] SWAP NEXT WITH THIS
	MOVEM	T1,FILXBK(F)		;[215] STORE IN X. BLOCK POINTER
	PUSHJ	P,INIINP		;[215] OPEN FILE AND SET MODES
	JSP	P4,GETREC		;[215] FINISH PENDING RECORD REQUEST
	  JRST	MSTEOF			;[215] [107] IGNORE NULL FILES
	JRST	$F			;[215]
  ELSE UNBIND STACK TO START MERGE
	MOVE	P,PSAV			;[215] UNBIND STACK
  FI;
	RETURN				;[215] ALL DONE
END;
SUBTTL	RELES. -- End of Input File -- MERGE Case

BEGIN
  PROCEDURE	(PUSHJ	P,EOFMNY)
	PUSHJ	P,CHKMTA		;[215] THIS MIGHT BE MULTI-REEL FILE
	  RETURN			;[215] YES--CONTINUE AS IF NOTHING HAPPENED 
	PUSHJ	P,CLSMST		;[327] CLOSE THE FILE (EOT PROCESSING, ETC.)
	MOVE	T1,FILSIZ(F)
	ADDM	T1,INPREC		;KEEP COUNT OF INPUT RECORDS
  IF NOT LAST FILE
	SOSG	ACTTMP			;ALL DONE?
	JRST	$T
  THEN TERMINATE THIS RUN AND CONTINUE
	HLLOS	RQ			;SET TERMINATING RUN#
	RETURN
  ELSE TERMINATE CYCLE AND START AGAIN
	  IF NO MORE TO DO
		SKIPE	NUMINP		;ANY MORE
		JRST	$T		;TOO BAD
	  THEN JUST RETURN
		MOVE	P,PSAV
		RETURN
	  ELSE TRY AGAIN
		MOVEI	F,FCBORG	;SET ON OUTPUT FILE
		PUSHJ	P,CLSRUN	;CLOSE THIS, OPEN NEXT RUN
		PUSHJ	P,SETMRG	;SETUP MERGE NO. AGAIN
		PUSHJ	P,INITRE	;SETUP NUL TREE AGAIN
		PUSHJ	P,GETMRG	;SETUP TEMP FILES AGAIN
		SKIPN	ACTTMP		;[327] ALL FILES NULL?
		JRST	[MOVE	P,PSAV		;[327] YES--NOTHING TO DO
			 POPJ	P,]		;[327]   SO JUST RETURN
		MOVEI	F,FCBORG
		JSP	P4,PTTREC	;WE ALREADY HAVE FIRST RECORD IN R
		POP	P,(P)		;GET TOP CALL OFF STACK
		PJRST	RETRNM		;CONTINUE
	  FI;
  FI;
END;
SUBTTL	RELES. -- End of Input File -- Check End Lables

BEGIN
  PROCEDURE (PUSHJ	P,CHKMTA)	;[215] SEE IF EOT OF MULTI-REEL FILE OR EOF
	PUSH	P,P1			;[215] SAVE TEMP FOR X. BLOCK
  IF WE HAVE A MAGTAPE
	PUSHJ	P,ISITMT		;IS THIS A MAGTAPE?
	JRST	$T			;NO, SKIP LABEL STUFF
  THEN CHECK END LABEL (IF ANY) AND SEE IF MULTI-REEL
	MOVE	P1,FILXBK(F)		;GET ADDR OF X. BLOCK
IFE FTFORTRAN,<
  $1%	PUSHJ	P,CHKEND		;[215] PROCESS LABEL
>
	  IF TAPE NEEDS UNLOADING
		MOVE	T1,FILFLG(F)		;[215] SEE IF USER ASKED FOR IT
		TXNE	T1,FI.UNL!FI.EOT	;[215]   OR ANOTHER REEL TO FILE
	  THEN UNLOAD TAPE
		PUSHJ	P,UNLDF			;[215] YES--UNLOAD TAPE
	  FI;
IFE FTFORTRAN,<
	  IF FILE IS MULTI-REEL
		MOVE	T1,FILFLG(F)		;[215] GET FLAGS BACK
		TXNN	T1,FI.EOT		;[215] EOT RATHER THAN EOF?
		JRST	$T			;[215] NO--WE'RE DONE
	  THEN ASK USER OR OPERATOR TO MOUNT NEXT REEL
	IFN FTOPS20,<
		SKIPE	MOUNTR			;[C12] MOUNTR AROUND?
		PUSHJ	P,[	PUSHJ P,GMTVOL	;[C12] YES, LET MOUNT DO IT
				JRST	$2]	;[C12]  ..
	>
		CLEARO				;[215] CLEAR ^O
E$$LRI:		$ERROR	($,LRI,<Load reel >,+)	;[215] ASK FOR TAPE
		MOVE	T1,X.REEL(P1)		;[OK] [215] PRINT REEL # WE WANT
		ADDI	T1,1			;[215]   ..
		$MORE	(DECIMAL,T1)		;[215]   ..
		$MORE	(TEXT,< of input file >);[215] NOW PRINT WHICH FILE
  IFE FTOPS20,<
		MOVEI	T1,X.RIB(P1)		;[OK]   ..
  >
  IFN FTOPS20,<
		HLRZ	T1,FILPGN(F)		;GET JFN
  >
		$MORE	(FILESPEC,T1)		;[215] TYPE FILESPEC
		$MORE	(TEXT,<, type CONTINUE when ready.>) ;[215]
		$CRLF				;[215] ALL DONE
		MONRET				;[215] EXIT TO ALLOW USER TO MOUNT TAPE
  IFN FTOPS20,<
	$2%	PUSHJ	P,STRTIO		;[C12] START I/O
  >
		MOVX	T1,FI.EOT		;CLEAR EOT FLAG
		ANDCAM	T1,FILFLG(F)		; ..
		PUSHJ	P,CHKLBL		;[215] CHECK NEW REEL
		JSP	P4,GETREC		;[C07] [215] FINISH PENDING GETREC
		  JRST	$1			;[215] WHAT?? ANOTHER LABEL SO QUICK??
		JRST	$F			;[215] WE HAVE NEW REEL SET UP NOW
	  ELSE WE'RE REALLY DONE WITH FILE, SO GIVE EOF RETURN
>
		AOS	-1(P)			;[215] EOF IS SKIP RETURN
IFE FTFORTRAN,<
	  FI;
>
	JRST	$F			;[215] NOW DONE CHECKING EOT
  ELSE NOT A TAPE, JUST GIVE EOF RETURN
	AOS	-1(P)			;[215] EOF IS SKIP RETURN
  FI;
	POP	P,P1			;[215] RESTORE TEMP
	RETURN				;[215] DONE
END;
SUBTTL	MERGE.

BEGIN
  PROCEDURE	(PUSHJ	P,MERGE.)
	MOVEM	P,PSAV			;SAVE P INCASE NEEDED
  IF NOT 1 PASS /MERGE
	SKIPLE	MRGSW
	SKIPE	NUMTMP
  THEN DO MERGE
	PJRST	MERGE%
  ELSE JUST RETURN
	RETURN
  FI;
END;
SUBTTL	RETRN. -- End of Output File

BEGIN
  PROCEDURE	(PUSHJ	P,EOFOUT)

;THIS ROUTINE IS CALLED FROM VARIOUS PLACES WHEN WE ARE FINALLY
;DONE WITH THE OUTPUT FILE.  ANY FINAL MAGTAPE PROCESSING IS DONE
;AND WE RETURN TO THE TOP LEVEL OF SORT.

	MOVEI	F,FCBORG
	PUSHJ	P,ISITMT		;[C08] IS IT A MAGTAPE?
	  SKIPA				;[C08] NO
	PUSHJ	P,WRTEND		;[C08] YES, WRITE EOF LABEL

	PUSHJ	P,CLSMST		;CLOSE MASTER FILE
	MOVE	T1,FILSIZ(F)		;[215] REMEMBER HOW MUCH WE
	MOVEM	T1,OUTREC		;[215]   WROTE FOR ENDS.

	MOVE	T1,FILFLG(F)		;[C08] CHECK FOR UNLOAD IF MAGTAPE
	TXNE	T1,FI.UNL		;[C08]   ..
	PUSHJ	P,ISITMT		;[C08]   ..
	  SKIPA				;[C08] NO
	PUSHJ	P,UNLDF			;[C08] YES--UNLOAD TAPE

	MOVE	P,PSAV			;UNBIND STACK
	RETURN
END;
SUBTTL	RETRN. -- MSTEOT - EOT Detected on Output Tape

IFE FTFORTRAN,<
BEGIN
  PROCEDURE	(PUSHJ	P,MSTEOT)	;[215] CONTINUE MULTI-REEL FILE

;THIS ROUTINE IS CALLED BY PUTREC WHEN AN END-OF-TAPE ERROR HAS BEEN
;DETECTED BY PUTBUF. SINCE THERE IS A PENDING RETURN FROM PUTREC IN
;P4, WE MUST SAVE IT. END-OF-TAPE PROCESSING FOLLOWS, BY WRITING
;LABELS AND UNLOADING THE OLD TAPE. IF THE NEXT DRIVE TO BE USED IS
;DIFFERENT FROM THE ONE WE JUST FINISHED WITH, A BOILED-DOWN COPY OF
;THE INIOUT ROUTINE IS USED TO SET UP ALL PROPER TAPE PARAMETERS.
;THEN, USER IS ASKED TO MOUNT THE NEXT TAPE. FINALLY, A HEADER LABEL
;IS WRITTEN.

	PUSH	P,P1			;[215] SAVE TEMP FOR X. BLOCK
	PUSH	P,P4			;[215] SAVE ORIGINAL CALLER
	MOVE	P1,FILXBK(F)		;[215] SET UP X. BLOCK
	PUSHJ	P,WRTEOT		;[215] WRITE END LABEL
	PUSHJ	P,UNLDF			;[215] DONE WITH THIS TAPE
	MOVX	T1,FI.EOT		;[414] GET EOT BIT
	ANDCAM	T1,FILFLG(F)		;[414] AND CLEAR IT
  IFE FTOPS20,<
  IF NEXT DRIVE IS DIFFERENT THAN CURRENT
	MOVE	T1,F.OUZR		;[C20] GET NEXT DEVICE
	SKIPN	T1,(T1)			;[C20]   ..
	MOVE	T1,X.NXT(P1)		;[OK] [215] LIST ENDED--START OVER
	MOVEM	T1,F.OUZR		;[215] REMEMBER FOR NEXT TIME
	MOVE	T1,OM.DEV(T1)		;[OK] [215] GET DEVICE
	CAMN	T1,X.OPN+.OPDEV(P1)	;[OK] [215] SAME AS LAST ONE?
	JRST	$F			;[215] YES--WE'RE ALL SET
  THEN WE MUST INITIALIZE IT TO LOOK LIKE LAST DRIVE
	MOVEM	T1,X.OPN+.OPDEV(P1)	;[OK] [215] STORE DEVICE FOR OPEN
	MOVX	T1,BF.VBR		;[C19] SET VIRGIN BUFFER RING HEADER
	IORM	T1,FILHDR(F)		;[C19]   ..
	HLLZS	FILPTR(F)		;[C19] CLEAR RH OF BYTE POINTER
	SETZM	FILCNT(F)		;[C19] CLEAR FILE COUNT
	HRL	T1,FILCHN(F)		;[C19] BUILD FILOP. BLOCK, GET CHANNEL
	HRRI	T1,.FORED		;[C19] GET READ FUNCTION
	MOVEM	T1,FLPARG+.FOFNC	;[C19] STORE THEM
	HRLI	T1,X.OPN(P1)		;[OK] [C19] TRANSFER OPEN BLOCK
	HRRI	T1,FLPARG+.FOIOS	;[C19]   ..
	BLT	T1,FLPARG+.FOIOS+2	;[C19]   ..
	SETZM	FLPARG+.FONBF		;[C19] NO BUFFERS
	SETZM	FLPARG+.FOLEB		;[C19] NO LOOKUP BLOCK
	HLLZ	T2,FILPTR(F)		;[C19] SAVE BYTE SIZE
	MOVE	T1,[.FOLEB+1,,FLPARG]	;[C19] DO READ FILOP.
	FILOP.	T1,			;[C19]   ..
	  JRST	ERRFUF			;[C19] FAILED
	HLLM	T2,FILPTR(F)		;[C19] RESTORE BYTE SIZE
	PUSHJ	P,STAPF			;[215] SET UP DENSITY, ETC.
  FI;
  >;END IFE FTOPS20
  IFN FTOPS20,<
	SKIPE	MOUNTR			;[C12] MOUNTR AROUND?
	PUSHJ	P,[	PUSHJ P,GMTVOL	;[C12] YES, LET MOUNTR DO IT
			JRST	$1]	;[C12]  ..
  >
  	CLEARO				;[215] CLEAR ANY ^O
E$$LRO:	$ERROR	($,LRO,<Load reel >)	;[215] ASK USER FOR NEXT TAPE
	MOVE	T1,X.REEL(P1)		;[OK] [215] SAY WHICH REEL
	ADDI	T1,1			;[215]   ..
	$MORE	(DECIMAL,T1)		;[215]   ..
	$MORE	(TEXT,< of output file >)
  IFE FTOPS20,<
	MOVEI	T1,X.RIB(P1)		;[OK] LOAD ADDR OF RIB
  >
  IFN FTOPS20,<
	HLRZ	T1,FILPGN(F)		;LOAD JFN
  >
	$MORE	(FILESPEC,T1)		;[215] SAY WHICH FILE
	$MORE	(TEXT,<, type CONTINUE when ready.>)
	MONRET				;[215] WAIT FOR REEL
  $1%	PUSHJ	P,WRTLBL		;[C12] [215] WRITE HEADER ON NEW REEL
	POP	P,P4			;[215] RESTORE TEMPS
	POP	P,P1			;[215]   ..
	RETURN				;[215] DONE
END;
>
SUBTTL	RETRN. -- RETRNM - Return Record From First-pass Merge Files

BEGIN
  PROCEDURE	(PUSHJ	P,RETRNM)
	HLRZ	F,RN.FCB(S)	;GET WHICH FILE
	JSP	P4,GETREC	;GET A RECORD
	  PUSHJ	P,DOEOF		;[C20] E-O-F RETURN
	PUSHJ	P,SETTRE	;SET NEW RECORD IN TREE
	RETURN
END;

BEGIN
  PROCEDURE	(PUSHJ	P,RETWSC)
	EXCH	R,LSTREC	;SAVE RECORD JUST OUTPUT
	HRRM	R,RN.REC(S)	;GET SPARE RECORD AREA
	HLRZ	F,RN.FCB(S)	;GET WHICH FILE
	JSP	P4,GETREC	;GET A RECORD
	  JRST	[PUSHJ	P,DOEOF		;[C20] E-O-F RETURN
		JRST	$1]		;DON'T TEST SINCE RECORD NOT READ
	HRRZ	J,LSTREC	;GET PREVIOUS FROM SAME FILE
	COMPARE	(R,J)
	  JRST	$1		;KEY(R) = KEY(J)	;OK
	  JRST	$1		;KEY(R) > KEY(J)	;OK
				;KEY(R) > KEY(J)	;OUT OF SEQUENCE
E$$MRS:	$ERROR	(%,MRS,<MERGE record >,+)
	$MORE	(DECIMAL,FILSIZ(F))
	$MORE	(TEXT,< not in sequence for >)
	HLRZ	T2,RN.FCB(S)	;GET POINTER TO FILE BLOCK
	HRRZ	T2,FILNAM(T2)	;[OK] ...
	ADDI	T2,X.RIB	;COMPENSATE FOR FOLLOWING MACRO
	$MORE	(FILESPEC,T2)
	$CRLF

$1%	PUSHJ	P,SETTRE	;SET NEW RECORD IN TREE
	RETURN
END;

BEGIN
  PROCEDURE	(PUSHJ	P,EOFMRG)
	PUSHJ	P,CHKMTA		;[327] MIGHT HAVE A MULTI-REEL TAPE
	  RETURN			;[327] YES--NOW HAVE ANOTHER RECORD
	PUSHJ	P,CLSMST		;[327] NO--JUST CLOSE THE FILE
	MOVE	T1,FILSIZ(F)
	ADDM	T1,INPREC		;KEEP COUNT OF INPUT RECORDS
	SOSG	ACTTMP			;ALL DONE?
	JRST	EOFOUT			;YES
	HLLOS	RQ			;SET TERMINATING RUN#
	RETURN
END;
SUBTTL	TAPE LABEL ROUTINES -- POSITF - Position Magtape at File

BEGIN
  PROCEDURE	(PUSHJ	P,POSITF)	;[C11]
	PUSH	P,P1			;[C11] SAVE A TEMP
	MOVE	T1,FILFLG(F)		;[C11] NEED TO REWIND FIRST?
	TXNE	T1,FI.REW		;[C11]  ..
	PUSHJ	P,RWNDF			;[C11] YES, DO IT
	MOVE	T1,FILXBK(F)		;[C11] WAS POSITIONING REQUESTED?
	SKIPG	P1,X.POSI(T1)		;[OK] [C11]  ..
	JRST	$4			;[C11] NO
	TXZN	P1,1B1			;[C11] YES, A BACKSPACE?
	JRST	$2			;[C11] NO
IFN FTOPS20,<
	MOVX	T1,FI.ATO		;[C12] LABELED MOUNTR TAPE?
	TDNN	T1,FILFLG(F)		;[C12]  ..
>
	PUSHJ	P,BKSPR			;[C11] NO, BACKSPACE OVER POSSIBLE EOF FIRST
  $1%	PUSHJ	P,BKSPF			;[C11] BACKSPACE A FILE
	SOJG	P1,$1			;[C11] LOOP FOR COUNT
IFN FTOPS20,<
	MOVX	T1,FI.ATO		;[C12] LABELED MOUNTR TAPE?
	TDNE	T1,FILFLG(F)		;[C12]  ..
	JRST	$4			;[C12] YES, DONE
>
	PUSHJ	P,ISATBT		;[C11] NO, AT BOT?
	  PUSHJ	P,SKIPF			;[C11] NO, SKIP OVER EOF
	JRST	$4			;[C11] DONE 

  $2%					;[C12] A SKIP
IFN FTOPS20,<
	MOVX	T1,FI.ATO		;[C12] LABELED MOUNTR TAPE?
	TDNE	T1,FILFLG(F)		;[C12]  ..
	JRST	$3			;[C12] YES
>
	PUSHJ	P,BKSPR			;[C11] NO, BACKSPACE OVER POSSIBLE EOF FIRST
	PUSHJ	P,ISATBT		;[C11] AT BOT?
	  ADDI	P1,1			;[C11] NO, SKIP OVER EOF
  $3%	PUSHJ	P,SKIPF			;[C11] SKIP A FILE
	SOJG	P1,$3			;[C11] LOOP FOR COUNT
  $4%	POP	P,P1			;[C11] RESTORE TEMP
	RETURN				;[C11] ALL DONE
END;
SUBTTL	TAPE LABEL ROUTINES -- CHKLBL - Check Header Labels

IFE FTFORTRAN,<
BEGIN
  PROCEDURE	(PUSHJ	P,CHKLBL)	;[215] CHECK TAPE HEADER LABELS
	PUSH	P,P1			;[215] SAVE A TEMP
	MOVE	P1,FILXBK(F)		;[215] NEED X. BLOCK A LOT HERE
  IF TAPE LABEL HANDLER IS NOT CHECKING THIS TAPE
	MOVE	T1,FILFLG(F)		;[C12] [215] FETCH TAPE'S FLAG BITS
	TXNE	T1,FI.ATO		;[C12] [215] TAPE LABELER DOING THE WORK?
	JRST	$F			;[C12] [215] YES--DONE
  THEN WE MUST DO IT OURSELVES
	  CASE LABEL TYPE OF (STANDARD,OMITTED,NON-STANDARD,DEC,ANSI)
		MOVE	T1,X.LABL(P1)		;[OK] [215] FETCH LABEL TYPE
		JRST	@[IFIWS <$1,$C,$2,$1,$3,$4>]-1(T1) ;[C20] [215] CHECK PROPER LABELS

	  $1%	;[215] STANDARD OR DEC LABELS (SYNONYMOUS)
		SKIPN	X.RIB+.RBNAM(P1)	;[OK] [215] DID USER GIVE A NAME?
		JRST	E$$NRL			;TELL USER
		JSP	T4,GETBUF		;READ THE LABEL
		  JRST	E$$RIE			;SHOULD NOT HAPPEN
		SETZM	FILCNT(F)		;SO WE IGNORE BLOCK WHEN DONE
		  CASE I/O MODE OF (SIXBIT,ASCII,EBCDIC,BINARY)
			HRRZ	T1,MODE		;[215] GET MODE OF FILE
			PUSHJ	P,@[IFIWS <CHKSIX,CHKASC,E$$ELN,CHKBIN>]-1(T1)	;[C20]
		  ESAC;
		JRST	$C			;[215] DONE WITH DEC LABELS

	  $2%	;[215] NON-STANDARD LABELS
E$$NSL:		$ERROR	(%,NSL,<Non-standard label not checked.>)
		PUSHJ	P,SKIPR			;[215] SKIP LABEL
		JRST	$C			;[215] DONE WITH NON LABELS

	  $3%	;[215] ANSI LABELS
E$$ANL:		$ERROR	(%,ANL,<ANSI label not checked.>)
		PUSHJ	P,SKIPF			;[215] SKIP LABEL
		JRST	$C			;[215] DONE WITH ANSI LABELS

	  $4%	;[215] IBM LABELS
E$$IBL:		$ERROR	(%,IBL,<IBM label not checked.>)
		PUSHJ	P,SKIPF			;[215] SKIP LABEL
;		JRST	$C			;[215] FALL THROUGH

	  ESAC;
  FI;
	POP	P,P1			;[215] RESTORE TEMP
	RETURN				;[215] ALL DONE
END;
;STILL IN IFE FTFORTRAN
BEGIN
  PROCEDURE	(PUSHJ	P,CHKSIX)	;CHECK SIXBIT LABEL
	HRRZ	T4,FILPTR(F)		;[C20] GET BUFFER ADDRESS
	MOVE	T1,0(T4)		;[OK] GET HEADER BYTES
	LSHC	T1,-2*6			;BYTES 1-4
	CAME	T1,['HDR1']		;IS IT CORRECT?
	JRST	E$$LNC
	LSHC	T1,2*6			;RESTORE BYTES 5-6
	MOVE	T2,1(T4)		;[OK] GET BYTES 7-12
	LSHC	T1,4*6			;LEFT JUSTIFY
	LSH	T2,-6			;SHIFT INTO BYTES 1-2
	HLR	T2,2(T4)		;[OK] GET LAST CHARACTER
	LSH	T2,6			;BYTES 11, 12, 13 IN LHS
	CAME	T1,X.RIB+.RBNAM(P1)	;[OK] [215] CHECK NAME
	JRST	E$$LNC
	HLLZS	X.RIB+.RBEXT(P1)	;[OK] [215] CLEAR RHS JUNK
	HLLZ	T2,T2			;...
	CAME	T2,X.RIB+.RBEXT(P1)	;[OK] [215] MATCH
	JRST	E$$LNC
	HRLZ	T3,4(T4)		;[OK] GET REEL NUMBER
	HLR	T3,5(T4)		;[OK] ...
	ANDCMI	T3,7777			;IN BYTES 0-4
	SETZ	T1,			;WHERE TO BUILD NUMBER
  $1%	SETZ	T2,
	LSHC	T2,6			;MOVE IN NEXT DIGIT
	IMULI	T1,^D10			;MAKE SPACE FOR IT
	SUBI	T2,'0'			;[C20] ADD IN
	ADD	T1,T2			;[C20]   ..
	JUMPN	T3,$1			;MORE TO DO
	SKIPN	X.REEL(P1)		;[OK] [215] [116] REEL #0 SAME AS #1
	JUMPE	T1,$2			;[116] FOR FIRST MULTI-FILE REEL
	SUBI	T1,1			;[C20] [C07] [116] PUT REEL NO. -1 IN T1
	CAME	T1,X.REEL(P1)		;[OK] [C07] [215] [116] ONE WE EXPECTED?
	JRST	ERRROS			;NO
  $2%	AOS	X.REEL(P1)		;[OK] [215] [116] INCREMENT PREVIOUS REEL ID
	RETURN
END;
;STILL IN IFE FTFORTRAN
BEGIN
  PROCEDURE	(PUSHJ	P,CHKBIN)
	HRRZ	T4,FILPTR(F)		;[C20] GET BUFFER ADDRESS
	MOVE	T1,0(T4)		;[OK] GET HEADER BYTES
	LSH	T1,-8			;TRY ASCII BYTES
	CAMN	T1,["HDR1"]		;IS IT ASCII?
	JRST	CHKASC			;YES
	LSH	T1,-4			;NO, TRY SIXBIT BYTES
	CAMN	T1,['HDR1']		;IS IT SIXBIT?
	JRST	CHKSIX			;YES
	JRST	E$$LNC			;ERROR
END;
;STILL IN IFE FTFORTRAN
BEGIN
  PROCEDURE	(PUSHJ	P,CHKASC)	;CHECK ASCII LABEL
	MOVE	T4,FILPTR(F)		;[C20] GET BYTE PTR
	HRRZ	T1,T4			;[C20] GET 1ST WORD
	MOVE	T1,0(T1)		;[C20]   ..
	LSHC	T1,-8			;RIGHT JUST
	CAME	T1,["HDR1"]		;
	JRST	E$$LNC			;ERROR
	SETZ	T1,			;BUILD NAME HERE
	LSH	T2,-4*7-1		;RIGHT JUSTIFY
	MOVEI	T3,6			;SIX CHARS
	AOJA	T4,$2			;INCREMENT BYTE PTR
$1%	ILDB	T2,T4			;GET NEXT BYTE
$2%	LSH	T1,6			;MAKE SPACE
	SUBI	T2," "			;[C20] ADD IN (SIXBITIZED)
	ADD	T1,T2			;[C20]   ..
	SOJG	T3,$1			;LOOP
	CAME	T1,X.RIB+.RBNAM(P1)	;[OK] [215] MATCH
	JRST	E$$LNC
	MOVEI	T3,3			;GET EXT
$3%	ILDB	T2,T4
	LSH	T1,6
	SUBI	T2," "			;[C20] SAME AS ABOVE
	ADD	T1,T2			;[C20]   ..
	SOJG	T3,$3
	HRLZ	T1,T1			;PUT IN LHS
	HLLZS	X.RIB+.RBEXT(P1)	;[OK] [215] CLEAR POSSIBLE JUNK
	CAME	T1,X.RIB+.RBEXT(P1)	;[OK] [215]
	JRST	E$$LNC
	HRRZ	T1,T4			;[C20] PICKUP REEL ID
	DMOVE	T2,3(T1)		;[C20]   ..
	LSH	T2,-1			;DROP BIT 35
	LSHC	T2,2*7+1		;LEFT JUSTIF
	ANDCMI	T2,377			;CLEAR JUNK
	SETZ	T3,			;WHERE TO BUILD NUMBER
  $4%	SETZ	T1,
	LSHC	T1,7			;MOVE IN NEXT DIGIT
	IMULI	T3,^D10			;MAKE SPACE FOR IT
	SUBI	T1,"0"			;[C20] ADD IN
	ADD	T3,T1			;[C20]   ..
	JUMPN	T2,$4			;MORE TO DO
	SKIPN	X.REEL(P1)		;[OK] [215] [116] REEL #0 SAME AS #1
	JUMPE	T3,$5			;[116] FOR FIRST MULTI-FILE REEL
	SOS	T1,T3			;[C20] [C07] [116] PUT REEL NO. -1 IN T1
	CAME	T1,X.REEL(P1)		;[OK] [215] [116] ONE WE EXPECTED?
	JRST	ERRROS			;NO
  $5%	AOS	X.REEL(P1)		;[OK] [215] [116] INCREMENT PREVIOUS REEL ID
	RETURN
END;
SUBTTL	TAPE LABEL ROUTINES -- WRTLBL - Write Header Labels

;STILL IN IFE FTFORTRAN
BEGIN
  PROCEDURE	(PUSHJ	P,WRTLBL)		;HERE TO WRITE MAGTAPE LABEL
	PUSH	P,P1			;[215] SAVE TEMP FOR X. BLOCK
	MOVE	P1,FILXBK(F)		;[215] SET UP X. BLOCK
  IF TAPE LABEL HANDLER IS NOT CHECKING THIS TAPE
	MOVE	T1,FILFLG(F)		;[C12] [215] GET FILE'S FLAGS
	TXNE	T1,FI.ATO		;[C12] [215] LABELER DOING THE WORK?
	JRST	$F			;[C12] [215] YES--NO PROBLEM
  THEN WE MUST DO IT OURSELVES
	AOS	X.REEL(P1)		;[OK] [215] WE'RE NOW ON NEXT REEL
	  CASE LABEL TYPE OF (STANDARD,OMITTED,NON-STANDARD,DEC,IBM)
		MOVE	T1,X.LABL(P1)		;[OK] [215] GET LABEL TYPE
		JRST	@[IFIWS <$1,$C,$2,$1,$3,$4>]-1(T1)	;[C20]

	  $1%	;[215] STANDARD OR DEC LABELS (SYNONYMOUS)
  IFE FTOPS20,<
		SKIPG	FILCNT(F)		;[C19] VIRGIN RING?
		JSP	T4,PUTBUF		;YES, DUMMY OUTPUT NEEDED
  >;END IFE FTOPS20
		  CASE I/O MODE OF (SIXBIT,ASCII,EBCDIC,BINARY)
			HRRZ	T2,MODE		;[215] GET MODE OF TAPE
			MOVE	T1,[EXP 'HDR1',"HDR1 ",0,'HDR1']-1(T2) ;[OK] [215] SET UP LABEL
			PUSHJ	P,@[IFIWS <WRTSIX,WRTASC,WRTEBC,WRTBIN>]-1(T2)	;[C20]
			JSP	T4,PUTBUF	;[C08] FORCE BUFFER OUT
		  ESAC;
		JRST	$C			;[215] DONE WITH DEC LABELS

	  $2%	;[215] NON-STANDARD LABELS
E$$NLN:		$ERROR	(%,NLN,<Non-standard label not written.>)
		JRST	$C			;[215] CONTINUE

	  $3%	;[215] ANSI LABELS
E$$ALN:		$ERROR	(%,ALN,<ANSI label not written.>)
		JRST	$C			;[215] CONTINUE

	  $4%	;[215] IBM LABELS
E$$ILN:		$ERROR	(%,ILN,<IBM label not written.>)
;		JRST	$C			;[215] FALL THROUGH
	  ESAC;
  FI;
	POP	P,P1			;[215] RESTORE TEMP
	RETURN				;[215] ALL DONE
END;
;STILL IN IFE FTFORTRAN
BEGIN
  PROCEDURE	(PUSHJ	P,WRTSIX)	;WRITE SIXBIT LABEL
	HRRZ	T4,FILPTR(F)		;[C20] GET BUFFER ADDRESS
	DMOVE	T2,X.RIB+.RBNAM(P1)	;[OK] [215] GET NAME, EXT
	JUMPE	T2,E$$NRL
	HRRI	T3,'   '		;FILL WITH SPACES
	LSHC	T1,2*6
	MOVEM	T1,0(T4)		;[OK] FIRST WORD
	LSH	T2,-2*6
	LSHC	T2,2*6
	MOVEM	T2,1(T4)		;[OK] SECOND WORD
	HRRI	T3,'   '
	MOVEM	T3,2(T4)		;[OK] THIRD WORD
	HRLZM	T3,3(T4)		;[OK] FOURTH WORD
	MOVE	T1,X.REEL(P1)		;[OK] [215] GET REEL NUMBER
	SETZ	T3,			;WHERE TO BUILD ID
  $1%	IDIVI	T1,^D10			;GET LEAST DIGIT
	ADDI	T2,'0'			;SIXBITIZE
	LSHC	T2,-6			;SHIFT IN
	TRNN	T3,770000		;GOT 4 CHARS YET?
	JRST	$1			;NO
	HLRZM	T3,4(T4)		;[OK]
	HRLI	T3,'00 '
	ADDI	T3,' 00'	
	MOVSM	T3,5(T4)		;[OK] STORE IT AS X0000
IFE FTOPS20,<
	DATE	T1,			;GET CURRENT DATE
	IDIVI	T1,^D31
	ADDI	T2,1
	IDIVI	T2,^D10			;GET DAYS
	LSH	T2,6
	ADDI	T3,'00'			;[C20] SIXBITIZE
	ADD	T2,T3			;[C20]   ..
	LSH	T2,6
	HRRZM	T2,7(T4)		;[OK] STORE DAYS
	IDIVI	T1,^D12			;GET MONTH
	ADDI	T2,1
	IDIVI	T2,^D10
	LSH	T2,6
	ADDI	T2,'00'			;[C20] PUT MONTH IN T3
	ADD	T3,T2			;[C20]   ..
	ADDI	T1,^D64			;ADD IN YEAR BASE
	IDIVI	T1,^D10
	LSH	T2,2*6
	ADDI	T3,'0  '		;[C20] YMM
	ADD	T2,T3			;[C20]   ..
	HRLM	T2,7(T4)		;[OK]
	ADDI	T1,'0'
	MOVEM	T1,6(T4)		;[OK] COMPLETE DATE
>;END IFE FTOPS20
IFN FTOPS20,<
	PUSH	P,T4			;[360] NEEDED BY JSYS
	SETO	T2,			;[360] CURRENT DATE AND TIME
	SETZ	T4,			;[360] NOTHING SPECIAL
	ODCNV%				;[360] GET IT
	HLRZ	T3,T3			;[360] GET DAY
	ADDI	T3,1			;[360] START AT 1
	IDIVI	T3,^D10			;[360]
	LSH	T3,6			;[360] MAKE ROOM
	ADDI	T4,'00'			;[C20] SIXBIT DAYS IN T3
	ADD	T3,T4			;[C20] [360]    ..
	LSH	T3,6			;[360] FORM 'HH '
	POP	P,T4			;[360] GET STORE POINTER
	HRRZM	T3,7(T4)		;[OK] [360] STORE DAYS
	HLRZ	T1,T2			;[360] GET YEAR
	HRRZ	T3,T2			;[C20] [360] GET MONTH
	ADDI	T3,1			;[C20]   ..
	IDIVI	T1,^D100		;[360] GET RID OF 1900
	MOVE	T1,T3			;[360] MOVE MONTH TO SAFE PLACE
	IDIVI	T2,^D10			;[360] GET 2 DIGITS OF YEAR
	ADDI	T2,'0'			;[360] SIXBITIZE
	MOVEM	T2,6(T4)		;[OK] [360] STORE '	   Y'
	IDIVI	T1,^D10			;[360] GET 2 DIGITS OF MONTH
	LSH	T1,6			;[360] MAKE ROOM
	IOR	T1,T2			;[360] FORM MM
	LSH	T3,2*6			;[360] MAKE ROOM
	ADDI	T1,'000'		;[C20] [360] SIXBITIZE
	ADD	T3,T1			;[C20]   ..
	HRLM	T3,7(T4)		;[OK] [360] STORE 'YMM'
>;END IFN FTOPS20
	MOVE	T1,['PDP10 ']
	MOVEM	T1,^D10(T4)		;[OK]
	MOVEI	T1,^D80/6
	ADDM	T1,FILPTR(F)		;ADVANCE BYTE PTR
	MOVN	T1,T1
	ADDM	T1,FILCNT(F)
	RETURN
END;

WRTEBC:	JRST	E$$ELN

WRTBIN==WRTSIX
;STILL IN IFE FTFORTRAN
BEGIN
  PROCEDURE	(PUSHJ	P,WRTASC)	;WRITE ASCII LABEL
	HRRZ	T4,FILPTR(F)		;[C20] GET BUFFER ADDRESS
	SETZ	T2,
	SKIPN	T3,X.RIB+.RBNAM(P1)	;[OK] [215] GET NAME
	JRST	E$$NRL
	LSHC	T2,6			;SHIFT IN T2
	ADD	T1,T2			;[C20] ADD IN
	LSH	T1,1			;LEFT JUST
	MOVEM	T1,0(T4)		;[OK] FIRST WORD
	SETZ	T1,			;HOLD NAME
$1%	SETZ	T2,
	LSHC	T2,6			;GET NEXT CHAR
	LSH	T1,7			;MAKE SPACE
	ADDI	T2," "			;[C20] ADD IN
	ADD	T1,T2			;[C20]   ..
	TXNN	T1,177B7		;DONE?
	JRST	$1			;NOT YET
	LSH	T1,1			;LEFT JUSTIFY
	MOVEM	T1,1(T4)		;[OK] STORE
	SETZ	T1,
	HLLZ	T3,X.RIB+.RBEXT(P1)	;[OK] [215] GET EXTENSION
$2%	SETZ	T2,
	LSHC	T2,6			;SHIFT IN
	LSH	T1,7			;MAKE SPACE
	ADDI	T2," "			;[C20] ADD IN
	ADD	T1,T2			;[C20]   ..
	TXNN	T1,177B7		;DONE
	JRST	$2
	LSH	T1,1			;LEFT JUSTIFY
	MOVEM	T1,2(T4)		;[OK] STORE EXT
	MOVE	T1,[ASCII /     /]	;5 SPACES
	MOVEM	T1,3(T4)		;[OK]
	MOVEM	T1,4(T4)		;[OK] MORE SPACES
	MOVEM	T1,7(T4)		;[OK]
	MOVEM	T1,^D10(T4)		;[OK]
	MOVE	T2,[ASCII /PDP10/]
	DMOVEM	T1,^D11(T4)		;[OK]
	MOVEM	T1,^D13(T4)		;[OK]
	MOVEM	T1,^D14(T4)		;[OK]
	TRC	T1,<BYTE (7) 40,40,40,40,40>^!<BYTE (7) 40,40,40,15,12>
	MOVEM	T1,^D15(T4)		;[OK] END WITH CR-LF
	MOVE	T1,X.REEL(P1)		;[OK] [215] GET REEL NUMBER
	SETZ	T3,			;WHERE TO BUILD ID
  $3%	IDIVI	T1,^D10			;GET LEAST DIGIT
	LSHC	T2,-7			;SHIFT IN
	TXNN	T3,<BYTE (7) 0,0,0,177>	;GOT 4 CHARS YET
	JRST	$3			;NO
	LSHC	T2,3*7			;PUT 3 CHARS IN FIRST WORD
	LSH	T2,1
  IFE FTKL10,<
	ADD	T2,[ASCII /  000/]	;MAKE ASCII
	ADD	T3,[ASCII /00000/]	;COBOL FILLS WITH 0
  >
  IFN FTKL10,<
	DADD	T2,[ASCII /  00000000/]
  >
	DMOVEM	T2,5(T4)		;[OK]
IFE FTOPS20,<
	DATE	T1,			;GET CURRENT DATE
	IDIVI	T1,^D31
	ADDI	T2,1
	IDIVI	T2,^D10			;GET DAYS
	LSH	T2,7
	ADDI	T3,"00"			;[C20] ASCIIIZE
	ADD	T2,T3			;[C20]   ..
	LSH	T2,1+3*7		;SHIFT OFF BIT 35
	IOR	T2,[BYTE (7) 0,0,40,40,40]
	MOVEM	T2,^D9(T4)		;[OK] STORE DAYS
	IDIVI	T1,^D12			;GET MONTH
	ADDI	T2,1
	IDIVI	T2,^D10
	LSH	T2,7
	ADDI	T2,"00"			;[C20] PUT MONTH IN T3
	ADD	T3,T2			;[C20]   ..
	ADDI	T1,^D64			;ADD IN YEAR BASE
	IDIVI	T1,^D10
	LSH	T1,7
	ADDI	T2,"00"			;[C20] YY
	ADD	T1,T2			;[C20]   ..
	LSH	T1,2*7+1		;YY
	LSH	T3,1			;MM
>;END IFE FTOPS20
IFN FTOPS20,<
	PUSH	P,T4			;[360] NEEDED BY JSYS
	SETO	T2,			;[360] CURRENT DATE AND TIME
	SETZ	T4,			;[360] NOTHING SPECIAL
	ODCNV%				;[360] GET IT
	HLRZ	T3,T3			;[360] GET DAY
	ADDI	T3,1			;[360] START AT 1
	IDIVI	T3,^D10			;[360]
	LSH	T3,7			;[360] MAKE ROOM
	ADDI	T4,"00"			;[C20] [360] ASCII DAYS IN T3
	ADD	T3,T4			;[C20]   ..
	LSH	T3,1+3*7		;[360] SHIFT OFF BIT 35
	IOR	T3,[BYTE (7) 0,0,40,40,40]	;[360] PAD WITH SPACES
	MOVE	T4,0(P)			;[360] GET STORE POINTER
	MOVEM	T3,9(T4)		;[OK] [360] STORE DAYS
	HRRZ	T1,T2			;[C20] [360] GET MONTH
	ADDI	T1,1			;[C20]   ..
	HLRZ	T2,T2			;[360] GET YEAR
	IDIVI	T2,^D100		;[360] GET RID OF 1900
	IDIVI	T3,^D10			;[360] GET 2 DIGITS OF YEAR
	LSH	T3,7			;[360] MAKE SPACE
	ADDI	T4,"00"			;[C20] [360] ASCII "YY"
	ADD	T3,T4			;[C20]   ..
	IDIVI	T1,^D10			;[360] GET 2 DIGITS OF MONTH
	LSH	T1,7			;[360] MAKE ROOM
	ADDI	T2,"00"			;[C20] [360] FORM MM
	ADD	T1,T2			;[C20]   ..
	LSH	T3,2*7+1		;[360] MAKE ROOM
	LSH	T1,1			;[360] LEFT JUSTIFY
	POP	P,T4			;[360] GET STORE POINTER
>;END IFN FTOPS20
	IOR	T1,T3			; YYMM
	TXO	T1,ASCII / /
	MOVEM	T1,8(T4)		;[OK]
	MOVEI	T1,^D82/5+1
	ADDM	T1,FILPTR(F)
	MOVNI	T1,^D82			;[C08] GET BYTE COUNT
	ADDM	T1,FILCNT(F)
	RETURN
END;
SUBTTL	TAPE LABEL ROUTINES -- CHKEND - Check End Labels

;STILL IN IFE FTFORTRAN
BEGIN
  PROCEDURE (PUSHJ	P,CHKEND)	;HERE TO CHECK END MAGTAPE LABEL
	PUSH	P,P1			;[215] SAVE TEMP FOR X. BLOCK
	MOVE	P1,FILXBK(F)		;[215]   ..
  IF TAPE LABEL HANDLER IS NOT CHECKING THIS TAPE
	MOVE	T1,FILFLG(F)		;[C12] [215] GET TAPE'S FILE FLAGS
	TXNE	T1,FI.ATO		;[C12] [215] LABELER DOING THE WORK?
	JRST	$F			;[C12] [215] YES--NO PROBLEM
  THEN WE MUST DO IT OURSELVES
  IFE FTOPS20,<
	HRL	T1,FILCHN(F)		;[C19] BUILD FILOP. BLOCK, GET CHANNEL
	HRRI	T1,.FOCLS		;[C19] GET CLOSE FUNCTION
	MOVEM	T1,FLPARG+.FOFNC	;[C19] STORE THEM
	SETZM	FLPARG+.FOIOS		;[C19] NO CLOSE BITS
	SETZM	FLPARG+.FOLEB		;[C19] NO LOOKUP BLOCK FOR ERRORS
	MOVE	T1,[XWD .FOIOS+1,FLPARG]	;[C19] DO CLOSE FILOP.
	FILOP.	T1,			;[C19]   ..
	  JRST	ERRFUF			;[C19] FAILED
  >
	  CASE LABEL TYPE OF (STANDARD, OMITTED,NON-STANDARD,DEC,ANSI,IBM)
		MOVE	T1,X.LABL(P1)		;[OK] [215] GET LABEL TYPE
		JRST	@[IFIWS <$1,$C,$C,$1,$C,$C>]-1(T1) ;[C20] [C03] [215] CASE BY LABEL TYPE

	  $1%	;[215] STANDARD OR DEC LABELS (SYNONYMOUS)
	  IFN FTOPS20,<
		PUSHJ	P,STRTIO		;[C03] RESTART I/O
	  >
		JSP	T4,GETBUF		;READ THE LABEL
		  JRST	E$$RIE			;SHOULD NOT HAPPEN
		SETZM	FILCNT(F)		;SO WE IGNORE BLOCK WHEN DONE
		HRRZ	T2,FILPTR(F)		;[C20] [215] GET LABEL DESIGNATOR
		MOVE	T2,(T2)			;[C20]   ..
		  CASE MODE OF (SIXBIT,ASCII,EBCDIC,BINARY)
			HRRZ	T1,MODE		;[215] GET MODE OF TAPE
			PUSHJ	P,@[IFIWS <CHKESX,CHKEAS,E$$ELN,CHKEBN>]-1(T1)	;[C20]
		  ESAC;
	  ESAC;

$2%	JSP	T4,GETBUF		;[C03] GET A BUFFER
	  JRST	$3			;[C03] EOF, YAY
	SETZM	FILCNT(F)		;[C03] NOT EOF, NOT INTERESTED
	JRST	$2			;[C03] TRY AGAIN
$3%					;[C03]

  FI;
	POP	P,P1			;[215] RESTORE TEMP
	RETURN				;[215] DONE
END;
;STILL IN IFE FTFORTRAN
BEGIN
  PROCEDURE (PUSHJ	P,CHKESX)	;[215] CHECK SIXBIT END LABEL
	LSH	T2,-^D12		;[215] SHIFT OUT GARBAGE
  IF EOV1 LABEL (FILE IS CONTINUED ON ANOTHER REEL)
	CAXE	T2,'EOV1'		;[215] LOOK AT JUST DESIGNATOR
	JRST	$T			;[215] NOT EOV--TRY EOF
  THEN REMEMBER FOR LATER
	MOVX	T1,FI.EOT		;[215] SET UP EOT BIT FOR LATER
	ORM	T1,FILFLG(F)		;[215] REMEMBER EOT CONDITION PENDING
	JRST	$F			;[215] NOW GO EAT LABEL
  ELSE CHECK IF EOF1 (END-OF-FILE)
	CAXE	T2,'EOF1'		;[215] LOOK AT JUST DESIGNATOR
	JRST	E$$LNC			;[215] NO GOOD--TELL USER
	SETZM	X.REEL(P1)		;[OK] [215] OK--RESET COUNT TO INDICATE NO MORE TAPES
  FI;
	RETURN				;[C03]
END;


BEGIN
  PROCEDURE (PUSHJ	P,CHKEAS)	;[215] CHECK ASCII END LABELS
	LSH	T2,-^D8			;[215] SHIFT OUT GARBAGE
  IF EOV1 LABEL (FILE CONTINUED ON ANOTHER REEL)
	CAXE	T2,"EOV1"		;[215] LOOK AT JUST DESIGNATOR
	JRST	$T			;[215] NOT EOV--TRY EOF
  THEN REMEMBER FOR LATER
	MOVX	T1,FI.EOT		;[215] SET UP EOT BIT FOR LATER
	ORM	T1,FILFLG(F)		;[215] REMEMBER EOT CONDITION PENDING
	JRST	$F			;[215] NOW GO EAT LABEL
  ELSE CHECK IF EOF1 (END-OF-FILE)
	CAXE	T2,"EOF1"		;[215] LOOK AT JUST DESIGNATOR
	JRST	E$$LNC			;[215] NO GOOD--TELL USER
	SETZM	X.REEL(P1)		;[OK] [215] OK--RESET COUNT TO INDICATE NO MORE TAPES
  FI;
	RETURN				;[C03]
END;
;STILL IN IFE FTFORTRAN
BEGIN
  PROCEDURE (PUSHJ	P,CHKEBN)	;[215] CHECK BINARY END LABELS
	MOVE	T1,T2			;[215] GET TEMP COPY OF DESIGNATOR
	LSH	T1,-^D8			;[215] SET UP TO TRY ASCII
	CAXE	T1,"EOV1"		;[215] END-OF-VOLUME
	CAXN	T1,"EOF1"		;[215]   OR END-OF-FILE?
	PJRST	CHKEAS			;[215] YES--MUST BE ASCII
	LSH	T1,-4			;[215] NO--THEN TRY FOR SIXBIT
	CAXE	T1,'EOV1'		;[215] END-OF-VOLUME
	CAXN	T1,'EOF1'		;[215]   OR END-OF-FILE?
	PJRST	CHKESX			;[215] YES--MUST BE SIXBIT
	JRST	E$$LNC			;[215] NEITHER--NO GOOD
END;
SUBTTL	TAPE LABEL ROUTINES -- WRTEND - Write End-of-file Labels

;STILL IN IFE FTFORTRAN
BEGIN
  PROCEDURE	(PUSHJ	P,WRTEND)
	PUSH	P,P1			;[215] SAVE TEMP FOR X. BLOCK
	MOVE	P1,FILXBK(F)		;[215] LOAD UP X. BLOCK
	JSP	T4,PUTBUF		;[C08] FORCE BUFFER OUT
  IF TAPE LABEL HANDLER IS NOT DOING THIS TAPE
	MOVE	T1,FILFLG(F)		;[C12] [215] TEST AUTO-LABELING BIT
	TXNE	T1,FI.ATO		;[C12] [215]   ..
	JRST	$F			;[C12] [215] NO PROBLEM
  THEN WE MUST DO IT OURSELVES
	  CASE LABEL TYPE OF (STANDARD,OMITTED,NON-STANDARD,DEC,ANSI,IBM)
		MOVE	T1,X.LABL(P1)		;[OK] [215] GET LABEL TYPE
		JRST	@[IFIWS <$1,$C,$C,$1,$C,$C>]-1(T1) ;[C20] [215] CASE ON LABEL TYPE

	  $1%	;[215] STANDARD OR DEC LABELS (SYNONYMOUS)
		PUSHJ	P,WRTEOF		;[C08] WRITE EOF BEFORE LABEL
  IFE FTOPS20,<
		MOVX	T1,BF.VBR
		ANDCAM	T1,FILHDR(F)		;CLEAR THE VIRGIN RING BIT
  >;END IFE FTOPS20
		  CASE I/O MODE OF (SIXBIT,ASCII,EBCDIC,BINARY)
			HRRZ	T2,MODE		;[215] GET TAPE'S I/O MODE
			MOVE	T1,[EXP 'EOF1',"EOF1 ",0,'EOF1']-1(T2) ;[OK] [215] SET UP LABEL
			PUSHJ	P,@[IFIWS <WRTSIX,WRTASC,WRTEBC,WRTBIN>]-1(T2)	;[C20]
		  ESAC;
;		JRST	$C			;[215] FALL THROUGH
	  ESAC;
  FI;
	POP	P,P1			;[215] RESTORE TEMP
	RETURN				;[215] ALL DONE
END;
SUBTTL	TAPE LABEL ROUTINES -- WRTEOT - Write End-of-tape Labels

;STILL IN IFE FTFORTRAN
BEGIN
  PROCEDURE	(PUSHJ	P,WRTEOT)
	PUSH	P,P1			;[215] SAVE TEMP FOR X. BLOCK
	MOVE	P1,FILXBK(F)		;[215] LOAD UP X. BLOCK
  IF TAPE LABEL HANDLER IS NOT DOING THIS TAPE
	MOVE	T1,FILFLG(F)		;[C12] [215] TEST AUTO-LABELING BIT
	TXNE	T1,FI.ATO		;[C12] [215]   ..
	JRST	$F			;[C12] [215] NO PROBLEM
  THEN WE MUST DO IT OURSELVES
	  CASE LABEL TYPE OF (STANDARD,OMITTED,NON-STANDARD,DEC,ANSI,IBM)
		MOVE	T1,X.LABL(P1)		;[OK] [215] GET LABEL TYPE
		JRST	@[IFIWS <$1,$2,$2,$1,$2,$2>]-1(T1) ;[C20] [215] CASE ON LABEL TYPE

	  $1%	;[215] STANDARD OR DEC LABELS (SYNONYMOUS)
		PUSHJ	P,WRTEOF		;[C08] WRITE EOF BEFORE LABEL
  IFE FTOPS20,<
		MOVX	T1,BF.VBR
		ANDCAM	T1,FILHDR(F)		;CLEAR THE VIRGIN RING BIT
  >;END IFE FTOPS20
		  CASE I/O MODE OF (SIXBIT,ASCII,EBCDIC,BINARY)
			HRRZ	T2,MODE		;[215] GET TAPE'S I/O MODE
			MOVE	T1,[EXP 'EOV1',"EOV1 ",0,'EOV1']-1(T2) ;[OK] [215] SET UP LABEL
			PUSHJ	P,@[IFIWS <WRTSIX,WRTASC,WRTEBC,WRTBIN>]-1(T2)	;[C20]
		  ESAC;
			JSP	T4,PUTBUF	;[C08] FORCE BUFFER OUT
		PUSHJ	P,WRTEOF		;[215] WRITE EOF AFTER LABEL
		PUSHJ	P,WRTEOF		;[C08] WRITE ANOTHER EOF AFTER LABEL
		JRST	$C			;[215] DONE

	  $2%	;[215] OMITTED, NON-STANDARD, ANSI, OR IBM LABELS
E$$MSD:		$ERROR	(?,MSD,<Multi-reel tape files with other than STANDARD or DEC labels not supported.>)
;		JRST	$C			;[215] FALL THROUGH
	  ESAC;
  FI;
	POP	P,P1			;[215] RESTORE TEMP
	RETURN				;[215] ALL DONE
END;
SUBTTL	ENDS. -- Clean Up After SORT

;STILL IN IFE FTFORTRAN
BEGIN
  PROCEDURE	(PUSHJ	P,ENDS.)
  IFE FTOPS20,<
	PUSHJ	P,RELSPC	;[C13] RELEASE ANY RETAINED SPACE
   IFE FTVM,<
	PUSHJ	P,GETSCN	;[C20] NEED HI-SEG
  >>
  IFN FTOPS20,<
	PUSHJ	P,RESET$	;[335] CLEAN UP MEMORY
  >
	MOVE	T1,INPREC	;[363] NUMBER OF RECORDS SORTED
	CAME	T1,OUTREC	;[363] SAME NUMBER AS WE OUTPUT?
	PUSHJ	P,E$$RNI	;[363] RECORD NUMBER INCONSISTENT
	PUSHJ	P,STATS		;[C20] TYPE STATISTICS, IF NECESSARY
	SKIPE	FORRET		;[C20] CALLED FROM FORTRAN?
  IFN FTOPS20,<
	SKIPE	TAKFLG		;[C20] AND NOT TAKING?
	SKIPA			;[C20] NO
  >
	JRST	FORXIT		;[C20] YES, RETURN TO USER
	RETURN
END;
>;END IFE FTFORTRAN
SUBTTL	LPURE SEGMENT ERROR MESSAGES

E$$ELN:	$ERROR	(?,ELN,<EBCDIC tape labels not supported.>)
ERRRTI:	AOSLE	RTRUNC		;ALREADY SEEN MESSAGE
	POPJ	P,		;YES
	PUSH	P,T0		;[C28]
	PUSH	P,T1
	PUSH	P,T2
	PUSH	P,T3		;[C28]
	PUSH	P,T4		;[455] [C28]
	$ERROR	(%,RTI,<Record truncation on input>)
	POP	P,T4		;[455] [C28]
	POP	P,T3		;[C28]
	POP	P,T2
	POP	P,T1
	POP	P,T0		;[C28]
	POPJ	P,
IFE FTOPS20,<
E$$SAT:	$ERROR	(?,SAT,<Standard ASCII requires TU70 drive>)
>
IFE FTFORTRAN,<
E$$NRL:	$ERROR	(?,NRL,<Name required with labeled magtape>)
E$$LNC:	$ERROR	(?,LNC,<LABEL not correct for >,+)
  IFE FTOPS20,<
	MOVEI	T2,X.RIB(P1)		;[OK] [215] TYPE OFFENDING FILE SPEC
  >
  IFN FTOPS20,<
	HRRZ	T2,X.JFN(P1)		;[C20] [C08] $MORE WANTS JFN ON TOPS20
  >
	$MORE	(FILESPEC,T2)
	$DIE

ERRROS:	PUSH	P,T1			;SAVE BAD REEL #
	$ERROR	(?,ROS,<Reel no. >,+)
	POP	P,T1
	$MORE	(DECIMAL,T1)
	$MORE	(TEXT,< out of sequence for >,+)
  IFE FTOPS20,<
	MOVEI	T2,X.RIB(P1)		;[OK] [215] PRINT OFFENDING FILE SPEC
  >
  IFN FTOPS20,<
	HRRZ	T2,X.JFN(P1)		;[C20]
  >
	$MORE	(FILESPEC,T2)
	$DIE
>;END IFE FTFORTRAN