Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-09 - 43,50466/forwmu.mac
There are 4 other files named forwmu.mac in the archive. Click here to see a list.
	TITLE	FORWMU - LOCAL FOROTS PATCHES
	SUBTTL	T HAGADONE

	SEARCH	FORPRM
IFNDEF FTWMU,<FTWMU==0>
IFN FTWMU,<
	ENTRY	INDVT.

INDVT.:	MOVSI	T2,ACC.SV+20(P4);FIRST LOC TO ZERO
	HRRI	T2,ACC.SV+21(P4)
	SETZM	ACC.SV+20(P4)	;ZERO IT
	BLT	T2,@.JBREL	;TO TOP OF CORE
	MOVEI	T1,DEVTB.	;ADDRESS OF DEVTB.
	MOVEM	T1,DEV.TB(P4)	;STORE IT FOR FOROTS
	MOVEI	T1,DVEND.-DEVTB.-1	;SIZE OF DEVTAB
	MOVEM	T1,DEV.SZ(P4)	;STORE IT FOR FOROTS
	JRST	(P)		;RETURN
	SUBTTL DEVTB. DEFAULT DEVICE TABLE FOR FORTRAN IV

	SIXBIT	.REREAD.	;-6;	REREAD
	SIXBIT	.CDR.		;-5;	READ
	SIXBIT	.TTY.		;-4;	ACCEPT
	SIXBIT	.LPT.		;-3;	PRINT
	SIXBIT	.PTP.		;-2;	PUNCH
	SIXBIT	.TTY.		;-1;	TYPE
DEVTB.:	Z			;00;	ILLEGAL DEVICE NUMBER
	SIXBIT	.DSK.		;01;	DISC
	SIXBIT	.CDR.		;02;	CARD READER
	SIXBIT	.LPT.		;03;	LINE PRINTER
	SIXBIT	.CTY.		;04;	CONSOLE TELETYPE
	SIXBIT	.TTY.		;05;	USER'S TELETYPE
	SIXBIT	.PTR.		;06;	PAPER TAPE READER
	SIXBIT	.PTP.		;07;	PAPER TAPE PUNCH
	SIXBIT	.DIS.		;08;	DISPLAY
	SIXBIT	.DTA1.		;09;	DECTAPE
	SIXBIT	.DTA2.		;10;
	SIXBIT	.DTA3.		;11;
	SIXBIT	.DTA4.		;12;
	SIXBIT	.DTA5.		;13;
	SIXBIT	.DTA6.		;14;
	SIXBIT	.DTA7.		;15;
	SIXBIT	.MTA0.		;16;	MAG TAPE
	SIXBIT	.MTA1.		;17;
	SIXBIT	.MTA2.		;18;
	SIXBIT	.FORTR.		;19;
	SIXBIT	.DSK.		;20;
	SIXBIT	.DSK.		;21;
	SIXBIT	.DSK.		;22;
	SIXBIT	.DSK.		;23;
	SIXBIT	.DSK.		;24;
	SIXBIT	.DEV1.		;25;
	SIXBIT	.DEV2.		;26;
	SIXBIT	.DEV3.		;27;
	SIXBIT	.DEV4.		;28;
	SIXBIT	.CDP.		;29;
	SIXBIT	.TTY.		;30;
DVEND.:

>	;END FTWMU
	PRGEND
	TITLE	DEVCHG
	SUBTTL	CHANGE DEVTB. ENTRIES TO NEW DEVICES

	SEARCH	FORPRM
IFNDEF FTWMU,<FTWMU==0>
IFN FTWMU,<

BP7=0
BP6=1
CTR=2
A=3
IND=5
CH=6
P4=7
Q=16
P=17

	HELLO	(DEVCHG)
	HRRZ	P4,.JBOPS	;LOAD BASE REGISTER
	SETZ	A,
	SKIPLE	IND,@1(Q)	;GET FLU, IS IT LEGAL
	CAMLE	IND,DEV.SZ(P4)	;TOP AND BOTTOM?
	JRST	[OUTSTR DEVERR
		MOVEI	16,[EXP 0,0]+1	;ARG FOR EXIT.
		PUSHJ P,EXIT.##]
	MOVEI	BP7,@(Q)	;ADDRESS OF DEVICE NAME
	HRLI	BP7,440700
	MOVE	BP6,POINT
	HRROI	CTR,-5		;NUMBER OF CHARS PER WORD
GETDEV:	ILDB	CH,BP7
	JUMPE	CH,DONE
	SUBI	CH,40
	IDPB	CH,BP6
	AOJL	CTR,GETDEV
DONE:	ADD	IND,DEV.TB(P4)	;ADDRESS OF ENTRY
	MOVEM	A,(IND)		;STORE NEW DEVICE
	GOODBY

POINT:	POINT	6,A,
DEVERR:	ASCIZ	/?FRSDVC - ILLEGAL DEVICE NUMBER IN CALL TO DEVCHG
/

>	;END FTWMU
	PRGEND
	TITLE BLOCKT
SUBTTL	 BLOCK TRANSFER SUBROUTINE
	SEARCH	FORPRM

COMMENT	*

USAGE		CALL BLOCKT(ARRAY1,ARRAY2,NWORDS)
	WHERE	ARRAY1:	IS ARRAY (VECTOR) TO BE TRANSFERED
		ARRAY2:	IS ARRAY (VECTOR) TO TRANSFER ARRAY1 TO
		NWORDS:	IS THE NUMBER OF WORDS TO TRANSFER
*


	HELLO	(BLOCKT, )	;BLOCKT ENTRY
	MOVSI	0,@0(16)	;PICK UP STARTING ADDRESS
	HRRI	0,@1(16)	;PICK UP DESTINATION ADDRESS
	HRRZ	1,0		;COPY
	ADD	1,@2(16)	;ADD LENGTH
	BLT	0,-1(1)		;TRANSFER. LIMIT =C(1)-1
	GOODBY	(3)		;RETURN
	PRGEND
	TITLE	LDBDPB - DO LDB AND DPB INSTRUCTIONS
	SEARCH	FORPRM

COMMENT	%

	USAGE		CALL GETBYT(SRCWD,IBYTE,ISIZE,IRMOST,IERR)
		WHERE	SRCWD  - WORD TO GET BYTE OUT OF
			IBYTE  - WORD TO PUT BYTE INTO
			ISIZE  - SIZE OF BYTE (1 TO 36)
				 MUST NOT BE GREATER THAN IRMOST+1
			IRMOST - POSITION OF RIGHTMOST BIT OF BYTE (0 TO 35)
			IERR   - ERROR CODE. NON-ZERO IF ARGUMENTS ARE ILLEGAL

			CALL GETBYT(DSTWD,IBYTE,ISIZE,IRMOST,IERR)
		WHERE	DSTWD  - WORD TO PUT THE BYTE IN
			IBYTE  - WORD TO DPB FROM
			OTHERS - SAME AS ABOVE

%
	HELLO	(GETBYT)
	PUSHJ	P,MAKPNT	;SET UP THE BYTE POINTER
	 GOODBY	(1)		;ERROR
	LDB	0,3		;LOAD THE BYTE
	MOVEM	0,@1(16)	;RETURN IT TO THE USER
	GOODBY	(1)		;RETURN

	HELLO	(PUTBYT)
	PUSHJ	P,MAKPNT	;SET UP THE BYTE POINTER
	 GOODBY	(1)		;ERROR
	MOVE	0,@1(16)	;GET THE BYTE
	DPB	0,3		;DEPOSIT THE BYTE
	GOODBY	(1)		;RETURN
MAKPNT:	SETZM	@4(16)		;ASSUME NO ERROR
	SKIPL	2,@3(16)	;IS "RIGHTMOST BIT" LEGAL?
	CAILE	2,^D35		;...
	 JRST	ERRORR		;NO. ERROR
	SKIPLE	1,@2(16)	;IS SIZE LEGAL?
	CAILE	1,1(2)		;...
	 JRST	ERRORR		;NO. ERROR
	MOVEI	3,^D35		;GET BITS TO THE RIGHT
	SUB	3,2		;...
	LSH	3,6		;MAKE SPACE FOR SIZE
	IOR	3,1		;PUT IN SIZE
	LSH	3,^D24		;POSITION
	HRRI	3,@0(16)	;GET ADDRESS
	AOS	(P)		;SKIP RETURN
	POPJ	P,

ERRORR:	SETOM	@4(16)
	POPJ	P,
	PRGEND
	TITLE BYTE PACKING/UNPACKING
	SEARCH	FORPRM

COMMENT	%

WRITTEN BY NORM GRANT. W.M.U. NOVEMBER 2, 1973

PURPOSE	PACK AND UNPACK ASCII WORDS

USAGE		CALL GETCHR(WORD,IBYTE,CHAR)
	WHERE		WORD:	IS PACKED WORD(S)
			IBYTE:	IS BYTE NUMBER (.GT. ZERO)
			CHAR:	IS CHARACTER UNPACKED (TRAILING BLANKS)

		CALL PUTCHR(WORD,IBYTE,CHAR)
	WHERE		WORD:	IS PACKED WORD(S)
			IBYTE:	IS BYTE NUMBER (.GT. ZERO)
			CHAR:	IS CHARACTER TO BE PACKED (LEFT JUSTIFIED)

	%

Q=16

	HELLO	(GETCHR, )	;GETCHR ENTRY
	MOVE	0,[ASCII'     '] ;BLANK OUT CHAR
	MOVEM	0,@2(Q)
	PUSHJ	P,BYTE
	LDB	0,2		;PICK UP CHARACTER FROM WORD
	DPB	0,3		;STORE IN CHAR
	GOODBY	(3)		;RETURN

	HELLO	(PUTCHR, )	;PUTCHR ENTRY
	PUSHJ	P,BYTE
	LDB	0,3		;PICK UP CHARACTER FROM CHAR
	DPB	0,2		;STORE IN WORD
	GOODBY	(3)		;RETURN

BYTE:	MOVE	2,@1(Q)	;GET BYTE NUMBER
	JUMPLE	2,NULL		;NON-POSITIVE IS AN ERROR
	SUBI	2,1		;MINUS ONE FOR DIVIDE
	IDIVI	2,5		;FIVE CHARACTERS PER WORD
	ADD	2,BYTTAB(3)	;ADD PROPER POINTER WORD
	ADDI	2,@0(Q)		;ADD IN ADDRESS OF WORD
	MOVEI	3,@2(Q)		;GET POINTER TO CHARACTER
	HRLI	3,350700
	POPJ	P,		;RETURN
BYTTAB:	POINT	7,0,6		;FIRST BYTE IN WORD
	POINT	7,0,13		;SECOND
	POINT	7,0,20		;THIRD
	POINT	7,0,27		;FOURTH
	POINT	7,0,34		;FIFTH AND LAST

NULL:	OUTSTR	[ASCIZ/
Non-positive byte number is illegal!
/]
	POP	P,0
	GOODBY	(2)

	PRGEND
TITLE	CLOCK
SUBTTL	TIME OF DAY.
	SEARCH	FORPRM

COMMENT	%

WRITTEN BY NORM GRANT. W.M.U.

USAGE		CALL CLOCK(IHOUR,IMIN,ISEC,ITICK)
	WHERE	IHOUR:	HOUR OF DAY-24 HOUR TIME.
		IMIN:	MINUTE.
		ISEC:	SECOND.
		ITICK:	CLOCK TICK(1/60 TH SECOND).

%


	HELLO	(CLOCK, )	;CLOCK ENTRY
	TIMER
	IDIVI	0,^D60
	MOVEM	1,@3(16)
	IDIVI	0,^D60
	MOVEM	1,@2(16)
	IDIVI	0,^D60
	MOVEM	1,@1(16)
	MOVEM	0,@0(16)
	GOODBY	(4)
	PRGEND
	TITLE	DAY
SUBTTL	DATE
	SEARCH	FORPRM

COMMENT	%

WRITTEN BY NORM GRANT. WMU. SEPTEMBER 2,1971.

PURPOSE:	TO DETERMINE YEAR, MONTH, AND DAY.

USAGE		CALL DAY(IYEAR,IMONTH,IDAY)
	WHERE	IYEAR:	INTEGER YEAR(RETURNED)
		IMONTH:	INTEGER MONTH(1-12)(RETURNED)
		IDAY:	INTEGER DATE OF MONTH.
%


	HELLO	(DAY, )		;DAY ENTRY
	DATE
	IDIVI	0,^D31
	AOJ	1,
	MOVEM	1,@2(16)
	IDIVI	0,^D12
	AOJ	1,
	MOVEM	1,@1(16)
	ADDI	0,^D1964
	MOVEM	0,@0(16)
	GOODBY	(3)
	PRGEND
TITLE	DLOGIC
SUBTTL	FORTRAN SUBROUTINES FOR LSHC AND ROTC.
REMARK	WRITTEN BY NORM GRANT. W.M.U.

	SEARCH	FORPRM

COMMENT	%

USAGE		CALL DSHIFT(WORD,IPLACES,WORD1)
		CALL DROTATE(WORD,IPLACES,WORD1)
	WHERE	WORD:	IS DOUBLE PRECISION WORD TO BE SHIFTED OR ROTATED.
		IPLACES:	IS NUMBER OF PLACES TO SHIFT OR ROTATE.
			POSITIVE IS LEFT, NEGATIVE IS RIGHT.
		WORD1:	DOUBLE PRECISION RESULT.
%

	HELLO	(DSHIFT, )	;DSHIFT ENTRY
	DMOVE	0,@0(16)
	MOVE	2,@1(16)
	LSHC	0,0(2)
DRET:	DMOVEM	0,@2(16)
	GOODBY	(3)

	HELLO	(DROTAT, )	;DROTAT ENTRY
	DMOVE	0,@0(16)
	MOVE	2,@1(16)
	ROTC	0,0(2)
	JRST	DRET

	PRGEND
TITLE DYTIME
SUBTTL GET DAY TIME, IN MS.
	SEARCH	FORPRM

COMMENT	%


WRITTEN BY NORM GRANT.  W.M.U.

USAGE	CALL DYTIME(ITIME)
	WHERE	ITIME:	IS DAYTIME IN MILLISECONDS.(RETURNED)
%


	HELLO	(DYTIME, )	;DYTIME ENTRY
	MSTIME	0,
	MOVEM	0,@0(16)
	GOODBY	(1)
	PRGEND
TITLE	ECHO - SUBROUTINE TO TURN TTY ECHO ON OR OFF.
SUBTTL	WRITTEN BY JERRY FOCHTMAN. W.M.U.

	SEARCH	FORPRM

COMMENT	%

USAGE		CALL ECHO(ICMD)
	WHERE	ICMD - IS A SWITCH TO TURN ECHO EITHER ON OR OFF.
			0 - ON
			1 - OFF

	NOTE - A CARRIAGE RETURN DOES NOT GENERATE A LINE FEED
		WHEN ECHO IS OFF, SO THE MAIN PROGRAM MUST ALLOW
		FOR IT.

	%


	HELLO	(ECHO, )	;ECHO ENTRY
	MOVE	1,@0(16)
	SETO	0,
	GETLCH	0,
	JUMPN	1,NEO
	TLZ	0,4
	JRST	DONE
NEO:	TLO	0,4
DONE:	SETLCH	0,
	GOODBY	(1)
	PRGEND
	TITLE	TYPEON
	SEARCH	FORPRM
	HELLO	(TYPEON, )
	SKPINL			;TURN ON ECHOING
	JFCL			;DON'T CARE
	GOODBY	(0)
	PRGEND
	TITLE	GES
	SEARCH	FORPRM

	HELLO	(GES, )
	SETZ	7,
	MOVE	1,@1(16)
	ADDI	1,@0(16)
	SOJ	1,
	HRRM	1,BLL
	HRLI	1,@0(16)
	MOVEI	2,@0(16)
	AOJ	2,
	HRRM	2,1
	MOVE	2,BL
	MOVEM	2,@(16)
BLL:	BLT	1,0
	MOVEI	1,@0(16)
	HRRM	1,MOV
	SETZM	@2(16)
	MOVE	1,@1(16)
	SETZ	4,
TT:	INCHWL	2
	CAIN	2,15
	JRST	TT
	CAIN	2,12
	JRST	EOL
	JUMPL	7,NEXT
	MOVE	3,BL
	DPB	2,[POINT	7,3,6]
MOV:	MOVEM	3,(4)
NEXT:	CAIG	2,175
	CAIN	2,33
	JRST	ALT
	CAIN	2,32
	JRST	EOF
A:	AOJ	4,
	CAML	4,1
	SETO	7,
	JRST	TT
ALT:	SETOM	@2(16)
	JRST	CRLF
EOL:	MOVEI	5,1
	MOVEM	5,@2(16)
	GOODBY	(3)
EOF:	MOVEI	5,2
	MOVEM	5,@2(16)
CRLF:	OUTSTR	[BYTE (7)15,12]
	GOODBY	(3)
BL:	ASCII/     /
	PRGEND
TITLE	GETPPN
SUBTTL	RETURN PROJECT-PROGRAMMER PAIR.
	SEARCH	FORPRM

	COMMENT	%

	WRITTEN BY NORM GRANT. AUGUST 30,1971.

USAGE		CALL GETPPN(IPROJ,IPROG)
	WHERE	IPROJ:	PROJECT NUMBER(OCTAL) RETURNED.
		IPROG:	PROGRAMMER NUMBER(OCTAL) RETURNED.
%


	HELLO	(GETPPN, )	;GETPPN ENTRY
	CALLI	0,24
	HRRZM	0,@1(16)
	HLRZM	0,@0(16)
	GOODBY	(2)
	PRGEND
	TITLE	JOBNUM
SUBTTL	GET JOB NUMBER
	SEARCH	FORPRM

COMMENT	%

WRITTEN BY NORM GRANT. WMU. SEPTEMBER 2,1971.

PURPOSE:	TO DETERMINE JOB NUMBER OF USER'S JOB.

USAGE		CALL JOBNUM(IJOB)
	WHERE	IJOB:	INTEGER JOB# (RETURNED)
%


	HELLO	(JOBNUM, )	;JOBNUM ENTRY
	PJOB
	MOVEM	0,@0(16)
	GOODBY	(1)
	PRGEND
TITLE	LOGIC
SUBTTL	FORTRAN SUBROUTINES FOR LSH AND ROT.
REMARK	WRITTEN BY NORM GRANT. W.M.U.

	SEARCH	FORPRM

COMMENT	%

USAGE		CALL SHIFT(WORD,IPLACES,WORD1)
		CALL ROTATE(WORD,IPLACES,WORD1)
	WHERE	WORD:	IS WORD TO BE SHIFTED OR ROTATED.
		IPLACES:	IS NUMBER OF PLACES TO SHIFT OR ROTATE.
			POSITIVE IS LEFT, NEGATIVE IS RIGHT.
		WORD1:	RESULT
%


	HELLO	(SHIFT, )	;SHIFT ENTRY
	MOVE	1,@1(16)
	MOVE	0,@0(16)
	LSH	0,0(1)
RET:	MOVEM	0,@2(16)
	GOODBY	(3)

	HELLO	(ROTATE, )	;ROTATE ENTRY
	MOVE	1,@1(16)
	MOVE	0,@0(16)
	ROT	0,0(1)
	JRST	RET

	PRGEND
	TITLE	MAXIMUMS
SUBTTL	FIND MAXIMUM ENTRY IN LIST
	SEARCH	FORPRM

COMMENT	%

WRITTEN BY NORM GRANT. W.M.U.

USAGE		CALL MAXIMU(ARRAY,NUM,ANS)
	WHERE	ARRAY	IS ARRAY FROM WHICH TO SELECT MAXIMUM.
		NUM	SIZE OF ARRAY(>=1)
		ANS	MAXIMUM(SAME MODE AS ARRAY)

%


	HELLO	(MAXIMU, )	;MAXIMUM ENTRY
	MOVE	2,@1(16)
	MOVE	0,@0(16)
	SOJLE	2,DONE
	MOVEI	1,@0(16)
	AOJ	1,
	CAMGE	0,0(1)
	MOVE	0,0(1)
	SOJG	2,.-3
DONE:	MOVEM	0,@2(16)
	GOODBY	(3)
	PRGEND
	TITLE	MAXWYT
	SEARCH	FORPRM

MIDNIT:	EXP	^D24*^D3600*^D1000	;NUMBER OF MILLISECONDS IN A DAY
	HELLO (MAXWYT, )
	MOVE	1,@0(16)	;GET TIME LIMIT
	IMULI	1,^D1000	;CONVERT TO MILLISECONDS
	MSTIME	3,		;GET CURRENT TIME
	ADD	3,1		;MAKE TIME LIMIT
	IDIV	3,MIDNIT	;MAY BE DAYS
	DATE	2,
	ADD	3,2		;GET FINAL DAY TOO
CHECK:	SKPINL			;ANY INPUT LINES?
	 CAIA			;NO
	JRST	GOTINP		;YES. GOOD RETURN
	DATE	2,		;CURRENT DATE
	MOVN	2,2
	ADD	2,3
	IMUL	2,MIDNIT	;DAYS YET
	ADD	2,4
	MSTIME	0,		;CURRENT TIME
	SUB	2,0		;TOTAL TIME YET TO WAIT
	JUMPLE	2,BADRET	;TOO LATE IF NOT POSITIVE
	CAILE	2,^D60000	;60 SECONDS OR LESS
	MOVEI	2,^D60000	;NO. USE 60 SECONDS
	TLO	2,(1B13)	;WAKE ON INPUT LINE
	HIBER	2,		;HIBERNATE
	 JRST	USESLP		;IF GET ERROR, WE MUST USE SLEEP
	JRST	CHECK		;GO CHECK ON INPUT
USESLP:	MOVEI	2,1		;SLEEP ONE SECOND
	SLEEP	2,
	JRST	CHECK		;AND GO CHECK
GOTINP:	SETZM	@1(16)		;GOOD EXIT
	GOODBY	(2)
BADRET:	MOVEI	0,1		;BAD RETURN
	MOVEM	0,@1(16)
	CLRBFI			;CLEAR ANY INPUT (PARTIAL LINES)
	GOODBY	(2)		;AND EXIT
	PRGEND
	TITLE	MINIMUMS
SUBTTL	FIND MINIMUM ENTRY IN LIST
	SEARCH	FORPRM

COMMENT	%

WRITTEN BY NORM GRANT. W.M.U.

USAGE		CALL MINIMUM(ARRAY,NUM,ANS)
	WHERE	ARRAY	IS ARRAY FROM WHICH TO SELECT MINIMUM.
		NUM	SIZE OF ARRAY(>=1)
		ANS	MINIMUM(SAME MODE AS ARRAY)

%


	HELLO	(MINIMU, )	;MINIMUM ENTRY
	MOVE	2,@1(16)
	MOVE	0,@0(16)
	SOJLE	2,DONE
	MOVEI	1,@0(16)
	AOJ	1,
	CAMLE	0,0(1)
	MOVE	0,0(1)
	SOJG	2,.-3
DONE:	MOVEM	0,@2(16)
	GOODBY	(3)
	PRGEND
TITLE	PEEK
SUBTTL	SUBROUTINE TO EXAMINE MONITOR.
	SEARCH	FORPRM

COMMENT	%

WRITTEN BY NORM GRANT. W.M.U.

USAGE		CALL PEEK(IEXEC,IWORD)
	WHERE	IEXEC:	IS EXECUTIVE ADDRESS TO BE EXAMINED.
		IWORD:	IS CONTENTS OF IEXEC.

%

OPDEF	PEEK	[CALLI	33]



	HELLO	(PEEK, )	;PEEK ENTRY
	MOVE	0,@0(16)
	PEEK
	MOVEM	0,@1(16)
	GOODBY	(2)
	PRGEND
	TITLE	RESTART
SUBTTL	RESTART PROGRAM
	SEARCH	FORPRM
	ENTRY	RESTAR

COMMENT	%

	WRITTEN BY NORM GRANT.  W.M.U. MARCH 8,1971.
	PURPOSE	TO IMMEDIATELY RESTART A PROGRAM FROM ANY POINT WITHIN IT.

USAGE		CALL RESTART

%
RESTAR:
IFN F40LIB,<	JFCL		;PERMIT BOTH F40 AND F10 ENTRIES>
	HRRZ	1,.JBSA##
	JRST	0(1)
	PRGEND
	TITLE RNTIME
SUBTTL GET PROGRAM RUN TIME, IN MS.
	SEARCH	FORPRM

COMMENT	%


WRITTEN BY NORM GRANT.  W.M.U.

USAGE	CALL RNTIME(ITIME)
	WHERE	ITIME:	IS RUNTIME OF JOB, TO PRESENT, IN MILLISECONDS.(RETURNED)
%


	HELLO	(RNTIME, )	;RNTIME ENTRY
	SETZ	0,
	RUNTIM	0,
	MOVEM	0,@0(16)
	GOODBY	(1)
	PRGEND
	TITLE	RUNUUO
	SUBTTL MIMIC CONCISE COMMAND LANGUAGE

;	WRITTEN BY NORM GRANT. W.M.U

	ENTRY RUNUUO

COMMENT	%

	USAGE		CALL RUNUUO(COMMAND)
	WHERE	COMMAND:	IS ASCII COMMAND STRING, 200 CHARACTERS
		OR LESS; MUST END WITH ZERO WORD.(IF COMMAND STRING IS
		LITERAL ENCLOSED IN QUOTES IN CALL STATEMENT, WILL DO SO
		AUTOMATICALLY.)
	VALID COMMANDS ARE   R,RUN,EXECUTE,DEBUG,LOAD,COMPILE,MAKE,TECO,
	CREATE,EDIT,RENAME,DELETE,TYPE,LIST,COPY,PRESERVE,PROTECT,REWIND,
	UNLOAD,ZERO,SKIP,BACKSPACE,EOF,LABEL AND THEIR
	STANDARD ABBREVIATIONS.

%

POINTA:	POINT	7,BUFFER,
POINTS:	POINT	6,FX+1,
COUNT=1
LIM=2
SVCNT=3
FLAG=4
NUM=6
POINT=10
POINT1=11
CH=12
Q=16
P=17

BLOCK:	SIXBIT/SVC/
	IOWD	1,BUFFER
OBUF:	BLOCK	3
BUFFER:	BLOCK	^D40
NAME:	SIXBIT/000SVC/
	SIXBIT/TMP/
	0
	0
RUNUUO:	JFCL			;PERMIT BOTH F40 AND F10 ENTRIES
	SETZ	FLAG,
RUNUU1:	RESET
	MOVEI	POINT,@0(16)
	HRLI	POINT,440700		;440700=(POINT 7,0,)
	MOVE	POINT1,POINTA
	SETZM	BUFFER
	MOVE	0,[XWD	BUFFER,BUFFER+1]
	BLT	0,BUFFER+^D39
	SETZ	1,
LOOP:	PUSHJ	P,GETCHR
	JUMPE	CH,ERMSG
	CAIN	CH," "
	JRST	LOOP
	CAIN	CH,"R"
	JRST	RUNR
	CAIA
LOOP1:	PUSHJ	P,GETCHR
	JUMPE	CH,TRAN
	IDPB	CH,POINT1
	JRST	LOOP1
TRAN:	MOVE	SVCNT,COUNT
	ADDI	COUNT,4
	IDIVI	COUNT,5
	MOVNS	COUNT
	HRLM	COUNT,BLOCK+1
	MOVE	0,[XWD	3,BLOCK]
	TMPCOR
	JRST	DSKIT
RUNS:	MOVE	0,[XWD	1,E]
	JRST	GET1
DSKIT:	INIT	0,0
	SIXBIT/DSK/
	XWD	OBUF,0
	JRST	NOGO
	PJOB
	IDIVI	0,^D10
	DPB	1,[POINT 4,NAME,17]
	IDIVI	0,^D10
	DPB	1,[POINT 4,NAME,11]
	DPB	0,[POINT 4,NAME,5]
	ENTER	0,NAME
	JRST	NOGO
	MOVE	POINT,POINTA
LOOP2:	SOSG	OBUF+2
	OUTPUT	0,
	PUSHJ	P,GETCHR
	IDPB	CH,OBUF+1
	SOJG	SVCNT,LOOP2
	CLOSE	0,
	JRST	RUNS
NOGO:	OUTSTR	[ASCIZ/CANNOT ENTER TMP FILE!
/]
	EXIT
RUNR:	JUMPN	FLAG,LOOP1+1
	SETO	FLAG,
	MOVE	POINT1,POINTS
	MOVEI	LIM,6
	PUSHJ	P,GETCHR
	CAIN	CH," "
	JRST	R
	CAIE	CH,"U"
	JRST	RUNUU1
	PUSHJ	P,GETCHR
	CAIN	CH,"N"
	PUSHJ	P,GETCHR
	CAIE	CH," "
	JRST	RUNUU1
	SOS	POINT1
	SETZM	FX
	PUSHJ	P,LOOP4
LOOP6:	CAIE	CH," "
	CAIN	CH,":"
	JRST	NEXT
	CAIE	CH,"."		;PREMATURE EXTENSION?
	CAIN	CH,"["		;OR PROJECT PROGRAMMER?
	JRST	DEVFAL		;YES, USE DEFAULT DEVICE, THAT WAS FILENAME.
	JUMPE	CH,DEVFAL	;SAME IF END OF STRING.
	JRST	ERMSG		;ERROR IF NONE OF ABOVE.
NEXT:	MOVEI	LIM,6
	MOVE	POINT1,POINTS
	PUSHJ	P,LOOP3
	SKIPN	FX+1		;NULL NAME?
	JRST	DEVFAL		;YES, SO DEVICE WAS FILENAME.
NEXT1:	CAIN	CH,"."
	JRST	EXTEND
EXEN:	JUMPE	CH,ENDS
	CAIN	CH,"["
	JRST	LL2
	CAIE	CH," "
	JRST	ERMSG		;BAD SYNTAX.
	PUSHJ	P,GETCHR
	JRST	EXEN

DEVFAL:	MOVSI	5,'DSK'		;DEFAULT DEVICE IS DSK.
	EXCH	5,FX		;AND THAT WAS A FILENAME.
	MOVEM	5,FX+1		;SO PUT IT WHERE IT BELONGS.
	JRST	NEXT1		;AND GO CHECK FOR EXTENSION.

ERMSG:	OUTSTR	[ASCIZ/Command error: /]
	OUTSTR	@0(16)		;USERS COMMAND
	OUTSTR	[BYTE (7)15,12]	;CRLF
	EXIT
EXTEND:	MOVEI	LIM,3
	MOVE	POINT1,[POINT	6,FX+2,]
	PUSHJ	P,LOOP5
	JRST	EXEN
LL2:	SETZ	NUM,
LL3:	PUSHJ	P,GETCHR
	CAIE	CH," "
	CAIN	CH,"]"
	JRST	ENDNUM
	CAIN	CH,","
	JRST	FNUM
	CAIG	CH,"7"
	CAIGE	CH,"0"
	JRST	ERMSG
	LSH	NUM,3
	ADDI	NUM,-"0"(CH)
	JRST	LL3
FNUM:	HRLZM	NUM,FX+4
	JRST	LL2
ENDNUM:	HRRM	NUM,FX+4
	JRST	ENDS
R:	PUSHJ	P,LOOP3
	MOVSI	0,'SYS'
	MOVEM	0,FX
ENDS:	MOVEI	0,F
GET1:	MOVE	3,[XWD	GETX,GET]
	BLT	3,GETEND
	JRST	GET
LOOP3:	SETZM	FX+1
	MOVE	3,[XWD	FX+1,FX+2]
	BLT	3,FX+5
LOOP4:	PUSHJ	P,GETCHR
	CAIN	CH," "		;BLANKS
	JRST	LOOP4		;ARE IGNORED HERE
	SKIPA
LOOP5:	PUSHJ	P,GETCHR		;SCAN UNTIL WE FIND BAD CHARACTER.
	CAIGE	CH,"0"
	POPJ	P,
	CAIG	CH,"9"
	JRST	OK
	CAIL	CH,"A"
	CAILE	CH,"Z"
	POPJ	P,
OK:	JUMPLE	LIM,.+3		;DON'T DEPOSIT IF ALREADY HAVE ENOUGH.
	ADDI	CH,40
	IDPB	CH,POINT1
	SOJA	LIM,LOOP5
GETCHR:	ILDB	CH,POINT
	CAIL	COUNT,^D200
	SETZ	CH,
	AOJ	COUNT,
	CAIN	CH,11
	MOVEI	CH," "
	POPJ	P,
GETX:	PHASE	140
GET:	MOVE	1,[XWD 1,777]
	CORE	1,
	JFCL
	RUN	0,
SPHASE:	HALT	.
	DEPHASE
FX:	PHASE	SPHASE+1
F:	0
	0
	0
	0
	0
	0
E:	SIXBIT/SYS/
	SIXBIT/COMPIL/
	0
	0
	0
GETEND:	0
	DEPHASE
	PRGEND
	TITLE SIZE OF OVERLAY  IN CHAINB
	SEARCH	FORPRM
	HELLO	(SIZE, )
	MOVE	1,@0(16)
	HLRE	0,OVTAB##-1(1)
	MOVMM	0,@1(16)
	GOODBY	(2)
	PRGEND
	TITLE	SLEEP
	SEARCH	FORPRM

OPDEF	SLEEP[CALLI	31]

COMMENT	%

WRITTEN BY NORM GRANT. WMU. SEPTEMBER 2,1971.

PURPOSE:	TO FORCE JOB TO SLEEP.

USAGE		CALL SLEEP(ISEC)
	WHERE	ISEC:	MINIMUM NUMBER OF SECONDS TO SLEEP.(MAY SLEEP
			LONGER)(INTEGER.)

%


MIDNIT:	EXP	^D24*^D3600*^D1000	;MILLISECONDS PER DAY
ARGBLK:	2			;CLOCK FUNCTION
	BLOCK	1

	HELLO	(SLEEP, )	;SLEEP ENTRY
	MOVE	1,@0(16)
	JUMPLE	1,NOWAIT
	IMULI	1,^D1000
	MSTIME	3,
	ADD	3,1		;GET FINAL TIME (MAY BE DAYS)
	IDIV	3,MIDNIT	;SO GET NUMBER OF DAYS
	DATE	2,		;CURRENT DATE
	ADD	3,2		;FINAL DATE
RESLP:	PUSH	P,1
	IDIVI	1,^D1000	;GET SECONDS
	MOVEM	1,ARGBLK+1
	POP	P,1
	MOVEI	0,ARGBLK	;ASSUME DAEMON
	CAILE	1,^D60000	;.LT. ONE MINUTE?
	DAEMON	0,		;NO. TRY DAEMON
	 JRST	USEHIB		;USE STRAIGHT HIBER
	SETZ	1,		;INFINITE HIBER
USEHIB:	CAILE	1,^D60000	;MAX OF ONE MINUTE
	MOVEI	1,^D60000	;DO IT ONE MINUTE AT TIME
	HIBER	1,		;HIBER.
	 JRST	USESLP		;DAMN
CHECK:	DATE	2,		;GET NEW DATE
	MSTIME	0,		;GET NEW TIME
	CAMLE	2,3		;PAST DATE?
	 JRST	NOWAIT		;YES
	CAMN	2,3		;SAME DATE?
	CAMGE	0,4		;YES. PAST TIME?
	 JRST	NEWSLP		;NO. MORE WAITING
NOWAIT:	GOODBY	(1)

NEWSLP:	MOVN	1,2
	ADD	1,3		;DATEF-DATE
	IMUL	1,MIDNIT	;TIMES MILLISECONDS/DAY
	ADD	1,4		;PLUS TIMEF
	SUB	1,0		;MINUS TIME
	JRST	RESLP

USESLP:	IDIVI	1,^D1000	;MUST USE SLEEP
	SLEEP	1,
	JRST	CHECK		;ARE WE THROUGH

	PRGEND
	TITLE	TRMOPS
	SEARCH	FORPRM

COMMENT	%

	USAGE	CALL REDTTY(IFUNCT,IVAL,IERR)
		TO READ FUNCTION IFUNCT INTO IVAL

	USAGE	CALL SETTTY(IFUNCT,IVAL,IERR)
		TO SET FUNCTION IFUNCT FROM IVAL
	IERR IS AN ERROR CODE
		0	OK
		-1	NOT ON TTY
		1	FUNCTION NOT IMPLEMENTED
		2	PRIVILEGED FUNCTION
		3	ARGUMENT OUT OF RANGE
		4	ARGUMENT LIST LENGTH OR ADDRESS ILLEGAL(ERROR IN SUBROUTINE)
		5	DATASET ACTIVITY ON NON DATASET
		6	??
		7	SUBFUNCTION FAILED
		8	TERMINAL NOT AVAILABLE

     FOR LIST OF FUNCTIONS, SEE TRMOP. UUO IN MONITOR CALLS MANUAL.
ALL FUNCTION CODES ARE IN RANGE 0-777(BASE EIGHT)
%

FUNCT:	BLOCK	1		;FUNCTION
UDX:	BLOCK	1		;TTY UDX
VAL:	BLOCK	1		;ARGUMENT
	HELLO	(REDTTY)
	MOVEI	0,1000		;READ BIT
	JRST	TRMOPS

	HELLO	(SETTTY)
	MOVEI	0,2000		;WRITE BIT
	MOVE	1,@1(16)	;GET VALUE
	MOVEM	1,VAL	;STORE IT
TRMOPS:	SKIPL	1,@0(16)	;PICK UP FUNCTION
	CAILE	1,777		;AND RANGE CHECK IT
	 JRST	ERR0		;ILL FUNCTION
	IOR	1,0		;PUT IN READ/WRITE BIT
	MOVEM	1,FUNCT		;STORE IT
	PJOB	1,		;GET OUT JOB NUMBER
	TRMNO.	1,		;GET UDX
	 JRST	ERRM1		;OOPS?
	MOVEM	1,UDX		;STORE IT
	MOVE	1,[XWD 3,FUNCT]	;ARGUMENT
	TRMOP.	1,		;DO FUNCTION
	 JRST	WHATER		;OOPS
	MOVE	0,FUNCT		;GET FUNCTION BACK
	TRNE	0,1000		;READ?
	MOVEM	1,@1(16)	;YES. RETURN ANSWER
	SETZ	1,		;SET NO ERROR
RETFIN:	MOVEM	1,@2(16)	;RETURN ERROR CODE
	GOODBY	(3)		;RETURN

ERRM1:	SKIPA	1,[-1]		;ERROR MINUS ONE
ERR0:	MOVEI	1,1		;ERROR ONE
	JRST	RETFIN		;RETURN IT
WHATER:	CAMN	1,[XWD 3,FUNCT]	;UNIMPLEMENTED UUO?
	SETZ	1,		;YES. PRETEND NO SUCH FUNCTION
	AOJA	1,RETFIN	;INCREMENT AND RETURN
	PRGEND
	TITLE	TRUTH
SUBTTL	PROGRAM TO MAINTAIN AND TEST COMPRESSED TRUTH TABLES.
REMARK	WRITTEN BY NORM GRANT. W.M.U. OCTOBER 11,1971.
	SEARCH	FORPRM

COMMENT	%

USAGE		CALL TRUTH(TABLE,IFUNCT,IENTRY,VALUE)

	WHERE	TABLE:	IS TRUTH TABLE.
		IFUNCT:	IS FUNCTION TO BE PERFORMEED.
			IF IFUNCT=0, TEST TABLE ENTRY.
			IF IFUNCT#0, SET TABLE ENTRY TO VALUE.
		IENTRY:	NUMBER OF ENTRY TO BE TESTED OR SET.
		VALUE:	VALUE OF ENTRY, IF IFUNCT=0.
			VALUE TO SET ENTRY TO IF IFUNCT#0.
	(# MEANS NOT EQUAL.)

PURPOSE:	TO COMPRESS A LARGE TRUTH TABLE INTO LITTLE SPACE.
	FOR EXAMPLE, A 360 ENTRY TABLE WOULD OCCUPY 10 WORDS.

%


	HELLO	(TRUTH, )	;TRUTH ENTRY
	MOVE	1,@2(16)
	SUBI	1,1		;BITS RUN 0-35
	IDIVI	1,^D36
	MOVNS	2		;GET NEGATIVE OF REMAINDER
	ADDI	1,@0(16)
	MOVE	0,0(1)
	MOVE	3,@1(16)
	MOVEI	5,1
	ROT	5,0(2)
	JUMPE	3,TEST
	SKIPL	@3(16)
	TDZA	0,5
	TDO	0,5
	MOVEM	0,0(1)
	GOODBY	(4)
TEST:	SETZ	4,
	TDNE	0,5
	SETO	4,
	MOVEM	4,@3(16)
	GOODBY	(4)
	PRGEND
	TITLE	TTYNAM
	SEARCH	FORPRM

COMMENT	%

WRITTEN BY NORM GRANT. W.M.U.

USAGE			CALL TTYNAM(NAME)
	WHERE	NAME	IS PHYSICAL NAME OF USER'S TTY.

%


	HELLO	(TTYNAM, )	;TTYNAM ENTRY
	LDB	1,[POINT 4,0(16),12]
	PUSHJ	P,TYPE..##	;CHECK SINGLE/DOUBLE WORD ARG
	MOVEI	2,@0(16)	;ADDR OF ARG WORD
	MOVE	1,[ASCII "     "]
	MOVEM	1,(2)		;BLANK OUT WORD
	CAILE	0,5		;SINGLE WORD ARG?
	MOVEM	1,1(2)		;NO. TWO WORD
	HRLI	2,440700	;SET UP BYTE POINTER
	GETLIN	4,
LOOP:	SETZ	3,
	LSHC	3,6
	ADDI	3,40
	IDPB	3,2
	JUMPN	4,LOOP
	GOODBY	(1)
	PRGEND
	TITLE	TTYPTY
SUBTTL	CHECK FOR TTY/PTY
	SEARCH	FORPRM

COMMENT	%

USAGE			CALL TTYPTY(ICODE)
	WHERE	ICODE	IS CODE FOR TELETYPE OR PSUEDO-TELETYPE.
			ICODE=0  TELETYPE.
			ICODE=-1  PSEUDO-TELETYPE.

	WRITTEN BY NORM GRANT.	WMU. APRIL 1,1971.
	THIS PROGRAM DETERMINES WHETHER PROGRAM IS RUNNING
	FROM TTY OR PTY,AND RETURNS THE APPROPRIATE CODE.
%


	HELLO	(TTYPTY, )	;TTYPTY ENTRY
	SETZM	@0(16)
	SETO	0,	;MAKE LINE NEGATIVE.
	GETLCH	0	;GET LINE CHARACTERISTICS.
	SKIPGE	0
	SETOM	@0(16)	;CONSOLE IS PTY. THEREFORE BATCH.
	GOODBY	(1)
	PRGEND
	TITLE	MINVSQ
	SUBTTL	INVERSE	MATRIX	PROGRAM.
	SEARCH	FORPRM

COMMENT	%
	WRITTEN BY NORM GRANT. WMU. DECEMBER 23, 1970.
	PROGRAM INVERTS A SQUARE MATRIX WITHIN ITSELF.
;
;
	USAGE	CALL MINVSQ(A,N,TOL,MC,MR,NDIM,IOUT,METHOD,DET,IEXP)
	WHERE	A:	MATRIX TO BE INVERTED.
		N:	NUMBER OF ROWS(COLUMNS)IN MATRIX.
		TOL:	TOLERANCE FOR INVERSE(IF LARGEST AVAILABLE
			PIVOT(IN ABS.)IS LESS THAN .000001*TOL,
			INVERSE IS CONSIDERED NOT TO EXIST).
		MC:	BOOK-KEEPING VECTOR(AT LEAST N LONG)
		MR:	BOOK-KEEPING VECTOR(AT LEAST N LONG)
		NDIM:	DIMENSION OF MATRIX A IN MAINLINE(NDIM BY NDIM)
		IOUT:	OUTPUT DEVICE SPECIFICATION FOR ERROR MESSAGES.
		METHOD:	SWITCH FOR SELECTING PIVOT METHOD.
			=0  LEAST ACCURATE(FASTEST)USES FIRST NON-ZERO.
			=1  COMPROMISE.USES LARGEST REMAINING IN ROW.
			=2  MOST ACCURATE(SLOWEST)USES LARGEST REMAINING.
		DET:	DETERMINENT OF MATRIX A(CHARACTERISTIC ONLY).
		IEXP:	POWER OF 10 OF DETERMINENT.

%

	K=15
	J=14
	I=13
	II=12
	JJ=11
	KK=10
	LL=7
	KI=6
	KKK=5


	HELLO	(MINVSQ, )	;MINVSQ ENTRY
	MOVEM	15,TEMP.
	MOVEM	16,TEMP.+1
	MOVEI	0,TEMP.+1
	PUSH	0,@1(16)
	PUSH	0,@2(16)
	PUSH	0,@5(16)
	PUSH	0,@6(16)
	PUSH	0,@7(16)
;
M0:	MOVEI	2,@3(16)	;SET UP BASE ADDRESSES OF ARRAYS.
	SOJ	2,
	HRRM	2,MC1
	HRRM	2,MC2
	HRRM	2,MC3
;
	MOVEI	2,@4(16)
	SOJ	2,
	HRRM	2,MR1
	HRRM	2,MR2
	HRRM	2,MR3
;
	MOVEI	2,@0(16)
	SOJ	2,
	HRRM	2,A1
	HRRM	2,A3
	HRRM	2,A4
	HRRM	2,A5
	HRRM	2,A6
	HRRM	2,A8
	HRRM	2,A9
	HRRM	2,A10
	HRRM	2,A11
	HRRM	2,A12
	HRRM	2,A14
	HRRM	2,A15
	HRRM	2,A16
	HRRM	2,A17
	HRRM	2,A18
	HRRM	2,A19
	HRRM	2,A21
	HRRM	2,A22
	HRRM	2,A23
	HRRM	2,A24
	HRRM	2,A26
	HRRM	2,A27
	HRRM	2,A28
;
;
;	INITIALIZE ZTOL,DET,AND BOOK-KEEPING ARRAYS.
;
	MOVE	2,[1.E-6]
	FMPR	2,TOL
	MOVEM	2,ZTOL#
	MOVSI	2,201400
	MOVEM	2,DET
	SETZM	IEXP
	MOVEI	I,1
M3:MR1:	MOVEM	I,777777(I)
MC1:	MOVEM	I,777777(I)
	CAMGE	I,N
	AOJA	I,M3
	MOVEI	2,1
	MOVEM	2,KSGN#
;
;	BEGIN MAIN INVERSION LOOP.
;
	MOVN	KK,NDIM
$7:	MOVEI	K,1
M4:	ADD	KK,NDIM
	MOVE	2,N
	MOVEM	2,NL#
;
;	SELECT PIVOT METHOD AND THEN PIVOT ELEMENT.
;
	MOVNI	2,1
	ADD	2,METHOD
	JUMPL	2,$4
	JUMPG	2,$2
$3:	MOVEM	K,NL
$2:	SETZM	AMAX#
	MOVE	JJ,KK
	SUB	JJ,NDIM
	MOVE	J,K
M6:	ADD	JJ,NDIM
	MOVE	I,K
M8:	MOVE	2,I
	ADD	2,JJ
	MOVEM	2,IJ#
A1:	MOVM	0,777777(2)
	CAMG	0,AMAX
	JRST	$5
	MOVEM	0,AMAX
	MOVEM	I,NR#
	MOVEM	J,NC#
$5:	CAMGE	I,NL
	AOJA	I,M8
$6:	CAMGE	J,N
	AOJA	J,M6
	JRST	$10
$4:	MOVE	II,KK
	SUB	II,NDIM
	MOVE	I,K
M12:	ADD	II,NDIM
	MOVE	KI,K
	ADD	KI,II
A3:	MOVM	0,777777(KI)
	CAMLE	0,ZTOL
	JRST	$11
$62:	CAMGE	I,N
	AOJA	I,M12
$13:	MOVE	0,IOUT
	JUMPE	0,M16
	MOVEI	16,%1M
	PUSHJ	P,OUT.##
	MOVEI	16,%2M
	PUSHJ	P,IOLST.##
M16:	SETZM	DET
	SETZM	IEXP
	JRST	M17
$11:A4:	MOVE	2,777777(KI)
	MOVEM	2,AMAX
	MOVEM	K,NR
	MOVEM	I,NC
$10:	MOVM	0,AMAX
	CAMG	0,ZTOL
	JRST	$13
	CAMN	K,NR	;SEE IF IN SAME ROW.
	JRST	$9
	MOVNS	0,KSGN	;IF NOT, CHANGE SIGN ON DETERMINENT.
	MOVE	3,NR
MR2:	MOVEM	3,777777(K)
	MOVN	JJ,NDIM
	MOVEI	J,1
M19:	ADD	JJ,NDIM
	MOVE	2,K
	ADD	2,JJ
	MOVE	4,JJ
	ADD	4,NR
A5:	MOVE	0,777777(2)	;AND SWITCH ROWS.
A6:	EXCH	0,777777(4)
A8:	MOVEM	0,777777(2)
	CAMGE	J,N
	AOJA	J,M19
$9:	CAMN	K,NC	;SEE IF IN SAME COLUMN.
	JRST	$22
	MOVNS	0,KSGN	;IF NOT, CHANGE SIGN ON DETERMINENT.
	MOVE	3,NC
MC2:	MOVEM	3,777777(K)
	SUBI	3,1
	IMUL	3,NDIM
	MOVEM	3,NCNC#
	MOVEI	J,1
M21:	MOVE	2,KK
	ADD	2,J
	MOVE	4,NCNC
	ADD	4,J
A9:	MOVE	0,777777(2)	;AND SWITCH COLUMNS.
A10:	EXCH	0,777777(4)
A11:	MOVEM	0,777777(2)
	CAMGE	J,N
	AOJA	J,M21
$22:	MOVE	KKK,KK
	ADD	KKK,K
A12:	MOVE	0,777777(KKK)
	MOVEM	0,D#	;STORE PIVOT ELEMENT.
	FMPRB	0,DET	;MULTIPLY DETERMINENT BY PIVOT.
	JUMPE	0,$13
$205:	MOVM	0,DET
	CAMGE	0,[10.]
	JRST	$200
	MOVE	2,DET
	FDVR	2,[10.]
	MOVEM	2,DET
	AOS	IEXP
	JRST	$205
$200:	MOVM	0,DET
	CAML	0,[1.]
	JRST	$210
	MOVSI	2,204500
	FMPRM	2,DET
	SOS	IEXP
	JRST	$200
$210:	MOVEI	I,1
M23:	MOVE	2,I
	ADD	2,KK
$30:A14:MOVE	0,777777(2)	;DIVIDE COLUMN BY PIVOT.
	FDVR	0,D
A15:	MOVEM	0,777777(2)
	CAMGE	I,N
	AOJA	I,M23
	MOVSI	2,201400
	FDVR	2,D
A16:	MOVEM	2,777777(KKK)	;PIVOT=1./PIVOT.
;
;	BEGIN MAIN REDUCTION LOOP FOR REST OF MATRIX.
;
	MOVN	II,NDIM
	MOVEI	I,1
M24:	ADD	II,NDIM
	MOVE	KI,K
	ADD	KI,II
A17:	MOVE	0,777777(KI)
	JUMPE	0,$40
	MOVEM	0,C#
	CAMN	I,K
	JRST	$40
;
;	BEGIN INNERMOST REDUCTION LOOP.
;
$41:	MOVEI	J,1
M27:	MOVE	2,J
	ADD	2,II
	MOVE	4,J
	ADD	4,KK
	MOVN	0,C
A18:	FMPR	0,777777(4)
A19:	FADRM	0,777777(2)	;A(J,I)=A(J,I)-C*A(J,K)
$50:	CAMGE	J,N
	AOJA	J,M27
;
;	END OF INNERMOST LOOP.
;
	MOVE	2,C
	FDVR	2,D
A21:	MOVNM	2,777777(KI)	;A(K,I)=-C/D
$40:	CAMGE	I,N
	AOJA	I,M24
;
;	END OF MAIN REDUCTION LOOP.
;
$100:	CAMGE	K,N
	AOJA	K,M4
;
;	END OF MAIN INVERSION LOOP.
;
	MOVE	0,KSGN
	FSC	0,233		;FLOAT NUMBER
	FMPRM	0,DET
;
;	NOW SORT COLUMNS INTO CORRECT ORDER.
;
	MOVE	K,N
M28:MC3:MOVE	2,777777(K)
	MOVEM	2,L#
	CAMN	K,L
	JRST	$155
$150:	MOVE	II,N
	IMUL	II,NDIM
	MOVE	I,N
M31:	SUB	II,NDIM
	MOVE	3,II
	ADD	3,L
	MOVE	2,K
	ADD	2,II
A22:	MOVE	0,777777(3)
A23:	EXCH	0,777777(2)
A24:	MOVEM	0,777777(3)
	SOJG	I,M31
$155:	SOJG	K,M28
;
;	NOW SORT ROWS INTO ORDER.
;
	MOVE	KK,N
	IMUL	KK,NDIM
	MOVE	K,N
M32:	SUB	KK,NDIM
MR3:	MOVE	2,777777(K)
	MOVEM	2,L
	SUB	2,K
	JUMPE	2,$175
$180:	MOVNI	LL,1
	ADD	LL,L
	IMUL	LL,NDIM
	MOVEI	I,1
M35:	MOVE	2,I
	ADD	2,LL
	MOVE	4,I
	ADD	4,KK
A26:	MOVE	0,777777(2)
A27:	EXCH	0,777777(4)
A28:	MOVEM	0,777777(2)
	CAMGE	I,N
	AOJA	I,M35
$175:	SOJG	K,M32
;
;	RETURN!
;
M17:	MOVE	15,TEMP.
	MOVE	16,TEMP.+1
	HRROI	0,TEMP.+10
	POP	0,@11(16)
	POP	0,@10(16)
	GOODBY	(12)

%1M:	20,,IOUT
	0
	0
	340,,[ASCII "('0',I4,' BY',I4,' INVERSE DOES NOT EXIST.'//)"]
	12
	0
%2M:	1100,,N
	1100,,N
	4000,,0
TEMP.:	BLOCK	2
N:	0
TOL:	0
NDIM:	0
IOUT:	0
METHOD:	0
DET:	0
IEXP:	0
	PRGEND
	TITLE XPRODH
	SUBTTL CROSS-PRODUCT MATRIX SUBROUTINE.
	SEARCH	FORPRM

COMMENT	%

	WRITTEN BY NORMAN GRANT. WMU. DECEMBER 16,1970.
	GENERATES LOWER CORNER CROSS-PRODUCTS ONLY.
	USAGE		CALL XPRODH(X,SX,SXX,N,NDIM)
		WHERE	X: IS SET OF OBSERVATIONS.(1-DIMENSIONAL ARRAY)
			SX: IS SUMS OF VARIABLES.(1-DIMENSIONAL ARRAY)
			SXX: IS SUMS OF CROSS-PRODUCTS.(2-DIMENSIONAL)
			N: IS NUMBER OF VARIABLES.
			NDIM: IS DIMENSION OF SXX.(SXX(NDIM,NDIM)  )

%

SXX=0
XIXJ=1
XI=2
J=3
I=4

	HELLO	(XPRODH, )	;XPRODH ENTRY
	MOVEI	0,N-1		;INIT PUSH DOWN LIST TO GET ARGS
	PUSH	0,@3(16)	;GET N
	PUSH	0,@4(16)	;GET NDIM
	MOVEI	SXX,@2(16)	;GET ADR OF SXX
	SOJ	SXX,		;MINUS ONE

	MOVEI	1,@0(16)	;GET BASE FOR X
	SOJ	1,
	HRRM	1,L1
	HRRM	1,L2

	MOVEI	1,@1(16)	;GET BASE FOR SX
	SOJ	1,
	HRRM	1,SX1		;AND STORE

	MOVEI	I,1		;SET INDEX OF OUTER LOOP TO 1
L1:	MOVE	XI,777777(I)	;SET VALUE OF X(I)
SX1:	FADRM	XI,777777(I)	;SX(I)=SX(I)+X(I).
	MOVE	J,I		;SET COUNTER ON INNER LOOP
	HRRM	SXX,SXX1	;SET BASE ADDR INTO ARRAY
L2:	MOVE	XIXJ,777777(J)	;GET X(J)
	FMPR	XIXJ,XI		;X(I)*X(J)
SXX1:	FADRM	XIXJ,777777(J)	;SXX(J,I)=SXX(J,I)+X(I)*X(J)
	CAMGE	J,N		;END OF KNNER LOOP?
	AOJA	J,L2		;NO. INCREMENT AND REPEAT
	ADD	SXX,NDIM	;MOVE TO NEXT COLUMN OF SXX
	CAMGE	I,N		;END OF OUTER LOOP?
	AOJA	I,L1		;INCREMENT I AND JUMP TO BEGINNING OUTER LOOP
	GOODBY	(5)		;RETURN TO CALLING PROGRAM
N:	0
NDIM:	0
	PRGEND
	TITLE XPRODP
	SUBTTL CROSS-PRODUCT MATRIX SUBROUTINE.
	SEARCH	FORPRM

COMMENT	%

	WRITTEN BY NORMAN GRANT. WMU. DECEMBER 16,1970.
	GENERATES UPPER CORNER CROSS-PRODUCTS ONLY.(BY COLUMN)
	(STORED IN CLOSE PACKED FORMAT)
	USAGE		CALL XPRODP(X,SX,SXX,N)
		WHERE	X: IS SET OF OBSERVATIONS.(1-DIMENSIONAL ARRAY)
			SX: IS SUMS OF VARIABLES.(1-DIMENSIONAL ARRAY)
			SXX: IS SUMS OF CROSS-PRODUCTS.(2-DIMENSIONAL)
			(IN CLOSE PACKED UPPER TRIANGULAR FORM.)
			N: IS NUMBER OF VARIABLES.

%

N=1
SXX=2
XI=3
XIXJ=4
J=5
I=6

	HELLO	(XPRODP, )	;XPRODP ENTRY
	MOVE	N,@3(16)	;GET VALUE OF N
	MOVEI	0,@0(16)	;GET BASE ADDR FOR X
	SOJ	0,
	HRRM	0,X1
	HRRM	0,X2

	MOVEI	0,@1(16)	;GET BASE ADDR FOR SX
	SOJ	0,
	HRRM	0,SX1
	MOVEI	SXX,@2(16)

	MOVEI	I,1		;SET INDEX OF OUTER LOOP TO 1
L1:X1:	MOVE	XI,777777(I)	;GET X(I)
SX1:	FADRM	XI,777777(I)	;SX(I)=SX(I)+X(I)
	MOVEI	J,1		;SET INDEX OF INNER LOOP TO 1
L2:	AOJ	SXX,		;INCREMENT ADDR INTO SXX
X2:	MOVE	XIXJ,777777(J)	;X(J)
	FMPR	XIXJ,XI		;X(I)*X(J)
SXX1:	FADRM	XIXJ,-1(SXX)	;SXX(J,I)=SXX(J,I)+X(I)*X(J)
	CAMGE	J,I		;END OF INNER LOOP?
	AOJA	J,L2		;NO. CONTINUE
	CAMGE	I,N		;END OF OUTER LOOP
	AOJA	I,L1		;NO. CONTINUE
	GOODBY	(4)		;RETURN TO CALLING PROGRAM
	PRGEND
	TITLE ZEROH
	SUBTTL PROGRAM TO ZERO MATRIX.
	SEARCH	FORPRM
COMMENT	%
	WRITTEN BY NORMAN GRANT. WMU. NOVEMBER 17,1970.
	USAGE		CALL ZEROH(A,A2,N,NDIM)

	WHERE		NDIM:	DIMENSION OF A2 IN CALLING PROGRAM.
			A:	A VECTOR OF NDIM ELEMENTS.
			A2:	AN NDIM BY NDIM ARRAY
			N:	NUMBER OF ROWS AND COMUMNS TO ZERO

%
	A=5
	A2=6
	N=7
	NDIM=10

	HELLO	(ZEROH, )	;ZEROH ENTRY
	MOVEI	A,@0(16)	;GET ADDRESS OF ARRAY A.
	MOVEI	A2,@1(16)	;GET ADDRESS OF MATRIX A2.
	MOVE	N,@2(16)	;GET VALUE OF N.
	MOVE	NDIM,@3(16)	;GET VALUE OF DIMENSION(NDIM).
	SETZM	0(A)		;ZERO FIRST ELEMENT OF A
	CAIG	N,1		;MORE THAN ONE ELEMENT?
	JRST	Z1		;NO.
	HRLZ	0,A		;SET UP BLT
	HRRI	0,1(A)		;A,,A+1
	MOVE	1,A		;A+N-1
	ADD	1,N		;...
	BLT	0,-1(1)
Z1:	MOVEI	1,-1(N)
	HRRM	1,B1		;UPPER LIMIT =N-1(A2+(I-1)*NDIM)
Z2:	HRRZ	0,A2		;SET UP BLT WORD
	HRL	0,A		;A,,A2+(I-1)*NDIM
B1:	BLT	0,-1(A2)
	ADD	A2,NDIM		;GET TO NEXT COLUMN
	SOJG	N,Z2		;N COLUMNS
	GOODBY	(4)		;RETURN TO CALLING PROGRAM.
	PRGEND
	TITLE ZEROP
	SUBTTL PROGRAM TO ZERO ARRAY.
	SEARCH	FORPRM

COMMENT	%

	WRITTEN BY NORMAN GRANT. WMU. JANUARY 6,1971.
	USAGE		CALL ZEROP(A,N)
	WHERE		A:	IS VECTOR TO BE ZEROED
			N:	IS NUMBER OF ELEMENTS TO ZERO

%

	A=1
	N=2

	HELLO	(ZEROP, )	;ZEROP ENTRY
	MOVEI	A,@0(16)	;GET ADDRESS OF ARRAY A.
	MOVE	N,@1(16)	;GET VALUE OF N.
	SETZM	0(A)
	CAIG	N,1
	GOODBY	(2)
	HRLZ	0,A
	HRRI	0,1(A)
	ADD	A,N
	BLT	0,-1(A)
	POPJ	P,
	PRGEND
TITLE	ACMSRT
	SEARCH	FORPRM

;AC DEFINITIONS
I=14
IJ=13
J=12
K=11
LL=10
M=7
T=6
TT=5
L=0

;			      SUBROUTINE ACMSRT(L,N)
;			C     SORT ARRAY L
;			C     ORDERING IS BY INTEGER SUBTRACTION
;			C     ARRAYS IU(K) LND IL(K) PERMIT SORTING UP TO 2**(K+1)-1 ELEMENTS
;			      DIMENSION L(1),IU(16),IL(16)
DIM==^D16
IU:	BLOCK	DIM
IL:	BLOCK	DIM
;			      INTEGER T,TT

;ENTRANCE CODE
	HELLO	(ACMSRT, )	;ACMSRT ENTRY
	MOVEI	0,@0(16)
	HRRM	0,LP1
	HRRM	0,LP2
	HRRM	0,LP3
	SOJ	0,
	HRRM	0,L1
	HRRM	0,L2
	HRRM	0,L3
	HRRM	0,L4
	HRRM	0,L6
	HRRM	0,L7
	HRRM	0,L8
	HRRM	0,L10
	HRRM	0,L11
	HRRM	0,L12
	HRRM	0,L14
	HRRM	0,L15
	HRRM	0,L16
	HRRM	0,L17
	HRRM	0,L18
	HRRM	0,L19
	HRRM	0,L20
	HRRM	0,L21
	HRRM	0,L22

;			      M=1
	MOVEI	M,1
;			      I=1
	MOVEI	I,1
;			      J=N
	MOVE	J,@1(16)
;			5     IF(I.GE.J) GO TO 70
$5:	CAML	I,J
	JRST	$70
;			10    K=I
$10:	MOVE	K,I
;			      IJ=(J+I)/2
	MOVE	IJ,I
	ADD	IJ,J
	ASH	IJ,-1
;			      T=L(IJ)
L1:	MOVE	T,L-1(IJ)
;			      IF(L(I).LE.T) GO TO 20
L2:	CAML	T,L-1(I)
	JRST	$20
;			      L(IJ)=L(I)
;			      L(I)=T
;			      T=L(IJ)
L3:	EXCH	T,L-1(I)
L4:	MOVEM	T,L-1(IJ)
;			20    LL=J
$20:	MOVE	LL,J
;			      IF(L(J).GE.T) GO TO 40
L6:	CAMG	T,L-1(J)
	JRST	$40
;			      L(IJ)=L(J)
;			      L(J)=T
;			      T=L(IJ)
L7:	EXCH	T,L-1(J)
L8:	MOVEM	T,L-1(IJ)

;			      IF(L(I).LE.T) GO TO40
L10:	CAML	T,L-1(I)
	JRST	$40
;			      L(IJ)=L(I)
;			      L(I)=T
;			      T=L(IJ)
L11:	EXCH	T,L-1(I)
L12:	MOVEM	T,L-1(IJ)
;			      GO TO 40
	JRST	$40
;			30    L(LL)=L(K)
L14:
$30:	MOVE	02,L-1(K)
L15:	MOVEM	02,L-1(LL)
;			      L(K)=TT
L16:	MOVEM	TT,L-1(K)
;			40    LL=LL-1
$40:	SOJ	LL,
;			      IF(L(LL).GT.T) GO TO 40
L17:	CAMGE	T,L-1(LL)

	JRST	$40
;			      TT=L(LL)
L18:	MOVE	TT,L-1(LL)
;			50    K=K+1
$50:	AOJ	K,
;			      IF(L(K).LT.T) GO TO 50
L19:	CAMLE	T,L-1(K)
	JRST	$50
;			      IF(K.LE.LL) GO TO 30
	CAMG	K,LL
	JRST	$30
;			      IF((LL-I).LE.(J-K)) GO TO 60
	MOVE	02,J
	SUB	02,K
	ADD	02,I
	CAML	02,LL
	JRST	$60
;			      IL(M)=I
	MOVEM	I,IL-1(M)
;			      IU(M)=LL
	MOVEM	LL,IU-1(M)
;			      I=K
	MOVE	I,K
;			      M=M+1
;			      GO TO80
	AOJA	M,$80
;			60    IL(M)=K
$60:	MOVEM	K,IL-1(M)
;			      IU(M)=J
	MOVEM	J,IU-1(M)
;			      J=LL
	MOVE	J,LL
;			      M=M+1
;			      GO TO 80
	AOJA	M,$80
;			70    M=M-1
$70:	SOJE	M,M3
;			      IF(M.EQ.0) RETURN
;			      I=IL(M)
	MOVE	I,IL-1(M)
;			      J=IU(M)
	MOVE	J,IU-1(M)
;			80    IF((J-I).GE.(11)) GO TO 10
$80:
IFG	<DIM-16>,<
	MOVE	02,J
	SUB	02,I
	CAIL	02,^D11>
IFLE	<DIM-16>,<
	CAIL	J,^D11(I)>
	JRST	$10
;			      IF(I.EQ.1) GO TO 5
	CAIN	I,1
	JRST	$5
;			      I=I-1
	SOJ	I,
;			90    I=I+1
$90:	AOJ	I,

;			      IF(I.EQ.J) GO TO 70
	CAMN	I,J
	JRST	$70
;			      T=L(I+1)
LP1:	MOVE	T,L(I)
;			      IF(L(I).LE.T) GO TO 90
L20:	CAML	T,L-1(I)
	JRST	$90
;			      K=I
	MOVE	K,I
;			100   L(K+1)=L(K)
L21:
$100:	MOVE	02,L-1(K)
LP2:	MOVEM	02,L(K)
;			      K=K-1
	SOJ	K,
;			      IF(T.LT.L(K)) GO TO 100
L22:	CAMGE	T,L-1(K)
	JRST	$100
;			      L(K+1)=T
LP3:	MOVEM	T,L(K)
;			      GO TO90
	JRST	$90
;			      END
M3:	GOODBY	(2)
	PRGEND
	TITLE SORT
	SUBTTL MERGE-SORT PROGRAM.
;
REMARK	PROGRAM ORIGINALLY WRITTEN IN FORTRAN BY DICK HOUCHARD. WMU.
REMARK	TRANSLATED TO MACRO FOR INCREASED EFFICIENCY BY NORM GRANT. WMU.
REMARK			DECEMBER 19,1970.
;
;
;	USAGE	CALL SORT(IA,N,JA,ISF,IFIELD,IW,IB,ITAG)
;	  WHERE	IA:	MATRIX TO BE SORTED.
;		N:	NUMBER OF ROWS FILLED IN MATRIX.
;		JA:	NUMBER OF COLUMS FILLED IN MATRIX.
;		ISF:	NUMBER OF SORT FIELDS.
;		IFIELD:	VECTOR TELLING WHICH COLUMN IN MOST MAJOR,
;			NEXT MOST,ETC.
;		IW:	NUMBER OF ROWS DIMENSIONED IN MATRIX.
;		IB:	WORKING STORAGE(AT LEAST 3N/2).
;		ITAG:	WORKING STORAGE(AT LEAST N).
;
	SEARCH	FORPRM
;
;
	I=15
	J=14
	M=13
	K=12
	MA=11
	MC=10
	MP=7
	JK=6
	IC=5
;
	HELLO	(SORT, )	;SORT ENTRY

	MOVEM	15,TEMP
	MOVEM	16,TEMP+1
	MOVEI	0,TEMP+1
	PUSH	0,@1(16)
	PUSH	0,@2(16)
	PUSH	0,@3(16)
	PUSH	0,@5(16)
;
M0:	MOVEI	2,@0(16)	;IA
	SOJ	2,
	HRRM	2,IA1
	HRRM	2,IA2
	HRRM	2,IA3
	HRRM	2,IA4
;
	MOVEI	2,@6(16)	;IB
	SOJ	2,
	HRRM	2,IB1
	HRRM	2,IB2
	HRRM	2,IB3
	HRRM	2,IB4
	HRRM	2,IB5
	HRRM	2,IB6
	HRRM	2,IB7
	HRRM	2,IB8
	HRRM	2,IB9
	HRRM	2,IB10
	HRRM	2,IB11
	HRRM	2,IB12
	HRRM	2,IB13
	HRRM	2,IB14
;
	MOVEI	2,@4(16)	;IFIELD
	SOJ	2,
	HRRM	2,IF1
;
	MOVEI	2,@7(16)	;ITAG
	SOJ	2,
	HRRM	2,IT1
	HRRM	2,IT2
	HRRM	2,IT5
	HRRM	2,IT6
	HRRM	2,IT7
;
M1:	MOVE	0,N
	IDIVI	0,2
	ADD	0,1
	MOVEM	0,KL#
	MOVEI	I,1
M3:	MOVE	2,KL
	ADD	2,I
IB1:	MOVEM	I,777777(2)
	CAMGE	I,N
	AOJA	I,M3
	MOVEI	2,1
	MOVEM	2,IM#
$15:	MOVEI	M,1
	ADD	M,KL
	MOVEI	K,1
$13:	MOVE	2,IM
	ADD	2,M
	MOVEM	2,IEND#
	MOVEM	2,J
	ADD	2,IM
	MOVEM	2,JEND#
$5:	MOVEI	I,1
M4:	MOVNI	2,1
IF1:	ADD	2,777777(I)
	IMUL	2,IW
	MOVE	MA,2
IB2:	ADD	MA,777777(J)
	MOVE	MC,2
IB3:	ADD	MC,777777(M)
IA1:	MOVE	2,777777(MA)
IA2:	MOVE	3,777777(MC)
	CAMGE	2,3
	JRST	$3
	CAME	2,3
	JRST	$4
$2:	CAMGE	I,ISF
	AOJA	I,M4
$3:IB4:	MOVE	3,777777(J)
IB5:	MOVEM	3,777777(K)
	AOJ	K,
	AOJ	J,
	CAMGE	J,JEND
	JRST	$5
$6:IB6:	MOVE	3,777777(M)
IB7:	MOVEM	3,777777(K)
	AOJ	K,
	AOJ	M,
	CAML	M,IEND
	JRST	$7
	JRST	$6
$4:IB8:	MOVE	3,777777(M)
IB9:	MOVEM	3,777777(K)
	AOJ	K,
	AOJ	M,
	CAMGE	M,IEND
	JRST	$5
$8:IB10:MOVE	3,777777(J)
IB11:	MOVEM	3,777777(K)
	AOJ	K,
	AOJ	J,
	CAMGE	J,JEND
	JRST	$8
$7:	MOVN	2,KL
	SUB	2,N
	ADD	2,IM
	ADD	2,JEND
	JUMPG	2,$10
	MOVE	M,JEND
	ADD	2,IM
	JUMPLE	2,$13
	MOVE	2,IM
	ADD	2,M
	MOVEM	2,IEND
	MOVEM	2,J
	MOVEI	2,1
	ADD	2,KL
	ADD	2,N
	MOVEM	2,JEND
	JRST	$5
$10:	MOVNI	I,1
	ADD	I,K
M7:	MOVE	MP,KL
	ADD	MP,I
IB12:	MOVE	3,777777(I)
IB13:	MOVEM	3,777777(MP)
	SOJG	I,M7
	MOVE	2,IM
	ASH	2,1
	MOVN	3,N
	ADD	3,2
	JUMPGE	3,$16
	MOVEM	2,IM
	ADD	3,IM
	JUMPLE	3,$15
$20:	MOVEI	2,1
	ADD	2,KL
	MOVEM	2,JEND
	MOVEI	K,1
	JRST	$7
;
;	BEGIN FINAL PHASE OF SORT PUTTING IN ORDER BY TAGS.
;
$16:	MOVEI	I,1
	ADD	I,KL
	MOVE	MC,KL
	ADD	MC,N
M9:IB14:MOVE	M,777777(I)
$21:	MOVN	2,KL
	ADD	2,I
IT1:	MOVEM	2,777777(M)
	CAMGE	I,MC
	AOJA	I,M9
	MOVEI	I,1
M10:IT2:MOVE	2,777777(I)
	JUMPE	2,$22
$27:	CAMN	2,I
	JRST	$22
	MOVE	IC,2
	MOVEI	J,1
M13:	MOVNI	2,1
	ADD	2,J
	IMUL	2,IW
	MOVE	JK,I
	ADD	JK,2
$24:IA3:MOVE	2,777777(JK)
	MOVEM	2,IX-1(J)
	CAMGE	J,JA
	AOJA	J,M13
$25:	MOVEI	J,1
M15:	MOVNI	2,1
	ADD	2,J
	IMUL	2,IW
	MOVE	JK,IC
	ADD	JK,2
	MOVE	0,IX-1(J)
IA4:	EXCH	0,777777(JK)
	MOVEM	0,IX-1(J)
	CAMGE	J,JA
	AOJA	J,M15
IT5:	MOVE	2,777777(IC)
IT6:	SETZM	777777(IC)
	MOVE	IC,2
IT7:	MOVE	2,777777(IC)
	JUMPG	2,$25
$22:	CAMGE	I,N
	AOJA	I,M10
M16:	MOVE	15,TEMP
	MOVE	16,TEMP+1
	GOODBY	(10)
TEMP:	BLOCK	2
N:	0
JA:	0
ISF:	0
IW:	0
IX:	BLOCK	^D40
	PRGEND
	TITLE	SSORT
	SEARCH	FORPRM

COMMENT	*	USAGE DESCRIPTION

	CALL SSORT(NV,NC,MV,MC,DATA,IS,KKL,IV,SP)
OR	CALL SSORT(NV,NC,MV,MC,DATA,IS,KKL,IV,SP,ITYP)

WHERE	DATA	IS ARRAY TO BE SORTED (ONE OR TWO DIMENSIONAL)
	MC	NUMBER OF ROWS DIMENSIONED IN MATRIX DATA (1ST SUBSCRIPT)
	MV	NUMBER OF COLUMNS DIMENSIONED IN MATRIX (SECOND
		  SUBSCRIPT OR 1 IF DATA IS SINGLE SUBSCRIPTED)
	NC	NUMBER OF ROWS FILLED
	NV	NUMBER OF COLUMNS FILLED
	KKL	NUMBER OF SORT FIELDS TO BE USED
	IS	VECTOR OF INDEXES OF SORT FIELDS
	IV	WORKING STORAGE VECTOR. AT LEAST NC IN LENGTH
	SP	WORKING STORAGE VECTOR. AT LEAST NV IN LENGTH
	ITYP	OPTIONAL VECTOR TELLING HOW TO SORT.
		IF ITH ENTRY IS ZERO, SORT ITH FIELD AS SIGNED INTEGER
		IF NONZERO, SORT AS UNSIGNED INTEGER OR ALPHANUMERIC
			(LEFT JUSTIFIED)

*
COMMENT	*	ACCUMULATOR ASSIGNMENTS		*

NEXTRA=15
I=14
J=13
K=12
L=11
II=10
IJ=7
M=6
LL=5
P1==4
T1=0
T2=1

;	      SUBROUTINE SSORT(NV,NC,MV,MC,DATA,IS,KKL,IV,SP)
	HELLO	(SSORT, )	;SSORT ENTRY
	MOVEM	15,TEMP.
	MOVEM	16,TEMP.+1
	MOVEI	00,TEMP.+1
	PUSH	00,@0(16)
	PUSH	00,@1(16)
	PUSH	00,@2(16)
	PUSH	00,@3(16)
	PUSH	00,@6(16)

	MOVEI	0,@4(16)
	SOJ	0,
	SUB	0,MC
	HRRM	0,DATA1
	HRRM	0,DATA2
	HRRM	0,DATA3
	HRRM	0,DATA4
	HRRM	0,DATA5
	HRRM	0,DATA6
	HRRM	0,DATA7
	HRRM	0,DATA8
	HRRM	0,DATA9
	HRRM	0,DATA10
	HRRM	0,DATA11
	HRRM	0,DATA12
	HRRM	0,DATA13
	HRRM	0,DATA14
	HRRM	0,DATA15
	HRRM	0,DATA16
	HRRM	0,DATA17

	MOVEI	0,@5(16)
	SOJ	0,
	HRRM	0,IS1
	HRRM	0,IS2
	HRRM	0,IS3
	HRRM	0,IS4
	HRRM	0,IS5
	HRRM	0,IS6
	HRRM	0,IS7
	HRRM	0,IS8
	HRRM	0,IS9
	HRRM	0,IS10
	HRRM	0,IS11
	HRRM	0,IS12
	HRRM	0,IS13

	MOVEI	0,@7(16)
	HRRM	0,IV1A
	HRRM	0,IV2A
	HRRM	0,IV3A
	SOJ	0,
	HRRM	0,IV1
	HRRM	0,IV2
	HRRM	0,IV3
	HRRM	0,IV4
	HRRM	0,IV5
	HRRM	0,IV6
	HRRM	0,IV7
	HRRM	0,IV9
	HRRM	0,IV10
	HRRM	0,IV11
	HRRM	0,IV12
	HRRM	0,IV13
	HRRM	0,IV14
	HRRM	0,IV15
	HRRM	0,IV17
	HRRM	0,IV18
	HRRM	0,IV19
	HRRM	0,IV20
	HRRM	0,IV21
	HRRM	0,IV22
	HRRM	0,IV23
	HRRM	0,IV25
	HRRM	0,IV26
	HRRM	0,IV26.5
	HRRM	0,IV27
	HRRM	0,IV28
	HRRM	0,IV30
	HRRM	0,IV31
	HRRM	0,IV32
	HRRM	0,IV34
	HRRM	0,IV35
	HRRM	0,IV37
	HRRM	0,IV38
	HRRM	0,IV39
	HRRM	0,IV40
	HRRM	0,IV41
	HRRM	0,IV42
	HRRM	0,IV43
	HRRM	0,IV44
	HRRM	0,IV45
	HRRM	0,IV46
	HRRM	0,IV47
	HRRM	0,IV48

	MOVEI	0,@10(16)
	SOJ	0,
	HRRM	0,S$1
	HRRM	0,S$2

	MOVE	0,[JRST COMINT]	;ASSUME COMPARE SIGNED
	MOVEM	COMTYP#
IFN F40LIB,<
	TLNN	16,-1		;F40 CALL?
	 JRST	CHKF10		;NO. F10
	HLRZ	0,^D9(16)	;OPTIONAL ARG PRESENT
	TRZ	0,777
	CAIE	0,(JUMP 0)
	JRST	NOTYPE		;NO. NO TYPE
	JRST	CHKTYP		;MUST CHECK TYPES
CHKF10:>
	HLRE	0,-1(16)	;GET NUMBER OF ARGUMENTS
	MOVN	0,0
	CAIGE	0,^D10		;OPTIONAL ARG PRESENT
	JRST	NOTYPE
CHKTYP:	MOVE	0,[SKIPN 0(I)]	;SET UP SKIP WORD TO EXECUTE FOR TYPE
	ADDI	0,@^D9(16)
	SUBI	0,1		;ACTUALLY DO SUB SINCE IF IN INSTRUCTION
				;IT OVERFLOWS INTO INDEX FIELD
	MOVEM	0,COMTYP#
NOTYPE:

;	      DIMENSION DATA(MC,MV),IV(1),IS(1),IU(16),IL(16),SP(1)
;	      DIMENSION GIP(25)
;	      DO 1 I=1,NC
	MOVE	I,NC
;	1     IV(I)=I
$1:
IV1:	MOVEM	I,777777(I)
	SOJG	I,$1
;	      M=1
	MOVEI	M,1
;	      II=1
	MOVEI	II,1
;	      J=NC
	MOVE	J,NC
;	11    IF(II.GE.J) GO TO 18
$11:	CAML	II,J
	JRST	$18
;	12    K=II
$12:	MOVE	K,II
;	      IJ=(J+II)/2
	MOVE	IJ,II
	ADD	IJ,J
	SKIPGE	IJ
	ADDI	IJ,1
	ASH	IJ,777777
;	      I=0
	MOVEI	I,0
;	31    I=I+1
$31:	AOS	I
;	      IF(I.GT.KKL) GO TO 33
	CAMLE	I,KKL
	JRST	$33
;	      T1=DATA(IV(IJ),IS(I))
IS1:	MOVE	03,777777(I)
	IMUL	03,MC
IV2:	ADD	03,777777(IJ)
DATA1:	MOVE	T1,777777(3)
;	      T2=DATA(IV(II),IS(I))
IS2:	MOVE	03,777777(I)
	IMUL	03,MC
IV3:	ADD	03,777777(II)
DATA2:	MOVE	T2,777777(3)
;	      IF(T2.EQ.T1) GO TO 31
;	      IF(T2.LT.T1) GO TO 13
;	      GO TO 32
	JSP	P1,COMPAR	;DO THE COMPARE
	 JRST	$32		;T1.LT.T2
	  JRST	$31		;T1.EQ.T2
	   JRST	$13		;T1.GT.T2
;	33    IF(IV(II).LE.IV(IJ)) GO TO 13
$33:
IV4:	MOVE	02,777777(II)
IV5:	CAMG	02,777777(IJ)
	JRST	$13
;	32    ISAV=IV(IJ)
$32:
IV6:	MOVE	02,777777(IJ)
;	      IV(IJ)=IV(II)
IV7:	EXCH	02,777777(II)	;IV(IJ) INTO IV(II) AND IV(II) INTO 02
;	      IV(II)=ISAV
IV9:	MOVEM	02,777777(IJ)	;IV(II) INTO IV(IJ)
;	13    LL=J
$13:	MOVE	LL,J
;	      I=0
	MOVEI	I,0
;	34    I=I+1
$34:	AOS	I
;	      IF(I.GT.KKL) GO TO 36
	CAMLE	I,KKL
	JRST	$36

;	      T1=DATA(IV(IJ),IS(I))
IS3:	MOVE	03,777777(I)
	IMUL	03,MC
IV10:	ADD	03,777777(IJ)
DATA3:	MOVE	T1,777777(3)
;	      T2=DATA(IV(J),IS(I))
IS4:	MOVE	03,777777(I)
	IMUL	03,MC
IV11:	ADD	03,777777(J)
DATA4:	MOVE	T2,777777(3)
;	      IF(T2.EQ.T1) GO TO 34
;	      IF(T2.GT.T1) GO TO 5
;	      GO TO 35
	JSP	P1,COMPAR	;DO THE COMPARE
	 JRST	$5		;T1.LT.T2
	  JRST	$34		;T1.EQ.T2
	   JRST	$35		;T1.GT.T2
;	36    IF(IV(J).GE.IV(IJ)) GO TO 5
$36:
IV12:	MOVE	02,777777(J)
IV13:	CAML	02,777777(IJ)
	JRST	$5
;	35    ISAV=IV(IJ)
$35:
IV14:	MOVE	02,777777(IJ)
;	      IV(IJ)=IV(J)
IV15:	EXCH	02,777777(J)	;IV(IJ) INTO IV(J) AND IV(J) INTO 02
;	      IV(J)=ISAV
IV17:	MOVEM	02,777777(IJ)	;IV(J) INTO IV(IJ)
;	      I=0
	MOVEI	I,0
;	37    I=I+1
$37:	AOS	I
;	      IF(I.GT.KKL) GO TO 39
	CAMLE	I,KKL
	JRST	$39
;	      T1=DATA(IV(IJ),IS(I))
IS5:	MOVE	03,777777(I)
	IMUL	03,MC
IV18:	ADD	03,777777(IJ)
DATA5:	MOVE	T1,777777(3)

;	      T2=DATA(IV(II),IS(I))
IS6:	MOVE	03,777777(I)
	IMUL	03,MC
IV19:	ADD	03,777777(II)
DATA6:	MOVE	T2,777777(3)
;	      IF(T2.EQ.T1) GOTO 37
;	      IF(T2.LT.T1) GO TO 5
;	      GO TO 38
	JSP	P1,COMPAR	;DO THE COMPARE
	 JRST	$38		;T1.LT.T2
	  JRST	$37		;T1.EQ.T2
	   JRST	$5		;T1.GT.T2
;	39    IF(IV(II).LE.IV(IJ)) GO TO 5
$39:
IV20:	MOVE	02,777777(II)
IV21:	CAMG	02,777777(IJ)
	JRST	$5
;	38    ISAV=IV(IJ)

$38:
IV22:	MOVE	02,777777(IJ)
;	      IV(IJ)=IV(II)
IV23:	EXCH	02,777777(II)	;IV(IJ) INTO IV(II) AND IV(II) INTO 02
;	      IV(II)=ISAV
IV25:	MOVEM	02,777777(IJ)	;IV(II) INTO IV(IJ)
;	      GO TO 5
;	JRST	$5
;	5     DO 6 L=1,KKL
$5:	MOVEI	L,1
M5:	BLOCK	0
;	6     GIP(L)=DATA(IV(IJ),IS(L))
$6:
IS7:	MOVE	03,777777(L)
	IMUL	03,MC
IV26:	ADD	03,777777(IJ)
DATA7:	MOVE	02,777777(3)
	MOVEM	02,GIP-1(L)
	CAMGE	L,KKL
	AOJA	L,M5
;	      NEXTRA=IV(IJ)
IV26.5:	MOVE	NEXTRA,777777(IJ)
;	      GO TO 15
	JRST	$15
;	14    ISAV=IV(LL)
$14:
IV27:	MOVE	02,777777(LL)
;	      IV(LL)=IV(K)
IV28:	EXCH	02,777777(K)	;IV(LL) INTO IV(K) AND IV(K) INTO 02
;	      IV(K)=ISAV
IV30:	MOVEM	02,777777(LL)	;IV(K) INTO IV(LL)
;	15    LL=LL-1
$15:	SOS	LL
;	      I=0
	MOVEI	I,0
;	40    I=I+1
$40:	AOS	I
;	      IF(I.GT.KKL) GO TO 41
	CAMLE	I,KKL
	JRST	$41
;	      T1=GIP(I)
	MOVE	T1,GIP-1(I)
;	      T2=DATA(IV(LL),IS(I))
IS8:	MOVE	03,777777(I)
	IMUL	03,MC
IV31:	ADD	03,777777(LL)
DATA8:	MOVE	T2,777777(3)
;	      IF(T2.EQ.T1) GO TO 40
;	      IF(T2.GT.T1) GO TO 15
;	      GO TO 16
	JSP	P1,COMPAR	;DO THE COMPARE
	 JRST	$15		;T1.LT.T2
	  JRST	$40		;T1.EQ.T2
	   JRST	$16		;T1.GT.T2
;	41    IF(IV(LL).GT.NEXTRA) GO TO 15
$41:
IV32:	MOVE	02,777777(LL)
	CAMLE	02,NEXTRA
	JRST	$15
;	16    K=K+1
$16:	AOS	K
;	      I=0
	MOVEI	I,0
;	42    I=I+1
$42:	AOS	I
;	      IF(I.GT.KKL) GO TO 44
	CAMLE	I,KKL
	JRST	$44
;	      T1=GIP(I)
	MOVE	T1,GIP-1(I)
;	      T2=DATA(IV(K),IS(I))
IS9:	MOVE	03,777777(I)
	IMUL	03,MC
IV34:	ADD	03,777777(K)
DATA9:	MOVE	T2,777777(3)
;	      IF(T2.EQ.T1) GO TO 42
;	      IF(T2.LT.T1) GO TO 16
;	      GO TO 43
	JSP	P1,COMPAR	;DO THE COMPARE
	 JRST	$43		;T1.LT.T2
	  JRST	$42		;T1.EQ.T2
	   JRST	$16		;T1.GT.T2
;	44    IF(IV(K).LT.NEXTRA) GO TO 16
$44:
IV35:	MOVE	02,777777(K)
	CAMGE	02,NEXTRA
	JRST	$16
;	43    IF(K.LE.LL) GO TO 14
$43:	CAMG	K,LL
	JRST	$14
;	      IF((LL-II).LE.(J-K)) GO TO 17
	MOVE	02,J
	SUB	02,K
	MOVN	03,II
	ADD	03,LL
	CAML	02,3
	JRST	$17
;	      IL(M)=II
	MOVEM	II,IL-1(M)
;	      IU(M)=LL
	MOVEM	LL,IU-1(M)
;	      II=K
	MOVE	II,K
;	      M=M+1
	AOS	M
;	      GOTO 19
	JRST	$19
;	17    IL(M)=K
$17:	MOVEM	K,IL-1(M)
;	      IU(M)=J
	MOVEM	J,IU-1(M)
;	      J=LL
	MOVE	J,LL
;	      M=M+1
;	      GOTO 19
	AOJA	M,$19
;	18    M=M-1
;	      IF(M.EQ.0) GO TO 90
$18:	SOJE	M,$90
;	      II=IL(M)
	MOVE	II,IL-1(M)
;	      J=IU(M)
	MOVE	J,IU-1(M)
;	19    IF((J-II).GE.11) GO TO 12
$19:	MOVN	02,II
	ADD	02,J
	CAIL	02,13
	JRST	$12
;	      IF(II.EQ.1) GO TO 11
	CAIN	II,1
	JRST	$11
;	C
;	C     BUBBLE SORT PORTION (FASTER THAN PARTITION ONLY IF SUBSET
;	C     BEING LOOKED AT IS 11 OBSERVATIONS OR LESS)
;	C
;	      II=II-1
	SOS	II
;	20    II=II+1
$20:	AOS	II
;	      IF(II.EQ.J) GO TO 18
	CAMN	J,II
	JRST	$18
;	      I=0
	MOVEI	I,0
;	      NEXTRA=IV(II+1)
IV1A:	MOVE	NEXTRA,0(II)
;	45    I=I+1
$45:	AOS	I
;	      IF(I.GT.KKL) GO TO 47
	CAMLE	I,KKL
	JRST	$47
;	      T1=DATA(NEXTRA,IS(I))
IS10:	MOVE	03,777777(I)
	IMUL	03,MC
	ADD	03,NEXTRA
DATA10:	MOVE	T1,777777(3)
;	      T2=DATA(IV(II),IS(I))
IS11:	MOVE	03,777777(I)
	IMUL	03,MC
IV37:	ADD	03,777777(II)
DATA11:	MOVE	T2,777777(3)
;	      IF(T2.EQ.T1) GO TO 45
;	      IF(T2.LT.T1) GO TO 20
;	      GO TO 46
	JSP	P1,COMPAR	;DO THE COMPARE
	 JRST	$46		;T1.LT.T2
	  JRST	$45		;T1.EQ.T2
	   JRST	$20		;T1.GT.T2
;	47    IF(IV(II).LE.NEXTRA) GO TO 20
$47:
IV38:	CAML	NEXTRA,777777(II)
	JRST	$20
;	46    K=II
$46:	MOVE	K,II
;	21    IV(K+1)=IV(K)
$21:
IV39:	MOVE	03,777777(K)
IV2A:	MOVEM	03,0(K)
;	      K=K-1
	SOS	K
;	      I=0
	MOVEI	I,0
;	48    I=I+1
$48:	AOS	I
;	      IF(I.GT.KKL) GO TO 50
	CAMLE	I,KKL
	JRST	$50
;	      T1=DATA(NEXTRA,IS(I))
IS12:	MOVE	03,777777(I)
	IMUL	03,MC
	ADD	03,NEXTRA
DATA12:	MOVE	T1,777777(3)
;	      T2=DATA(IV(K),IS(I))
IS13:	MOVE	03,777777(I)
	IMUL	03,MC
IV40:	ADD	03,777777(K)
DATA13:	MOVE	T2,777777(3)
;	      IF(T2.EQ.T1) GOTO 48
;	      IF(T1.LT.T2) GO TO 21
;	      GO TO 49
	JSP	P1,COMPARE	;DO THE COMPARE
	 JRST	$21		;T1.LT.T2
	  JRST	$48		;T1.EQ.T2
	   JRST	$49		;T1.GT.T2
;	50    IF(NEXTRA.LT.IV(K)) GO TO 21
$50:
IV41:	CAMGE	NEXTRA,777777(K)
	JRST	$21
;	49    IV(K+1)=NEXTRA
$49:
IV3A:	MOVEM	NEXTRA,0(K)
;	      GO TO 20
	JRST	$20
;	C

;	C     END SORT NOW PLACE TAGS IN CORRECT ORDER
;	C
;	90    DO 91 J=1,NC
$90:	MOVEI	J,1
M6:
;	      IF(IV(J).EQ.0) GOTO 91
IV42:	MOVE	02,777777(J)
	JUMPE	02,$91
;	      IF(IV(J).EQ.J) GO TO 91
IV43:	CAMN	J,777777(J)
	JRST	$91
;	      DO 92 K=1,NV
	MOVEI	K,1
M9:	BLOCK	0
;	92    SP(K)=DATA(J,K)
$92:	MOVE	03,K
	IMUL	03,MC
	ADD	03,J
DATA14:	MOVE	02,777777(3)
S$1:	MOVEM	02,777777(K)
	CAMGE	K,NV
	AOJA	K,M9
;	      M=J
	MOVEM	J,M
;	      L=J
	MOVE	L,J
;	93    DO 94 K=1,NV

$93:	MOVEI	K,1
M11:	BLOCK	0
;	94    DATA(M,K)=DATA(IV(L),K)
$94:
	MOVE	03,K
	IMUL	03,MC
IV44:	ADD	03,777777(L)
DATA15:	MOVE	02,777777(3)
	MOVE	03,K
	IMUL	03,MC
	ADD	03,M
DATA16:	MOVEM	02,777777(3)
	CAMGE	K,NV
	AOJA	K,M11
;	      M=IV(L)
IV45:	MOVE	02,777777(L)
	MOVEM	02,M
;	      IV(L)=0
IV46:	SETZM	777777(L)
;	      L=M
	MOVE	L,M
;	      IF(IV(L).NE.J) GO TO 93
IV47:	CAME	J,777777(L)
	JRST	$93
;	      DO 96 K=1,NV
	MOVEI	K,1
M13:	BLOCK	0
;	96    DATA(L,K)=SP(K)
$96:	MOVE	03,K
	IMUL	03,MC
	ADD	03,L
S$2:	MOVE	02,777777(K)
DATA17:	MOVEM	02,777777(3)
	CAMGE	K,NV
	AOJA	K,M13
;	      IV(L)=0
IV48:	SETZM	777777(L)
;	91    CONTINUE
$91:	CAMGE	J,NC
	AOJA	J,M6
;	      RETURN
;	      END
M14:	MOVE	15,TEMP.
	MOVE	16,TEMP.+1
	GOODBY	(11)


; ROUTINE TO DO APPROPRIATE TYPE COMPARE ON T1,T2
; USES ACS 2,3 IF ALPHA COMPARE
; RETURNS +1 IF T1.LT.T2
;	  +2 IF T1.EQ.T2
;	  +3 IF T1.GT.T2
COMPAR:	XCT	COMTYP		;DO SKIPN OR JRST
	 JRST	COMINT		;SIGNED INTEGER COMPARE
	TLC	T1,(1B0)	;FLIP SIGN BIT
	TLC	T2,(1B0)	;FLIP SIGN BIT
COMINT:	CAMGE	T1,T2		;COMPARE
	 JRST	(P1)		;T1.LT.T2
	CAMG	T1,T2		;...
	  JRST	1(P1)		;T1.EQ.T2
	   JRST	2(P1)		;T1.GT.T2


COMMENT	*	DATA AREA	*

TEMP.:	BLOCK	2
NV:	BLOCK	1
NC:	BLOCK	1
MV:	BLOCK	1
MC:	BLOCK	1
KKL:	BLOCK	1


IU:	BLOCK	^D16
IL:	BLOCK	^D16
GIP:	BLOCK	^D25

	PRGEND
	TITLE	BUSY
	SEARCH	FORPRM

COMMENT	%

	WRITTEN BY NORM GRANT. W.M.U.

USAGE		CALL BUSY(IDEV)

	WHERE	IDEV:	IS FORTRAN DEVICE NUMBER OF DESIRED DEVICE OR
			ASCII DEVICE NAME
%

	HELLO	(BUSY, )	;BUSY ENTRANCE
	PUSHJ	P,GTDV..##
	JUMPE	0,RETUR1
LOOPB:	MOVE	0,2
	DEVCHR
	TLNE	0,40		;AVAILABLE?
RETUR1:	GOODBY	(1)
	MOVEI	0,10
	SLEEP	0,
	JRST	LOOPB
	PRGEND
	TITLE	CHKDEV

	SEARCH	FORPRM

COMMENT	%
WRITTEN BY NORM GRANT. W.M.U.


	ASSIGN

PURPOSE	TO ASSIGN A DEVICE TO USER'S JOB.(TTY'S EXCLUDED)

USAGE	CALL ASSIGN(IDEV,IERR)
OR	CALL ASSIGN(IDEV,IERR,NSECS)
WHERE	IDEV:	IS FORTRAN DEVICE NUMBER.
	IERR:	ERROR CODE.
		IERR=-1 IF NO SUCH DEVICE OR DEVICE NOT ASSIGNABLE.
		IERR=0 IF DEVICE EXISTS.
	NSECS:	MAXIMUM NUMBER OF SECONDS TO WAIT. IF NOT GIVEN,
		PROGRAM SLEEPS UNTIL DEVICE CAN BE ASSIGNED.

	DEASSI

PURPOSE	TO DEASSIGN A DEVICE FROM USER'S JOB.(TTY'S EXCLUDED)

USAGE	CALL DEASSI(IDEV)
WHERE	IDEV:	IS FORTRAN DEVICE NUMBER.  IF NOT ASSIGNED, CALL IS
		A NO-OP.

	REASSI

PURPOSE	TO TRANSFER AN ASSIGNED DEVICE TO ANOTHER JOB.(TTY'S EXCLUDED)

USAGE	CALL REASSI(IDEV,IJOB,IERR)
WHERE	IDEV:	IS FORTRAN DEVICE NUMBER OF DEVICE.
	IJOB:	IS JOB TO ASSIGN THE DEVICE TO.
	IERR:	ERROR CODE. IERR=-1 IF DEVICE DOES NOT EXIST,IJOB DOES
		NOT EXIST, OR DEVICE CANNOT BE REASSIGNED.


%

OPDEF	REASSI[CALLI	21]
	HELLO	(ASSIGN, )		;ASSIGN ENTRY
	SETOM	@1(16)
	PUSHJ	P,GTDV..##
	JUMPE	0,RETUR2
	TLNE	0,DV.TTY
	JRST	RETUR2
IFN F40LIB,<
	TLNN	16,-1		;F10 CALL?
	JRST	CHKF10		;YES
	HLRZ	3,2(16)		;NO. F40
	ANDI	3,777037	;CLEAR AC BITS
	CAIE	3,(JUMP)	;ARG?
	JRST	LOOPR		;NO
	JRST	ARG3		;YES. GET IT
CHKF10:>
	HLRE	3,-1(16)	;GET -VE NUMBER OF ARGS
	MOVMS	3		;GET ABS NUMBER
	CAIGE	3,3		;AT LEAST THREE?
	JRST	LOOPR		;NO.
ARG3:	SKIPA	3,@2(16)	;PICK UP ARG
LOOPR:	HRLOI	3,377777	;SLEEP FOREVER IF NECESSARY
	MOVE	4,0
	ANDI	4,177777	;GET LEGAL MODES
	JFFO	4,.+1		;FIRST BIT POSITION
	SUBI	5,^D35		;-35
	MOVM	4,5		;ABS IS HIGHEST LEGAL MODE
	MOVE	5,2		;SET UP OPEN BLOCK
	SETZ	6,		;NO BUFFERS
LOOPR1:	OPEN	0,4		;TRY TO OPEN IT
	 JRST	[MOVEI	1,1	;ONE SEC
		 SLEEP	1,	;SLEEP IT
		 SOJL	3,RETUR2 ; QUIT IF -VE
		 JRST	LOOPR1]
	PJOB	1,
DRPOUT:	REASSI	1,
	RELEAS	0,0
	JUMPE	2,RETUR2
	JUMPE	1,RETUR2
	SETZM	@1(16)
RETUR2:	GOODBY	(2)


	HELLO	(REASSI, )		;REASSIGN ENTRY
	SETOM	@2(16)
	PUSHJ	P,GTDV..
	MOVE	1,@1(16)
	AOJA	16,DRPOUT

	HELLO	(DEASSI, )		;DEASSIGN ENTRY
	PUSHJ	P,GTDV..
	SETZ	1,
	REASSI	1,
	GOODBY	(1)


	PRGEND
	TITLE	CHKNAM
	SUBTTL SUBROUTINE TO CHECK FILE-NAMES.
	SEARCH	FORPRM

COMMENT	%

	WRITTEN BY NORM GRANT. WMU.

	CKNAME IS ASCII TO SIXBIT CONVERTER AND NAME CHECKER
;
	USAGE		CALL CHKNAM(NAME,IERR)
	OR		CALL CHKNAM(NAME,IERR,IEXT)
		WHERE   NAME IS FILENAME.EXT(MUST BE A TWO WORD
				QUANTITY.)
		AND	IERR IS ERROR CODE
			IERR=0	VALID NAME.
			IERR=-1	ILLEGAL NAME.
			IEXT:	(IF PRESENT) IS -1 IF EXT. NOT NULL, 0 IF NULL.
%


NAME:	BLOCK	2

	HELLO	(CHKNAM, )
	SETZM	@1(16)
	MOVEI	0,@0(16)	;GET ADDRESS OF NAME.
	HRRM	0,%1M
	PUSH	P,16
	MOVEI	16,%1M
	PUSHJ	P,CKNAME##
	POP	P,16
	SKIPE	IERR
	SETOM	@1(16)
IFN F40LIB,<
	TLNN	16,-1		;F10 OR F40?
	JRST	CHKF10		;F10!
	HLRZ	0,2(16)
	TRZ	0,777
	CAIE	0,(JUMP 0,0)
	GOODBY	(2)
	JRST	ARG3
CHKF10:>
	HLRE	1,-1(16)
	MOVMS	1		;GET ABS NUMBER OF ARGS
	CAIGE	1,3		;AT LEAST THREE?
	GOODBY	(2)		;NO. LEAVE
ARG3:	SETZM	@2(16)
	SKIPE	NAME+1
	SETOM	@2(16)
	GOODBY	(3)

%1M:	JUMP	0,0
	JUMP	0,NAME
	JUMP	0,IERR#
	PRGEND
	TITLE	DEVCHR
	SEARCH	FORPRM

COMMENT	%
WRITTEN BY NORM GRANT. W.M.U.

	DEVCHR
PURPOSE	TO DETERMINE THE CHARACTERISTICS OF A DEVICE


USAGE	CALL DEVCHR(IDEV,ICHAR)
	WHERE	IDEV:	IS FORTRAN UNIT NUMBER OF DEVICE.
	AND	ICHAR:	IS RETURNED DEVICE CHARACTERISTICS, AS FOLLOWS:
BIT			MEANING IF BIT IS SET
 0		DECTAPE DIRECTORY IS IN CORE.
 1		DEVICE IS A DISK.
 2		DEVICE IS A CARD READER.
 3		DEVICE IS A LINE PRINTER.
 4		TTY ATTACHED TO JOB.
 5		TTY IN USE AS A USER CONSOLE(EVEN IF DETACHED)
 6		TTY IN USE AS I/O DEVICE.
 7		DEVICE IS A DISPLAY.
 8		DEVICE HAS A LONG DISPATCH TABLE(RECOGNIZES UUO'S
		    OTHER THAN INPUT,OUTPUT,CLOSE, AND RELEAS)
 9		DEVICE IS A PAPER TAPE PUNCH.
10		DEVICE IS A PAPER TAPE READER.
11		DEVICE IS A DECTAPE.
12		DEVICE IS AVAILABLE TO THIS JOB OR ALREADY
		    ASSIGNED TO THIS JOB.
13		DEVICE IS A MAGNETIC TAPE.
14		DEVICE IS A TTY.
15		DEVICE HAS A DIRECTORY(DTA OR DSK)
16		DEVICE CAN DO INPUT.
17		DEVICE CAN DO OUTPUT.
18		DEVICE ASSIGNED BY CONSOLE COMMAND.
19		DEVICE ASSIGNED BY PROGRAM(INIT UUO)
 REMAINING BITS	IF BIT (35-N) CONTAINS A 1, THEN MODE N IS LEGAL
		    FOR THE DEVICE.


%


	HELLO	(DEVCHR, )
	PUSHJ	P,GTDV..##
	MOVEM	0,@1(16)
	GOODBY	(2)
	PRGEND
	TITLE	DEVICE
COMMENT	%
USAGE		CALL DEVICE(IDEV)
WHERE 	IDEV  IS FORTRAN DEVICE NUMBER

WRITTEN BY NORM GRANT. WMU. DECEMBER 8,1970.
THIS PROGRAM DETERMINES WHETHER PROGRAM IS RUNNING
FROM TTY OR PTY,AND CALL EXIT IF FROM PTY.
IF FROM TTY, IT TAKES A FORTRAN DEVICE NUMBER
AND CHECKS WHETHER IT IS OTHER THAN TTY.  IF IT IS, PROGRAM CALLS
EXIT.  OTHERWISE, NORMAL RETURN IS MADE.

%
	SEARCH	FORPRM

	HELLO	(DEVICE, )		;DEVICE ENTRY
	SETOM	1		;MAKE LINE NEGATIVE.
	GETLCH	1		;GET LINE CHARACTERISTICS.
	JUMPL	1,DOEXIT	;CALL EXIT IF LESS THAN ZERO(CONSOLE IS PTY)
	PUSHJ	P,GTDV..##
	TLNE	0,DV.TTY
	GOODBY	(1)		;IF USER IS ON TTY, AND DEVICE IS A TTY,RETURN.
DOEXIT:	MOVEI	16,[EXP 0,0]+1	;ARG FOR EXIT.
	PUSHJ	P,EXIT.##
	PRGEND
	TITLE	DEVTYP
	SEARCH	FORPRM

COMMENT	%

USAGE	CALL DEVTYP(IDEV,ICHAR)

	WHERE	IDEV	IS FORTRAN UNIT NUMBER OR ASCII DEVICE NAME
		ICHAR	RETURNED WORD FROM DEVTYP UUO

	BIT		MEANING
	 0	LOOKUP/ENTER MANDATORY.
	1-11	RESERVED FOR FUTURE
	12	DEVICE IS AVAILABLE TO THIS JOB.
	13	SPOOLED ON DISK. (OTHER BITS REFLECT PROPERTIES OF
		READ DEVICE, EXCEPT VARIABLE BUFFER SIZE)
	14	INTERACTIVE DEVICE (OUTPUT AFTER EACH BREAK CHARACTER)
	15	CAPABLE OF VARIABLE BUFFER SIZE (USER CAN SET HIS OWN
		BUFFER LENGTHS)
	16	CAPABLE OF INPUT
	17	CAPABLE OF OUTPUT
	18-26	JOB NUMBER THAT CURRENTLY HAS DEVICE ASSIGNED OR INITED
	27-28	RESERVED FOR THE FUTURE
	29	DEVICE IS A RESTRICTED DEVICE (I.E., CAN ONLY BE ASSIGNED
		BY A PRIVILEGED JOB OR THE MOUNT COMMAND)
	30-35	DEVICE TYPE CODE (OCTAL)
		CODE	MNEMONIC	MEANING
		  0	DSK	    DISK OF SOME SORT
		  1	DTA	    DECTAPE
		  2	MTA	    MAGNETIC TAPE
		  3	TTY	    TTY OR EQUIVALENT
		  4	PTR	    PAPER-TAPE READER
		  5	PTP	    PAPER-TAPE PUNCH
		  6	DIS	    DISPLAY
		  7	LPT	    LINE PRINTER
		 10	CDR	    CARD READER
		 11	CDP	    CARD PUNCH
		 12	PTY	    PLOTTER
		 13	PLT	    PLOTTER
		 14	EXT	    EXTERNAL TASK
		 15	MPX	    SOFTWARE MPX
		 16	PAR	    PA611R ON DC44
		 17	YCR	    PC11(R) ON DC44
		 20	PAP	    PA611P ON DC44
		 21	LPC	    LPC-11 ON DC44
		 22	PCP	    PC-11(P) ON DC44
		23-57		    RESERVED FOR DIGITAL
		60-77		    RESERVED FOR CUSTOMER

%
	OPDEF	DEVTYP[CALLI 53]
	HELLO	(DEVTYP)
	PUSHJ	P,GTDV..##	;INTERPRET UNIT NUMBER
	DEVTYP	2,		;DO UUO
	 SETZ	2,		;???
	MOVEM	2,@1(16)	;RETURN ANSWER
	GOODBY	2
	PRGEND
	TITLE	DTRNAC
	SEARCH	FORPRM

COMMENT	%

WRITTEN BY NORM GRANT. W.M.U.

	PURPOSE	RANDOM ACCESS ON DECTAPE.
	USAGE	CALL DTRNAC(N,A,IA,IDTA,NWORDS)
		WHERE	N:	FIRST PHYSICAL BLOCK NUMBER DESIRED.
				0<N<578.IF AN ATTEMPT IS MADE TO
				ACCESS AN ILLEGAL BLOCK NUMBER, THE
				PROGRAM WILL ABORT.
			A:	DATA MATRIX
			IA:	CODE FOR INPUT(1) OR OUTPUT(OTHER).
			IDTA:	FORTRAN DEVICE NUMBER OF DECTAPE.
			NWORDS:	NUMBER OF WORDS IN A RECORD.
;
	NOTE: SINCE THIS PROGRAM INDEXES ON PHYSICAL BLOCK NUMBERS,
	NO ATTENTION CAN BE PAYED TO ANY PREEXISTINT FILE STRUCTURE
	ON THE TAPE!  THEREFORE, THE PROGRAM SHOULD ONLY BE USED WHERE
	IT'S FILE IS SOLE OCCUPANT OF THE TAPE!
	NOTE: ONE PHYSICAL BLOCK CONTAINS 128 WORDS.
%

%1M:	ARG	.

	HELLO	(DTRNAC, )		;DTRNAC ENTRY
	MOVEI	0,@3(16)	;SET UP ARG FOR GTDV..
	MOVEM	0,%1M
	PUSH	P,16		;SAVE 16
	MOVEI	16,%1M
	PUSHJ	P,GTDV..##
	POP	P,16		;RESTORE 16
	JUMPE	0,ILDEV
	TLNN	0,DV.DTA
	JRST	ILDEV
	MOVEM	2,NAME
	INIT	17,116
NAME:	0
	0	;NO BUFFERS. DUMP MODE.
	JRST	TAPERR
	MOVEI	0,@1(16)
	SOJ	0,
LOOP:	HRRM	0,IOLIST
	MOVN	0,@4(16)
	HRLM	0,IOLIST
	MOVE	0,@0(16)
	CAILE	0,0
	CAIL	0,1102
	JRST	ILBLCK
	MOVE	1,@2(16)
	CAIN	1,1
	JRST	INPUT
OUTPUT:	HRRM	0,USETO
USETO:	USETO	17,0
	OUTPUT	17,IOLIST
	GOODBY	(5)
INPUT:	HRRM	0,USETI
USETI:	USETI	17,0
	INPUT	17,IOLIST
	GOODBY	(5)
ILBLCK:	OUTSTR	[ASCIZ/
No such block number!
/]
	EXIT
TAPERR:	OUTSTR	[ASCIZ/
Ccannot initialize tape!
/]
	EXIT
ILDEV:	OUTSTR	[ASCIZ/
Not a DECtape!
/]
	exit
ILD.:	ASCII "('-NOT A DECTAPE!'/)"
IOLIST:	IOWD ^D600,0
	0
	PRGEND
	TITLE	EXIST
	SUBTTL SUBROUTINE TO CHECK FOR FILE EXISTANCE ON DSK OR OTHER DEVICE.
	SEARCH	FORPRM

COMMENT	%

	WRITTEN BY NORM GRANT. WMU.
	CKNAME IS AN ASCII TO SIXBIT CONVERTER AND NAME CHECKER.

	USAGE		CALL EXIST(NAME,IERR)
	OR		CALL EXIST(NAME,IERR,IPROJ,IPROG)
	OR		CALL EXISTS(IDEV,NAME,IERR)
	OR		CALL EXISTS(IDEV,NAME,IERR,IPROJ,IPROG)
		WHERE   NAME IS FILENAME.EXT(SHOULD BE A TWO WORD
			QUANTITY OR END WITH A SPACE.)
		AND	IDEV IS FORTRAN DEVICE NUMBER.( IF UNDEFINED,
			DSK IS ASSUMED.
		AND	IERR IS ERROR CODE:
				IERR=0   FILE FOUND AND NAME LEGAL.
				IERR=-1  NAME ILLEGAL.
				IERR=1   FILE NOT FOUND OR NOT READABLE.
			IPROJ:	OCTAL PROJECT NUMBER.
			IPROG:	OCTAL PROGRAMMER NUMBER.
%

%1M:	JUMP	0,0
	JUMP	0,NAME
	JUMP	0,IERR#
NAME:	BLOCK	4		;BLOCK FOR LOOKUP
OPN:	BLOCK	3

	HELLO	(EXISTS, )	;EXISTS ENTRY
	SETOM	LONG#		;SAY CALLED EXISTS
	MOVE	1,@0(16)
	JUMPE	1,UNDEF
	PUSHJ	P,GTDV..##
	JUMPE	0,UNDEF
	AOJA	16,BOTH
UNDEF:	AOJA	16,EXIST1

	HELLO	(EXIST, )	;EXIST ENTRY
	SETZM	LONG		;SAY CALLED EXIST
EXIST1:	MOVSI	2,'DSK'
	MOVE	0,2		;COPY DEVICE
	DEVCHR	0,		;AND SIMULATE GTDV..
BOTH:	SETZM	@1(16)
	TLNE	0,(1B12)	;IS IT AVAILABLE?
	TLNN	0,(1B16)	;YES. IS IT AN INPUT DEVICE?
	JRST	NOFILE		;NO. ERROR
	TLNN	0,(1B15)	;DIRECTORY DEVICE?
	JRST	RETUR1		;NO. GOOD RETURN
	MOVEM	2,OPN+1		;DO OPEN IN ACS
	ANDI	0,177777	;GET LEGAL MODES
	JFFO	0,.+1		;FIND HIGHEST
	SUBI	1,^D35		;AS ABS(JFFO-35)
	MOVMM	1,OPN		;FOR OPEN IN HIGHEST LEGAL MODE
	SETZM	OPN+2		;NO BUFFERS
	MOVEI	0,@0(16)	;GET ADDRESS OF NAME.
	HRRM	0,%1M
	PUSH	P,16
	MOVEI	16,%1M
	PUSHJ	P,CKNAME##
	POP	P,16
	SKIPN	IERR
	JRST	ENDEXT
	SETOM	@1(16)
	JRST	RETURN
ENDEXT:	MOVEI	1,@0(16)	;GET ADR OF NAME
	HRLI	1,(POINT 7,0,)
	MOVEI	2,7		;PERIOD CANNOT BE LATER THAN 7 AND BE LEGAL NAME
EXTCHK:	ILDB	0,1		;GET CHARACTER
	CAIN	0,"."		;PERIOD?
	 JRST	EXTOK		;YES
	CAILE	0,40		;SPACE OR NULL?
	SOJG	2,EXTCHK	;LOOP
	MOVSI	0,'DAT'		;NULL EXTENSION AND NO PERIOD
	MOVEM	0,NAME+1	;MEANS .DAT
EXTOK:	SETZM	NAME+3		;ZERO PROJECT PROGRAMMER NUMBER(MONITER
				;ASSUMES PRESENT JOBS PPN.)
IFN F40LIB,<
	TLNN	16,-1		;F40 CALL?
	JRST	CHKF10		;NO. F10
	HLRZ	0,2(16)
	TRZ	0,777
	CAIE	0,(JUMP	0,0)
	JRST	END1
	HLRZ	0,3(16)
	TRZ	0,777
	CAIE	0,(JUMP	0,0)
	JRST	END1
	JRST	ARG4
CHKF10:>
	HLRE	0,-1(16)	;GET -VE NUMBER OF ARGS
	SKIPE	LONG		;DID WE REALLY CALL EXISTS?
	HLRE	0,-2(16)	;YES. 16 HAS BEEN MODIFIED
	MOVMS	0		;ABS NUMBER OF ARGS
	CAIGE	0,4		;AT LEAST FOUR?
	JRST	END1		;NO.
ARG4:	HRLZ	0,@2(16)
	HRR	0,@3(16)
	MOVEM	0,NAME+3	;STORE PPN FOR LOOKUP
END1:	OPEN	0,OPN		;INIT DSK.
	JRST	ERMSG
	LOOKUP	0,NAME	;LOOKUP FILE.
	JRST	NOFILE
	JRST	RETURN
ERMSG:	OUTSTR	[ASCIZ/ ERROR ON OPEN!
/]				;PUT OUT ERROR MESSAGE
	JRST	RETURN
NOFILE:	MOVEI	0,1
	MOVEM	0,@1(16)
RETURN:	RELEAS	0,0
RETUR1:	GOODBY	(2)
	PRGEND
	TITLE	FNDSPC - FIND STR WITH MOST FREE SPACE USEABLE BY US

COMMENT	%

USAGE		CALL FNDSPC(STR,IFREE)
	WHERE	STR - IS THE ASCII NAME OF THE FILE STRUCTURE WITH THE
			MOST FREE SPACE ACCESSABLE BY THIS USER.
		IFREE - IS THE AMOUNT OF FREE SPACE ON STR AVAILABLE
			TO THE USER ON A FCFS BASIS

%

	SEARCH	FORPRM,UUOSYM

N==3

STRBLK:	BLOCK	2		;JOBSTR BLOCK
DSKBLK:	BLOCK	3		;DSKCHR BLOCK
FILBLK:	BLOCK	.RBUSD+1	;UFD LOOKUP BLOCK

SAVSTR:	BLOCK	1		;SAVED STR NAME
SAVSIZ:	BLOCK	1		;SAVED FREE SPACE
	HELLO	(FNDSPC)
	SETOM	STRBLK		;START AT BEGINNING
	MOVSI	0,'DSK'
	MOVEM	0,SAVSTR	;DEFAULT STR IS DSK
	SETZM	SAVSIZ		;IS EMPTY
NXTSTR:	MOVE	0,[XWD 2,STRBLK]
	JOBSTR	0,		;GET NEXT STR
	 JRST	ENDSTR		;OOPS!
	MOVE	0,STRBLK	;GET STR NAME
	CAIE	0,0		;FENCE?
	CAMN	0,[-1]		;OR END?
	 JRST	ENDSTR		;YES. END
	MOVEM	0,DSKBLK	;STORE FOR DSKCHR
	SKIPGE	STRBLK+1	;READ-ONLY?
	 JRST	NXTSTR		;YES. GET NEXT
	MOVE	0,[XWD 3,DSKBLK]
	DSKCHR	0,		;DSKCHR
	 JRST	NXTSTR		;OOPS?
	TLNE	0,140300	;WRITE-LOCKED, ETC?
	 JRST	NXTSTR		;YES. IGNORE
	MOVE	0,DSKBLK+1	;GET BLOCKS FCFS LEFT
	CAMN	0,[XWD 400000,0]	;DOES MONITOR KNOW?
	 PUSHJ	P,GETQUO	;NO. GET IT FROM UFD
	CAMLE	0,DSKBLK+2	;QUOTA GREATER THAN FREE?
	MOVE	0,DSKBLK+2	;YES. USE FREE
	CAMG	0,SAVSIZ	;BETTER THAN REMEMBERED ONE?
	 JRST	NXTSTR		;NO. GET NEXT
	MOVEM	0,SAVSIZ	;SAVE NEW GREATEST SIZE
	MOVE	1,STRBLK	;AND NAME
	MOVEM	1,SAVSTR	;...
	JRST	NXTSTR		;LOOP AT ALL STRS

ENDSTR:	MOVE	0,SAVSIZ	;RETURN FREE SPACE
	MOVEM	0,@1(16)	;TO USER
	LDB	1,[POINT 4,0(L),12]
	PUSHJ	P,TYPE..##	;GET SINGLE/DOUBLE PRECISION
	MOVE	N,0		;COPY IT
	MOVEI	2,@0(L)		;GET ARGUMENT ADDRESS
	MOVE	1,[ASCII "     "];FIVE SPACES
	MOVEM	1,(2)		;STORE IT
	CAILE	N,5		;DOUBLE PRECISION ARG?
	MOVEM	1,1(2)		;YES. STORE IN SECOND WORD ALSO
	HRLI	2,440700	;SET UP BYTE POINTER TO STORE NAME
	MOVE	1,SAVSTR	;GET STR NAME BACK
RETNAM:	SETZ	0,
	LSHC	0,6
	JUMPE	0,RETFIN	;IF ZERO, NAME ENDS
	ADDI	0,40
	IDPB	0,2
	SOJG	N,RETNAM
RETFIN:	GOODBY	(2)		;AND RETURN TO USER

GETQUO:	MOVEI	0,16		;OPEN IN DUMP MODE
	MOVE	1,STRBLK	;STR
	SETZ	2,		;NO BUFFERS
	OPEN	0,0		;OPEN IT
	 JRST	GETQU2		;CAN'T. ASSUME ZERO
	SETZM	FILBLK		;CLEAR LOOKUP BLOCK
	MOVE	0,[XWD FILBLK,FILBLK+1]
	BLT	0,FILBLK+.RBUSD	;ENOUGH FOR QUOTA INFO
	MOVEI	0,25		;SET RIBCNT
	MOVEM	0,FILBLK
	MOVSI	0,'UFD'		;EXTENSION
	MOVEM	0,FILBLK+.RBEXT
	GETPPN	0,		;OUR PPN
	 JFCL
	MOVEM	0,FILBLK+.RBNAM	;IS NAME
	MOVE	0,[XWD 1,16]	;GET MFD PPN
	GETTAB	0,		;FROM MONITOR
	 MOVE	0,[XWD 1,1]	;DEFAULT
	MOVEM	0,FILBLK+.RBPPN	;WHERE TO FIND UFD
	LOOKUP	0,FILBLK	;FIND IT
	 JRST	GETQU2		;HUNH??
	MOVE	0,FILBLK+.RBQTF	;GET FCFS
	SUB	0,FILBLK+.RBUSD	;MINUS USED
GETQU1:	RELEAS	0,		;FREE CHANNEL
	POPJ	P,		;RETURN
GETQU2:	SETZ	0,		;ZERO QUOTA
	JRST	GETQU1		;DONE
	PRGEND
	TITLE	MOUNTS - SUBROUTINE TO MOUNT AND DISMOUNT DEVICES
	SUBTTL	COMMENTS
	SEARCH	FORPRM

	COMMENT %

USAGE		CALL MOUNT(DEV,LOGNAM,LOCK,VID,PHYNAM,IERR)
		CALL MOUNT(DEV,LOGNAM,LOCK,VID,PHYNAM,IERR,REELID)
	WHERE	DEV - IS ASCII NAME OF DEVICE TO MOUNT. THE NAME MAY BE
			PHYSICAL OR GENERIC, BUT MUST NOT BE A TTY, DSK, OR
			FILE STRUCTURE. ARGUMENT MAY BE SINGLE OR DOUBLE PRECISION.
		LOGNAM -  IS LOGICAL NAME TO GIVE TO THE DEVICE.
		LOCK - SIGNAL WHETHER TO WRITE ENABLE TAPE. VALID ONLY
			FOR DECTAPE AND MAGTAPE.
			0 = WRITE LOCKED
			1 = WRITE ENABLED
		VID - VISUAL IDENTIFICATION STRING. ASCII STRING OF
			UP TO 25 LETTERS,DIGITS,PERIODS, AND HYPHENS
			TERMINATED BY A BLANK OR UP TO 50 CHARACTERS
			 ENCLOSED IN QUOTES (' OR ")
		PHYNAM -  IS PHYSICAL NAME OF DEVICE OBTAINED,
			IF ANY. THIS SHOULD BE A DOUBLE PRECISION ARGUMENT,
			SINCE 510/602 USES SIX CHARACTER DEVICE NAMES.
			IF THE ARGUMENT IS SINGLE PRECISION, ONLY
			FIVE CHARACTERS WILL BE RETURNED.
		IERR - IS AN ERROR CODE.
			0 = NO ERRORS. DEVICE OBTAINED.
			1 = DEV IS NOT RECOGNIZED OR DOES NOT EXIST
			2 = LOGNAM IS ALREADY IN USE OR IS ZERO.
			3 = NO MOUNT JOB RUNNING
			-1 = MOUNT UNSUCCESSFUL
		REELID - OPTIONAL ARGUMENT FOR MTA ONLY, GIVING REELID OF TAPE


USAGE		CALL DISMOU(LOGNAM,IERR)
	WHERE	LOGNAM - IS LOGICAL OR PHYSICAL NAME OF DEVICE TO DISMOUNT
		IERR - IS ERROR CODE
			0 = NO ERROR. DISMOUNT SUCCESSFUL
			1 = ILLEGAL OR NONEXISTENT DEVICE NAME
			-1 = DISMOUNT UNSUCCESSFUL

	%
	SUBTTL	DATA AREA

CH=14
NUM=13
WD=12
M=11
N1=10
N=7

.ERPRT==2
.ERIPP==1
.ERFBM==3
.ERNRM==14

DSKCHN:	XWD 400000,0
	Z
	XWD	OBUF,0
OBUF:	BLOCK	3
	SUBTTL	CHECK ARGUMENTS FOR MOUNT

	HELLO	(MOUNT, )	;MOUNT ENTRANCE
	PUSHJ	P,MNTON		;SEE IF THE RIGHT MOUNT IS RUNNING
	JRST	ERR3		;IT ISN'T
	MOVEI	3,0(L)		;GET SIXBIT ARGUMENT
	PUSHJ	P,ASC6..##	;FROM USERS ASCII ONE
	JUMPE	2,ERR1		;ERROR IF NO DEVICE
	MOVEM	2,PHYNAM#
	DEVCHR	2,200000	;GET CHARACTERISTICS
	JUMPE	2,ERR1		;DOESN'T EXIST
	TLNE	2,230010	;IF DISK OR TTY, REJECT IT
	JRST	ERR1
	SKIPN	@1(L)		;GET LOGNAM
	JRST	ERR2		;ZERO IS AN ERROR
	MOVEI	3,1(L)		;ADDRESS OF ARGUMENT
	PUSHJ	P,ASC6..##	;CONVERT ARGUMENT TO SIXBIT
	JUMPE	2,ERR2		;ZERO IN SIXBIT ALWAYS ILLEGAL
	MOVEM	2,LOGSIX#	;SAVE IT FOR LATER
	DEVCHR	2,
	JUMPN	2,ERR2		;EXISTENCE OF LOGNAM IS AN ERROR
	SUBTTL	ENTER MOUNT REQUEST
	MOVSI	NUM,'M  '
	PUSHJ	P,QSTART
	MOVEI	M,[ASCIZ\ MOUNT \]
	PUSHJ	P,MSG
	MOVE	M,PHYNAM	;GET DEVICE GENERIC NAME
	PUSHJ	P,SIXMSG	;OUT IT
	PUSHJ	P,SPACE
	MOVE	M,LOGSIX	;LOGICAL NAME DESIRED
	PUSHJ	P,SIXMSG	;OUT IT
	MOVE	0,PHYNAM	;GET DEVICE NAME
	DEVCHR	0,200000	;SEE WHAT IT IS
	TLNN	0,DV.MTA	;MAG TAPE?
	 JRST	NOREEL		;NO. DON'T LOOK FOR REELID
IFN F40LIB,<
	TLNN	L,-1		;IS IT F40 CALL?
	 JRST	REEF10		;NO. F10
	HLRZ	0,6(L)		;GET ARG WORD
	ANDI	0,777037	;CLEAR AC BITS
	CAIE	0,(JUMP)	;IS IT AN ARG?
	 JRST	NOREEL		;NO
	JRST	REELID		;YES. GET IT
REEF10:>
	HLRE	0,-1(L)		;GET ARG COUNT
	MOVN	0,0		;MAKE IT POSITIVE
	CAIGE	0,^D7		;AT LEAST NUMBER 7
	 JRST	NOREEL		;NO. NO REELID
REELID:	SKIPN	3,@6(L)		;ANY ARGUMENT?
	 JRST	NOREEL		;NO
	MOVEI	3,6(L)		;ADDRESS OF REELID ARGUMENT
	PUSHJ	P,ASC6..##	;CONVERT IT TO SIXBIT
	JUMPE	2,NOREEL	;ANY NOW?
	MOVEI	M,[ASCIZ" /REELID: "]
	PUSHJ	P,MSG		;PUT SWITCH IN FILE
	MOVE	M,2		;MOVE ID
	PUSHJ	P,SIXMSG	;PUT IT IN FILE
NOREEL:	LDB	CH,[POINT 7,@3(L),6]
	SETZM	VIDCNT#		;COUNT OF CHARACTERS IN VID
	SETZM	VIDQT#		;FLAG FOR QUOTES AROUND VID
	SKIPE	@3(L)		;ANY ID?
	PUSHJ	P,VIDCH		;IS EVEN THE FIRST CHARACTER LEGAL?
	 JRST	VIDDON		;NO
	MOVEI	M,[ASCIZ\ /VID:\]
	PUSHJ	P,MSG
	SETZM	VIDCNT#		;COUNT OF CHARACTERS IN VID
	SETZM	VIDQT#		;FLAG FOR QUOTES AROUND VID
	MOVEI	1,@3(L)
	HRLI	1,440700
VIDOU2:	ILDB	CH,1
	PUSHJ	P,VIDCH
	 JRST	VIDDON		;NOT LEGAL CHARACTER SO DONE
	PUSHJ	P,W.CMD
	JRST	VIDOU2
VIDDON:	MOVE	0,PHYNAM
	DEVCHR	0,200000
	TLNN	0,DV.DTA!DV.MTA		;DECTAPE OR MAGTAPE?
	JRST	NOSWIT		;NEITHER. NO /WX
	MOVEI	M,[ASCIZ\ /WL\]
	SKIPE	@2(L)
	MOVEI	M,[ASCIZ\ /WE\]
	PUSHJ	P,MSG
NOSWIT:	PUSHJ	P,CRLF
	CLOSE	0,
	RELEAS	0,
	MOVE	0,SVJBFF
	MOVEM	0,.JBFF
	PUSHJ	P,WAITUP	;WAIT WHILE OMOUNT PROCESS IT
	LDB	1,[POINT 4,4(L),12]
	PUSHJ	P,TYPE..##	;GET SINGLE/DOUBLE PRECISION
	MOVE	N,0		;COPY IT
	MOVEI	2,@4(L)		;GET ARGUMENT ADDRESS
	MOVE	1,[ASCII "     "];FIVE SPACES
	MOVEM	1,(2)		;STORE IT
	CAILE	N,5		;DOUBLE PRECISION ARG?
	MOVEM	1,1(2)		;YES. STORE IN SECOND WORD ALSO
	HRLI	2,440700	;SET UP BYTE POINTER TO STORE NAME
	MOVE	1,LOGSIX	;GET BACK LOGICAL NAME
	DEVNAM	1,		;IS IT DEFINED? (GET PHYSICAL NAME IN 1)
	 JRST	ERRM1		;NO. BAD MOUNT
RETNAM:	SETZ	0,
	LSHC	0,6
	JUMPE	0,RETFIN	;IF ZERO, NAME ENDS
	ADDI	0,40
	IDPB	0,2
	SOJG	N,RETNAM
RETFIN:	SETZM	@5(L)
	GOODBY	(6)
	SUBTTL	ERROR ROUTINES
ERRM1:	MOVE	2,PHYNAM	;SEE IF PROBLEM IS "NOT AVAILABLE"
	DEVCHR	2,200000
	TLNN	2,40		;IS IT?
	JRST	ERR4		;YES. GIVE THAT ERROR
	SETOM	@5(L)
	GOODBY	(6)
ERR4:	MOVEI	0,4
	JRST	ERR3A
ERR1:	MOVEI	0,1
	JRST	ERR3A
ERR2:	MOVEI	0,2
	JRST	ERR3A
ERR3:	MOVEI	0,3
ERR3A:	MOVEM	0,@5(L)
	GOODBY	(6)
ERRD1:	MOVEI	0,1
ERRD1A:	MOVEM	0,@1(L)
	GOODBY	(2)
ERRDM1:	SETOM	@1(L)
	GOODBY	(2)
ERRD2:	SKIPE	REASAN#		;SUCCESSFUL DEASSIGN
	JRST	ERRDM1		;NO
	SETZM	@1(L)		;YES
	GOODBY	(2)		;RETURN
	SUBTTL	DISMOUNT COMMAND
	HELLO	(DISMOU, )	;DISMOUNT ENTRY
	SKIPN	@0(L)
	JRST	ERRD1
	MOVEI	3,0(16)		;ADDRESS OF ARGUMENT
	PUSHJ	P,ASC6..##	;CONVERT TO SIXBIT
	JUMPE	2,ERRD1		;BLANK IS AN ERROR
	MOVEM	2,LOGSIX	;AND SAVE IT FOR LATER
	DEVCHR	2,		;GET CHARACTERISTICS.
	JUMPE	2,ERRD1		;NON-EXISTENCE IS AN ERROR
	MOVE	0,LOGSIX
	DEVNAM	0,
	 MOVE	0,LOGSIX	;TAKE WHAT WAS GIVEN IF IT WON'T TELL
	MOVEM	0,PHYNAM
	TLNE	2,DV.DTA!DV.MTA	;DECTAPE OR MAGTAPE?
	PUSHJ	P,UNLOAD	;YES. DO UNLOAD
	MOVE	1,LOGSIX	;DO DEASSIGN FIRST FOR OMOUNT VERSION 26
	SETZ	0,
	REASSI	0,
	MOVEM	0,REASAN#	;STORE ANSWER FROM REASSIGN
	PUSHJ	P,MNTON		;MAKE SURE MOUNT IS RUNNING
	 JRST	ERRD2		;NOT THERE
	MOVSI	NUM,'D  '
	PUSHJ	P,QSTART
	MOVEI	M,[ASCIZ/ DISMOUNT /]
	PUSHJ	P,MSG
	MOVE	M,PHYNAM
	PUSHJ	P,SIXMSG
	MOVEI	M,[ASCIZ\ /R\]
	PUSHJ	P,MSG
	PUSHJ	P,CRLF
	CLOSE	0,
	RELEAS	0,
	MOVE	0,SVJBFF
	MOVEM	0,.JBFF		;RESTORE .JBFF
	PUSHJ	P,WAKEUP	;WAKE UP OMOUNT
	JRST	ERRD2		;SEE WHETHER DEASSIGN WORKED, AND RETURN

UNLOAD:	MOVEI	0,16		;OPEN TAPE IN DUMP MODE
	MOVE	1,LOGSIX
	SETZ	2,
	OPEN	0,0
	 POPJ	P,		;OH WELL
	MTAPE	0,11		;UNLOAD TAPE
	RELEAS	0,		;AND GET RID OF IT
	POPJ	P,		;RETURN
	SUBTTL	CONSTRUCT FIRST PART OF QUEUE ENTRY
QSTART:	MOVE	0,[XWD 4,16]
	GETTAB			;GET PPN FOR QUEUE AREA
	 MOVE	0,[XWD 3,3]	;DEFAULT IS 3,3
	MOVEM	0,CMDPPN#
	MOVE	0,[XWD 15,16]
	GETTAB			;GET STRUCTURE FOR QUEUE AREA
	 MOVSI	0,'DSK'
	MOVEM	0,DSKCHN+1
	PJOB
	MOVEM	0,THSJOB#
	GETLIN
	MOVEM	0,TTYLIN#
	GETPPN
	JFCL
	MOVEM	0,USRPPN#
	TSO	0,0		;OR HALFS SWAPPED
	HRRZM	0,IORPPN#
	OPEN	0,DSKCHN
	 HALT	.
	SETZM	CMDNAM#
	MOVEI	0,^D10
	MOVEM	0,ENTERS#
FILCL1:	HLLZ	WD,NUM
	TIMER	CH,		;FORM A NAME
	ANDI	CH,7777		;TWELVE BITS FROM TIMER
	TLO	WD,(CH)		;IN LEFT HALF OF WORD
	IOR	WD,IORPPN	;RH OF NAME IS IOR'D PPN
	CAMN	WD,CMDNAM
	JRST	FILCL1		;DON'T RETRY SAME NAME
	MOVEM	WD,CMDNAM	;STORE NAME
	MOVE	0,CMDNAM
	MOVSI	1,'CMD'
	SETZ	2,
	MOVE	3,CMDPPN
	LOOKUP	0,0		;IS THIS NAME FREE?
	 TRNE	1,-1		;MAYBE
	JRST	FILCL1		;NO
	MOVSI	1,'CMD'
	SETZ	2,
	MOVE	3,CMDPPN
	ENTER	0,0
	 JRST	ENTFAI		;CHECK ON ENTER FAILURE
	MOVE	0,.JBFF##
	MOVEM	0,SVJBFF#
	OUTBUF	0,1
	MOVE	M,NUM
	PUSHJ	P,SIXMSG
	MOVEI	M,[ASCIZ/ JOB/]
	PUSHJ	P,MSG
	MOVE	N,THSJOB	;JOB NUMBER
	PUSHJ	P,DECPRT
	PUSHJ	P,SPACE
	SKIPN	M,TTYLIN
	MOVE	M,[SIXBIT/TTYXXX/]
	PUSHJ	P,SIXMSG
	PUSHJ	P,SPACE
	HLRZ	N,USRPPN
	PUSHJ	P,OCTPRT
	PUSHJ	P,COMMA
	HRRZ	N,USRPPN
	PUSHJ	P,OCTPRT
	PUSHJ	P,SPACE
	MOVSI	M,'1  '
	PUSHJ	P,SIXMSG
	POPJ	P,
ENTFAI:	HRRZS	1
	SOSG	ENTERS
	JRST	ENTFI1
	CAIN	1,.ERPRT	;PROTECTION FAILURE?
	JRST	FILCL1		;YES, TRY ANOTHER NAME.
	CAIN	1,.ERFBM	;FILE BEING MODIFIED?
	JRST	FILCL1		;YES, TRY ANOTHER NAME
ENTFI1:	MOVEI	M,[ASCIZ/?SYSTEM ERROR ENTERING MOUNT REQUEST
/]
	CAIN	1,.ERNRM	;OUT OF ROOM?
	MOVEI	M,[ASCIZ/?NO ROOM TO ENTER MOUNT REQUEST
/]
	CAIN	1,.ERIPP	;NO SUCH UFD?
	MOVEI	M,[ASCIZ/?NO UFD FOR MOUNT REQUEST
/]
	OUTSTR	0(M)
	HALT	.
	SUBTTL	IO SUBROUTINES
SPACE:	MOVEI	CH," "
	PJRST	W.CMD
COMMA:	MOVEI	CH,","
;	PJRST	W.CMD
W.CMD:	SOSLE	OBUF+2
	JRST	W.CDOK
	OUTPUT	0,0
	STATZ	0,740000		;ANY ERRORS?
	HALT	.
W.CDOK:	IDPB	CH,OBUF+1
	POPJ	P,

CRLF:	MOVEI	M,[ASCIZ/
/]
MSG:	HRLI	M,440700
MSGL:	ILDB	CH,M
	JUMPE	CH,CPOPJ
	PUSHJ	P,W.CMD
	JRST	MSGL

OCTPRT:	IDIVI	N,10
	HRLM	N1,0(P)
	SKIPE	N
	PUSHJ	P,OCTPRT
	HLRZ	CH,0(P)
	ADDI	CH,"0"
	PJRST	W.CMD

DECPRT:	IDIVI	N,^D10
	HRLM	N1,0(P)
	SKIPE	N
	PUSHJ	P,DECPRT
	HLRZ	CH,0(P)
	ADDI	CH,"0"
	PJRST	W.CMD

SIXMSG:	PUSH	P,M
	MOVE	M,[POINT 6,0(P)]
SIXMSL:	ILDB	CH,M
	JUMPE	CH,MPOPJ	;STOP ON FIRST NULL
	ADDI	CH,40
	PUSHJ	P,W.CMD
	TLNE	M,770000	;OR ON SIX OUT
	JRST	SIXMSL
MPOPJ:	POP	P,M
	POPJ	P,
	SUBTTL	MISC.

VIDCH:	SKIPE	VIDQT		;IN QUOTES?
	 JRST	QUOTVD		;YES.
	SKIPE	VIDCNT		;FIRST CHARACTER?
	 JRST	VIDCHO		;NO. OLD KIND
	CAIE	CH,"'"		;IS IT QUOTED?
	CAIN	CH,42		;(")
	 JRST	QTVID		;YES. REMEMBER
VIDCHO:	AOS	2,VIDCNT	;COUNT CHARACTERS
	CAILE	2,^D25		;ALREADY DONE 25?
	 POPJ	P,		;YES
	CAIE	CH,"."
	CAIN	CH,"-"
	JRST	CPOPJ1
	CAIL	CH,"0"
	CAILE	CH,"Z"
	JRST	CPOPJ
	CAILE	CH,"9"
	CAIL	CH,"A"
	JRST	CPOPJ1
	JRST	CPOPJ

QTVID:	MOVEM	CH,VIDQT	;REMEMBER THE QUOTES
	AOS	VIDCNT		;REMEMBER THE CHARACTER
	JRST	CPOPJ1		;RETURN

QUOTVD:	CAMN	CH,VIDQT	;CLOSING QUOTE?
	 PJRST	W.CMD
	AOS	2,VIDCNT	;OR LIMIT REACHED?
	CAILE	2,^D50		;...
	 POPJ	P,		;YES
	CAIL	CH,40		;LESS THAN A SPACE?
	CAIL	CH,175		;AND LESS THAN OLD ALTMODES?
	 POPJ	P,		;RETURN. DONE
	JRST	CPOPJ1		;OK
WAITUP:	PUSHJ	P,WAKEUP
WAIT1:	MOVEI	0,5
	MOVE	1,[XWD ^D60000,400024]
	HIBER	1,
	 SLEEP
	OPEN	0,DSKCHN
	 JRST	WAIT1
	MOVE	0,CMDNAM
	MOVSI	1,'CMD'
	SETZ	2,
	MOVE	3,CMDPPN
	LOOKUP	0,0		;SEE IF IT IS STILL THERE
	 TRNE	1,-1		;MAYBE
	JRST	WAIT1		;YES
	RELEAS	0,		;GET RID OF CHANNEL
	POPJ	P,

WAKEUP:	MOVEI	1,1
WAKE1:	HRLZ	0,1
	HRRI	0,2		;LOOK AT PPN
	GETTAB
	 SETZ	0,
	CAME	0,[XWD 1,2]	;IS IT 1,2?
	 JRST	WAKEND
	HRLZ	0,1
	HRRI	0,3		;GET NAME
	GETTAB
	 SETZ	0,
	CAME	0,[SIXBIT/OPROMO/]
	CAMN	0,[SIXBIT/OPRMNT/]
	JRST	.+2
	JRST	WAKEND
	MOVE	0,1
	WAKE
	 POPJ	P,		;GIVE UP ON FAILURE
WAKEND:	CAMGE	1,JOBS		;DONE YET?
	AOJA	1,WAKE1		;NO
	POPJ	P,
MNTON:	MOVE	0,[XWD 15,11]	;GET NUMBER OF JOBS
	GETTAB
	 MOVEI	0,^D64+1		;DEFAULT IF WON'T TELL
	HRRZS	0
	SUBI	0,1		;DON'T COUNT NULL JOB
	MOVEM	0,JOBS#
	MOVEI	1,1		;START WITH JOB 1
RUNLOP:	HRLZ	2,1
	HRRI	2,2		;SET UP TO LOOK AT PPN
	GETTAB	2,
	 SETZ	2,
	CAME	2,[XWD 1,2]	;IS IT 1,2?
	JRST	RUNEND		;NO
	HRLZ	2,1
	HRRI	2,3		;LOOK AT PROG NAME
	GETTAB	2,
	 SETZ	2,
	CAME	2,[SIXBIT/OPROMO/]
	CAMN	2,[SIXBIT/OPRMNT/]
	JRST	CPOPJ1
RUNEND:	CAMGE	1,0
	AOJA	1,RUNLOP	;NOT DONE, SO LOOP
	SKIPA
CPOPJ1:	AOS	(P)
CPOPJ:	POPJ	P,
	PRGEND
	TITLE	RENAMS
	SUBTTL	SUBROUTINE TO RENAME,PROTECT, AND DELETE FILE.
REMARK	WRITTEN BY NORM GRANT. WMU.
REMARK	CKNAME IS AN ASCII TO SIXBIT CONVERTER AND NAME CHECKER.
	SEARCH	FORPRM
;
COMMENT	%

USAGE			CALL DELETE(NAME)
			CALL PROTEK(PROT,NAME)
			CALL RENAME(NAME1,NAME2)
			CALL RENAMS(IDEV,IFUNCT,NAME1,NAME2,PROT)

	WHERE	NAME1	ASCII FILE NAME, TWO WORD,CURRENT FILE NAME.
		NAME2	ASCII FILE NAME, TWO WORD, DESIRED FILE NAME.
		IDEV	FORTRAN DEVICE NUMBER.
		IFUNCT	FUNCTION TO PERFORM.
			1:DELETE
			2:PROTECT
			3:RENAME
			4:RENAME AND PROTECT
			5:DELETE EXISTING FILE OF NAME2,AND RENAME
			6:DELETE EXISTING FILE OF NAME2, RENAME, AND PROTECT
			OTHER: NO OPERATION.
		PROT	OCTAL PROTECTION CODE.
%

	-3,,0
CK1:	JUMP	0,0
	JUMP	0,NAME
	JUMP	0,IERR#

	-5,,0
%1M:	JUMP	0,[0]
	JUMP	0,[1]
D1:	JUMP	0,0
	JUMP	0,[0]
	JUMP	0,[0]

	-5,,0
%2M:	JUMP	0,[0]
	JUMP	0,[2]
$P2:	JUMP	0,0
	JUMP	0,[0]
$P1:	JUMP	0,0

	-5,,0
%3M:	JUMP	0,[0]
	JUMP	0,[3]
R1:	JUMP	0,0
R2:	JUMP	0,0
	JUMP	0,[0]
	HELLO	(DELETE, )		;DELETE ENTRY
	MOVEI	0,@0(16)
	HRRM	0,D1
	PUSH	P,16
	MOVEI	16,%1M
	PUSHJ	P,RENAMS
	POP	P,16
	GOODBY	(1)

	HELLO	(PROTEK, )		;PROTECT ENTRY
	MOVEI	0,@0(16)
	HRRM	0,$P1
	MOVEI	0,@1(16)
	HRRM	0,$P2
	PUSH	P,16
	MOVEI	16,%2M
	JRST	PREREN

	HELLO	(RENAME, )		;RENAME ENTRY
	MOVEI	0,@0(16)
	HRRM	0,R1
	MOVEI	0,@1(16)
	HRRM	0,R2
	PUSH	P,16
	MOVEI	16,%3M
PREREN:	PUSHJ	P,RENAMS
	POP	P,16
	GOODBY	(2)

	HELLO	(RENAMS, )		;RENAMS ENTRY
	MOVE	1,@0(16)
	JUMPE	1,UNDEF
	PUSHJ	P,GTDV..##
	JUMPN	0,BOTH
UNDEF:	MOVSI	2,'DSK'
	MOVE	0,2		;COPY DEVICE NAME
	DEVCHR	0,		;SIMULATE GTDV..
BOTH:	MOVEM	2,DEVICE
	ANDI	0,177777
	JFFO	0,.+1
	SUBI	1,^D35
	MOVMS	1
	HRRM	1,INITS		;STORE MODE FOR INIT
	MOVEM	P,SAVP#
	SETZM	NAME+3
	MOVE	14,@1(16)
	JUMPLE	14,RETURN
	CAILE	14,6
	JRST	RETURN
	PUSHJ	P,@LIST-1(14)
	JRST	RETURN
LIST:	EXP	DEL,PRO,PRO,PRO,DELREN,DELREN
DEL1:	MOVEI	1,@3(16)
	CAIA
DEL:	MOVEI	1,@2(16)
	HRRM	1,CK1
	PUSHJ	P,CHNAME
	PUSHJ	P,INITS
	LOOKUP	0,NAME
	POPJ	P,
	SETZM	NAME
	SETZM	NAME+1
	SETZM	NAME+3
	RENAME	0,NAME
	JFCL
	POPJ	P,

PRO:	MOVEI	1,@2(16)
	HRRM	1,CK1
	PUSHJ	P,CHNAME
	PUSHJ	P,INITS
AGAIN:	LOOKUP	0,NAME
	JRST	NOFIL
	SETZM	NAME+3
	CAIG	14,2
	JRST	PRO1
	MOVE	1,3(16)
	HRRM	1,CK1
	PUSH	P,NAME+1
	PUSHJ	P,CHNAME
	POP	P,0
	HRRM	0,NAME+1	;DON'T MESS UP HIGH ORDER DATE
PRO1:	MOVE	0,14
	IDIVI	0,2
	JUMPN	1,PRO2
	MOVE	0,@4(16)
	DPB	0,[POINT	9,NAME+2,8]
PRO2:	RENAME	0,NAME
	JRST	RENERR
	POPJ	P,

DELREN:	PUSHJ	P,DEL1
	JRST	PRO

RETURN:	MOVE	P,SAVP
	RELEAS	0,0
	GOODBY	(5)
NAME:	BLOCK	4
BADNAM:	OUTSTR	[ASCIZ/ILLEGAL FILENAME./
]
	JRST	RETURN
NODEV:	OUTSTR	[ASCIZ/ DEVICE NOT AVAILABLE.
/]
	JRST	RETURN
RENERR:	OUTSTR	[ASCIZ/RENAME ERROR!
/]
	JRST	RETURN
NOFIL:	HLLZ	0,NAME+1
	JUMPN	0,TYPEIT
	MOVSI	0,'DAT'
	MOVEM	0,NAME+1
	JRST	AGAIN
TYPEIT:	OUTSTR	[ASCIZ/NO SUCH FILE.
/]
	JRST	RETURN

INITS:	INIT	0,16
DEVICE:	0
	0
	JRST	NODEV
	POPJ	P,

CHNAME:	PUSH	P,16
	MOVEI	16,CK1
	PUSHJ	P,CKNAME##
	POP	P,16
	SKIPN	IERR
	POPJ	P,
	JRST	BADNAM

	PRGEND
	TITLE	CKNAME
	SUBTTL SUBROUTINE TO TRANSLATE FILENAMES.
REMARK	WRITTEN BY NORM GRANT. WMU.
	SEARCH	FORPRM

COMMENT	%
USAGE		CALL CKNAME(NAME1,NAME2,IERR)
	WHERE   NAME IS FILENAME.EXT(MUST BE A TWO WORD
		QUANTITY.)
	NAME2: FILENAME.EXT IN SIXBIT FORMAT(TWO WORDS.)
			(RETURNED.)
		IERR:	ERROR CODE RETURNED.
			IERR=0  ALL RIGHT.
			IERR=-1  ILLEGAL.
			IERR=1  WARNING. IMBEDDED SPACE(S)OR OVERLENGTH NAME.

%

POINTN:	POINT 7,0,	;POINTER TO ASCII NAME.
POINTS:	POINT 6,NAME,	;POINTER TO SIXBIT NAME.
POINTE:	POINT 6,NAME+1,	;POINTER TO SIXBIT EXTENSION.
POINT:	0
NAME:	BLOCK 2	;FILE-NAME BLOCK.
	;
	HELLO	(CKNAME, )
	SETZ	4,
	SETZM	@2(16)
	MOVSI	0,440700	;SET UP POINTER TO NAME
	ADDI	0,@0(16)
	MOVEM	0,POINTN	;STORE POINTER TO ASCII NAME.
	MOVE	0,POINTS
	MOVEM	0,POINT	;STORE POINTER TO SIXBIT NAME.
	SETZM	NAME	;ZERO SIXBIT NAME AND EXTENSION.
	SETZM	NAME+1
	MOVEI	3,^D10
	MOVEI	1,6	;SET COUNTER TO 6 CHARACTERS MAXIMUM.
L1:	ILDB	2,POINTN	;LOAD CHARACTER TO AC2.
	SOJ	3,
	CAIN	2,"."
	JRST	ENDNAM	;IF PERIOD, END FILE-NAME.
	JSR	CHK
	SOJG	1,L1	;CHECK FOR END OF LOOP, AND JUMP ELSE.
	ILDB	2,POINTN	;CHECK FOR NULL EXTENSION.
	SOJ	3,
	CAIE	2,"."
	JRST	BLANK1
ENDNAM:	SETO	4,
	MOVEI	1,3	;SET COUNTER TO 3 CHARACTERS MAXIMUM.
	MOVE	0,POINTE
	MOVEM	0,POINT	;STORE POINTER TO SIXBIT EXTENSION.
L2:	ILDB	2,POINTN
	SOJ	3,
	JSR	CHK
	SOJG	1,L2	;CHECK FOR END OF LOOP.
ENDEXT:
END1:	SKIPN	NAME
ILNAM:	SETOM	@2(16)
RETURN:	MOVEI	0,@1(16)
	SOJ	0,
	PUSH	0,NAME
	PUSH	0,NAME+1
	GOODBY	(3)
BLANK:	SOJL	3,ENDEXT
	ILDB	2,POINTN
BLANK1:	CAIN	2," "
	JRST	BLANK
IMBED:	MOVEI	0,1
	MOVEM	0,@2(16)
	JRST	END1
CHK:	0
	CAIN	2," "
	JRST	BLANK	;IF SPACE, END FILE-NAME AND EXTENSION.
	CAIGE	2,"0"
	JRST	ILNAM	;CHECK FOR ILLEGAL CHARACTERS.
	CAIG	2,"9"
	JRST	OKBIT
	CAIL	2,"A"
	CAILE	2,"Z"
	JRST	ILNAM
OKBIT:	MOVEI	2,40(2)		;CONVERT TO SIXBIT.
	IDPB	2,POINT	;AND STORE IN NAME BLOCK.
	JRST	@CHK
PRGEND
	TITLE	GTDV..

	SEARCH	FORPRM
IFNDEF FTWMU,<FTWMU==0>
	ENTRY	GTDV..

GTDV..:	LDB	1,[POINT 4,@0(16),12]	;GET ARG TYPE
	PUSHJ	P,TYPE..##	;AND FIND IF ITS DOUBLE
	CAIE	0,5		;SINGLE?
	 JRST	ASCII2		;NO.
	MOVE	1,@0(16)	;GET DEVICE NAME OR NUMBER
	JUMPE	1,ERMSG		;ZERO IS ILLEGAL
	SETCM	2,1		;COMPLEMENT IT
	TLNN	2,-1		;DEFAULT DEVICE?
	JRST	NEG		;YES
	TLNE	1,-1		;ASCII DEVICE NAME
	JRST	ASCII2		;YES
	MOVEI	2,6(1)		;GET FOROTS INTERNAL FLU NUMBER
	CAILE	2,FLU.MX+6	;IN RANGE?
	 JRST	ERMSG		;NO. ILL NUMBER
	IDIVI	2,6		;SIX ENTRIES PER WORD
	IMULI	3,6		;NUMBER OF BITS LEFT
	ROT	3,-6		;POSITION FOR THE BYTE POINTER
	HRRZ	4,.JBOPS##	;BASE FOR OTS DATA
	IOR	3,[POINT 6,FLU.TB(4),35];SET THE SIZE FIELD
	ADDI	3,(2)		;POINT TO THE WORD ENTRY
	LDB	2,3		;LOAD THE CHANNEL ENTRY
	ADDI	2,CHN.TB(4)	;SET THE OFFSET FOR CHANNEL CONTROL WD
	SKIPN	3,(2)		;GET THE I/O REG
	 JRST	TRYLOG		;NOT OPEN. TRY LOGICAL NAME
	MOVE	2,DD.DEV(3)	;GET DEVICE
	MOVE	0,DD.STS(3)	;GET DEVCHR STORED BY FOROTS
	POPJ	P,		;RETURN
TRYLOG:	MOVE	2,1
	ANDI	2,77
	IDIVI	2,^D10
	LSH	2,6
	IORI	2,2020(3)
	CAIGE	2,2120		;SIXBIT 10, RIGHT JUSTIFIED
	LSH	2,6
	LSH	2,^D24
	MOVE	0,2
	DEVCHR	0,
	JUMPN	0,CPOPJ
GETDV1:
IFN FTWMU,<
	MOVE	3,.JBOPS##
	CAMLE	1,DEV.SZ(3)	;ABOVE MAXIMUM?
	JRST	DEFDSK		;YES, ASSUME DSK
	MOVE	3,DEV.TB(3)	;ADDRESS OF DEVTAB
	ADDI	3,(1)		;OFFSET FROM DEVTAB
	SKIPN	2,(3)		;GET DEVICE NAME
>
IFE FTWMU,<
	CAILE	1,DEV.SZ	;ABOVE MAXIMUM?
	JRST	DEFDSK		;YES, ASSUME DSK
	SKIPN	2,DEVTB.(1)	;GET DEVICE NAME
>
DEFDSK:	MOVSI	2,'DSK'		;NO. USE DSK
	JRST	DODEV		;NOW GO RETURN DEVCHR
NEG:	CAML	1,[-5]		;NEGATIVE NUMBER OK?
	JRST	GETDV1		;YES
ASCII2:	MOVEI	3,0(16)		;ADDRESS OF ARG POINTER
	PUSHJ	P,ASC6..##	;GET SIXBIT FOR NAME
DODEV:	MOVE	0,2
	DEVCHR	0,
CPOPJ:	POPJ	P,
ERMSG:	OUTSTR	[ASCIZ/ILLEGAL DEVICE NUMBER!
/]
	MOVEI	16,[EXP 0,0]+1	;ARG FOR EXIT
	PUSHJ	P,EXIT.##
IFE FTWMU,<
;COPY FOR DEVTB.
	SIXBIT	.REREAD.	;-6;	REREAD
	SIXBIT	.CDR.		;-5;	READ
	SIXBIT	.TTY.		;-4;	ACCEPT
	SIXBIT	.LPT.		;-3;	PRINT
	SIXBIT	.PTP.		;-2;	PUNCH
	SIXBIT	.TTY.		;-1;	TYPE
DEVTB.:	Z			;00;	ILLEGAL DEVICE NUMBER
	SIXBIT	.DSK.		;01;	DISC
	SIXBIT	.CDR.		;02;	CARD READER
	SIXBIT	.LPT.		;03;	LINE PRINTER
	SIXBIT	.CTY.		;04;	CONSOLE TELETYPE
	SIXBIT	.TTY.		;05;	USER'S TELETYPE
	SIXBIT	.PTR.		;06;	PAPER TAPE READER
	SIXBIT	.PTP.		;07;	PAPER TAPE PUNCH
	SIXBIT	.DIS.		;08;	DISPLAY
	SIXBIT	.DTA1.		;09;	DECTAPE
	SIXBIT	.DTA2.		;10;
	SIXBIT	.DTA3.		;11;
	SIXBIT	.DTA4.		;12;
	SIXBIT	.DTA5.		;13;
	SIXBIT	.DTA6.		;14;
	SIXBIT	.DTA7.		;15;
	SIXBIT	.MTA0.		;16;	MAG TAPE
	SIXBIT	.MTA1.		;17;
	SIXBIT	.MTA2.		;18;
	SIXBIT	.FORTR.		;19;
	SIXBIT	.DSK.		;20;
	SIXBIT	.DSK.		;21;
	SIXBIT	.DSK.		;22;
	SIXBIT	.DSK.		;23;
	SIXBIT	.DSK.		;24;
	SIXBIT	.DEV1.		;25;
	SIXBIT	.DEV2.		;26;
	SIXBIT	.DEV3.		;27;
	SIXBIT	.DEV4.		;28;
	SIXBIT	.CDP.		;29;
	SIXBIT	.TTY.		;30;
DEV.SZ==.-DEVTB.-1
>
	PRGEND
	TITLE	ASC6..
	SEARCH	FORPRM
	ENTRY	ASC6..
	CH==14

;USAGE	MOVEI	3,ADR OF ARGUMENT POINTER
;	PUSHJ	P,ASC6..##
;	 ALWAYS RETURNS HERE WITH SIXBIT IN 2
;	  USES 0,1,2,3,4,14

ASC6..:	LDB	1,[POINT 4,(3),12]	;GET TYPE OF ARGUMENT
	PUSHJ	P,TYPE..##	;GET NUMBER OF CHARACTERS TO READ
	MOVEI	3,@(3)		;GET ADDRESS OF STRING
	HRLI	3,440700	;AND SET UP POINTER
	MOVE	4,[POINT 6,2]
	SETZ	2,
ASCSX1:	ILDB	CH,3
	CAIG	CH," "
	POPJ	P,
	CAIGE	CH,140		;LOWER CASE DOESN'T NEED THE +40
	ADDI	CH,40
	IDPB	CH,4
	SOJG	0,ASCSX1
	POPJ	P,
	PRGEND
	TITLE	TYPE..
	SEARCH	FORPRM
	ENTRY	TYPE..
;	USAGE
;		LDB	1,[POINT 4,n(L),12]
;		PUSHJ	P,TYPE..##
;	RETURNS NUMBER OF CHARACTERS TO PICK UP IN 0
;	 IF F10, 6 IFF CODE IS 10,14,17
;	 IF F40, 6 IFF CODE IS 5,6,7
;	  ELSE 5

TYPE..:	MOVEI	0,6		;ASSUME WE WILL RETURN SIX CHARACTERS
IFN F40LIB,<
	TLNN	L,-1		;F40?
	 JRST	F10TYP		;NO. F10
	CAIL	1,5		;IS IT IN RANGE FOR DOUBLE WORD?
	CAILE	1,7		;..
	 SUBI	0,1		;NO. MAKE THE 6 A FIVE
	POPJ	P,
F10TYP:>
	CAIE	1,10		;IS IT DOUBLE WORD?
	CAIN	1,14		;..
	 POPJ	P,		;YES
	CAIE	1,17		;IS IT?
	SUBI	0,1		;NO
	POPJ	P,
	PRGEND
	TITLE	PRINTS - ROUTINE TO ENTER FILE IN PRINT QUEUE
	SUBTTL	USAGE INSTRUCTIONS

	SEARCH	FORPRM,QPRM,MACTEN,UUOSYM

; FORPRM IS UNIVERSAL FILE FROM FOROTS
; QPRM   IS UNIVERSAL FILE FOR QUEUE DEFINITIONS. SEE ...
; MACTEN IS UNIVERSAL FILE WITH USEFUL MACRO DEFINITIONS SEE ...
; UUOSYM IS UNIVERSAL FILE WITH UUO SYMBOLS DEFINITIONS SEE ...

COMMENT	%

THE PURPOSE OF THIS ROUTINE IS TO ENTER A REQUEST IN THE PRINT(SPOOL)
QUEUE FROM A FORTRAN OR MACRO PROGRAM.

CALLING SEQUENCE
	CALL PRINTS('FILENAME.EXT',IARG1,IARG2,IARG3)
OR
	CALL PRINTS('FILENAME.EXT',IARG1,IARG2,IARG3,IARG4)
WHERE
	FILENAME	6 OR FEWER CHARACTERS.
	EXT		3 OR FEWER CHARACTERS.(MAY BE NULL)
	IARG1		2 IF FILE IS TO BE RENAMED OUT OF AREA.
			1 IF FILE IS TO BE DELETED.
			0 IF FILE IS TO BE PRESERVED.
	IARG2		1 IF FORTRAN FORMATTED OUTPUT
			0 IF OTHER THAN FORTRAN FORMATTED OUTPUT
	IARG3		LESS THAN OR EQUAL 0 IMPLIES 1 COPY.
			GREATER THAN 63 IMPLIES 1 COPY.
			1-63 IMPLIES THAT NUMBER OF COPIES.
	IARG4		OPTIONAL PAGE LIMIT.[DEFAULT IF OMITTED IS
			(#BLOCKS WRITTEN)*COPIES+20]

%


	SUBTTL	DATA AND DEFINITIONS
; AC DEFINITIONS
	F=0
	A=1
	B=2
	C=3
	WD=4		;SIXBIT ANSWER FROM ASCSIX
	T1=WD
	BP6=5		;SIXBIT POINTER
	T2=BP6
	BP7=6		;ASCII POINTER
	T3=BP7
	N=7		;NUMBER
	T4=N
	CH=10		;CHARACTER
	T5=CH
	V=11		;POINTER TO ARG VECTOR
	QD=12		;QUE TYPE
	QF=13		;POINTER TO CURRENT FILE BLOCK IN QUE BLOCK
	Q=14		;POINTER TO QUE AREA
	SUBTTL	PRINTS - DO THE WORK
	HELLO	(PRINTS)		;PRINTS ENTRY
	MOVE	A,[BYTE(9).QOHED,Q.FMOD+1(18)1]	;1 FILE
	PUSHJ	P,GTINF$##	;GET SOME INFO AND INIT  QUE BLOCK
	SETZ	QD,		;MODE IS PRINT QUEUE
	PUSHJ	P,OPDSK$##	;OPEN THE DISK
	 JRST	NODSK

	HRRZI	A,111000	;SINGLE SPACED ASCII
	SKIPE	@2(16)
	ADDI	A,1000		;MAKE THAT FORTRAN
	MOVEM	A,Q.OMOD(Q)

	MOVEI	A,^D10		;DEFAULT PRIORITY IS 10
	MOVEM	A,Q.PRI(Q)

	MOVEI	B,.QFDDE	;ASSUME /DISP:DEL
	SKIPG	A,@1(16)	;IS IT /DISP:PRE?
	MOVEI	B,.QFDPR	;YES
	CAIN	A,2		;IS IT /DISP:REN
	MOVEI	B,.QFDRE	;YES
	DPB	B,[POINTR(Q.OMOD(Q),QF.DSP)]

	PUSHJ	P,FILNMO
	MOVEI	QF,Q.OSTR(Q)	;WHERE FILE IS
	PUSHJ	P,DOFIL$##	;GO DO THE FILE THINGS
	 JRST	NTFND		;FILE NOT FOUND

	SKIPLE	A,@3(16)	;/COPIES
	CAILE	A,^D63
	MOVEI	A,1
	DPB	A,[POINTR(Q.OMOD(Q),QF.COP)]

	IMUL	A,$RBSIZ##
	MOVE	B,A		;MAKE A COPY
	ASH	A,-^D10		;DIVIDE BY 1024
	ADDI	A,1
	HRRM	A,Q.OSIZ(Q)	;QS.BLK

	IDIVI	B,200
	ADDI	B,^D21		;FUDGE FACTOR
IFN F40LIB,<
	TLNN	16,-1		;F10?
	 JRST	CHKF10		;YES
	HLRZ	A,4(16)
	TRZ	A,740
	CAIE	A,(JUMP 0)
	JRST	DEFALT
	JRST	F40ARG
>
CHKF10:	HLRE	A,-1(16)
	MOVMS	A
	CAIGE	A,5		;LIMIT ARG?
	JRST	DEFALT		;NO
F40ARG:	SKIPLE	A,@4(16)
	MOVE	B,A		;ONLY ACCEPT ESTIMATE IF POSITIVE
	CAILE	B,777776	;LESS THAN MAX?
	MOVEI	B,777776	;NO
DEFALT:	HRLM	B,Q.OSIZ(Q)	;PAGE LIMIT (QS.LIM)

	PUSHJ	P,$DOQUE##	;ACTUALLY QUE THE FILE
	 JFCL			;ALREADY GAVE ERROR MESSAGE
	GOODBY	200004		;AT LEAST FOUR ARG RETURN

NODSK:	OUTSTR	[ASCIZ\
CANNOT INIT DISK!
\]
	GOODBY	200004
NTFND:	OUTSTR	[ASCIZ\
FILE NOT FOUND!
\]
	GOODBY	200004

FILNMO:	SETZB	A,B
	MOVEI	BP7,@(16)
	HRROI	N,-11		;NINE POSSIBLE CHARACTERS.
	HRLI	BP7,440700	;MAKE POINTER TO STRING.
	MOVE	BP6,[POINT 6,A]
GETCHR:	ILDB	CH,BP7
	JUMPE	CH,CPOPJ
	CAIN	CH,"."
	JRST	[HRROI	N,-3
		 MOVE	BP6,[POINT 6,B]
		 JRST	GETCHR]
	SUBI	CH,40
	IDPB	CH,BP6
	AOJL	N,GETCHR
CPOPJ:	POPJ	P,
	PRGEND
	TITLE	QUEOUT - ROUTINES TO MAKE OUTPUT QUEUE ENTRIES
	SUBTTL	USAGE INSTRUCTIONS

	SEARCH	FORPRM,QPRM,MACTEN,UUOSYM

; FORPRM IS UNIVERSAL FILE FROM FOROTS
; QPRM   IS UNIVERSAL FILE FOR QUEUE DEFINITIONS. SEE ...
; MACTEN IS UNIVERSAL FILE WITH USEFUL MACRO DEFINITIONS SEE ...
; UUOSYM IS UNIVERSAL FILE WITH UUO SYMBOLS DEFINITIONS SEE ...

COMMENT	%

USAGE	CALL QUEOUT(DEVICE,FILENAME,QUE,VECTOR,ERROR)

WHERE
	DEVICE - IS DEVICE FILE IS ON. (MUST BE SOME KIND OF DSK)

	FILENAME - IS TWO WORD ASCII FILENAME TO OUTPUT

	QUE      - IS ASCII NAME OF QUEUE TO PUT FILE IN
			(MAY BE LPT, CDP, PTP, OR PLT)

	IERR     - IS ERROR CODE
			VALUE	MEANING
			  0	   OK
			  1	UNDEFINED QUE
			  2	ILLEGAL DEVICE
			  3	ILLEGAL FILE NAME
			  4	NO SUCH FILE
			  5	ILLEGAL ARGUMENT IN VECTOR
			  6	CANNOT OPEN QUE DEVIE
			  7	CANNOT ENTER QUEUE COMMAND FILE

	VECTOR    - IS A FOURTEEN(14) WORD INTEGER ARRAY OF ARGUMENTS
		VECTOR(1)	/FILE: ARGUMENT
				 1=ASCII (DEFAULT)
				 2=FORTRAN DATA
				 3=COBOL
				 4=CREF(NOT IMPLEMENTED. ASSUMES ASCII)
				 5=RUNOFF(NOT IMPLEMENTED. ASSUMES ASCII)
				 6=ELEVEN
		VECTOR(2)	/LIMIT: ARGUMENT
		VECTOR(3)	/COPIES:N (FROM 1 TO 63)
		VECTOR(4)	/DISP:
				 1=PRESERVE
				 2=RENAME
				 3=DELETE
		VECTOR(5)	AFTER SWITCH PART ONE
				TIME OF DAY OR PLUS TIME IN MINUTES
				PLUS TIME IS INDICATED BY A NEGATIVE IN VECTOR(6)
		VECTOR(6)	AFTER SWITCH PART TWO
				DATE IN 15 BIT FORMAT OR ZERO FOR TODAY
				NEGATIVE INDICATES TIME IS PLUS FORMAT
		VECTOR(7)	DEADLINE SWITCH PART ONE. SAME AS AFTER
		VECTOR(8)	DEADLINE SWITCH PART TWO. SAME AS AFTER
		VECTOR(9)	/PRIORITY:(N+1)
				GIVE NUMBER IN RANGE 1 TO 63. ACTUAL
				PRIORITY IS ONE LESS. DEFAULT IT 10
		VECTOR(10)	/PAPER: ARGUMENT
			   VALUE		MEANING
					LPT      CDP      PTP      PLT
				1	ARROW(*) ASCII(*) ASCII(*) IMAGE
				2	ASCII    026      IMAGE    ASCII(*)
				3	OCTAL    BINARY   IMG BIN  BINARY
				4	SUPPRESS D029     BINARY
				5	         IMAGE

		VECTOR(11)	/HEAD:N
				 0=NO HEADER
				 1=FILE HEADER
		VECTOR(12)	/SPACING: ARGUMENT
				 1=SINGLE
				 2=DOUBLE
				 3=TRIPLE
		VECTOR(13)	/FORMS:NAME
				 FIRST FIVE CHARACTERS
		VECTOR(14)	  REMAINING CHARACTER TO FORMS NAME
				ASCII NAME OF SPECIAL FORMS TO USE

%
	SUBTTL	DEFINITIONS AND DATA

; BITS THAT WE MUST DEFINE BECAUSE FORPRM AND UUOSYM DISAGREE
DV.DSK==1B1		;DEVICE IS A DSK
DV.TTY==1B14		;DEVICE IS A TTY

; AC DEFINITIONS
	F=0
	A=1
	B=2
	C=3
	WD=4		;SIXBIT ANSWER FROM ASCSIX
	T1=WD
	BP6=5		;SIXBIT POINTER
	T2=BP6
	BP7=6		;ASCII POINTER
	T3=BP7
	N=7		;NUMBER
	T4=N
	CH=10		;CHARACTER
	T5=CH
	V=11		;POINTER TO ARG VECTOR
	QD=12		;QUE TYPE
	QF=13		;POINTER TO CURRENT FILE BLOCK IN QUE BLOCK
	Q=14		;POINTER TO QUE AREA

; FLAGS IN LH OF F
NEDREN==400000		;FLAG IN DOFIL$ THAT A RENAME IS NEEDED
LOGFIL==200000		;FLAG TO DOFIL$ THAT THIS IS THE LOG FILE
CTLFIL==100000		;FLAG TO DOFIL$ THAT THIS IS THE CTL FILE
QUENAM:	ASCII/LPT  /
	ASCII/CDP  /
	ASCII/PTP  /
	ASCII/PLT  /
QUESZ==.-QUENAM

; TABLE OF MAXIMUM LEGAL PAPER MODES BY DEVICE
MAXPAP:	%QFLSU		;LPT
	%QFCIM		;CDP
	%QFTBI		;PTP
	%QFPBI		;PLT

; TABLE OF DIVISORS FOR CALCULATING DEFAULT LIMITS
LIMDIV:	1		;LPT
	1		;CDP
	1		;PTP
	^D20		;PLT

; TABLE OF ADDITIONAL QUANTA FOR CALCULATING DEFAULT LIMITS
LIMADD:	^D20		;LPT
	^D100		;CDP
	^D20		;PTP
	^D5		;PLT

; TABLE OF DEFAULT MODES FOR CDP(LH),PTP(RH)
PUNMOD:	XWD %QFCAS,%QFTAS
	XWD %QFCAS,%QFTAS
	XWD     77,    77
	XWD     77,    77
	XWD     77,    77
	XWD     77,    77
	XWD     77,    77
	XWD     77,    77
	XWD %QFCIM,%QFTIM
	XWD     77,    77
	XWD     77,    77
	XWD %QFCIM,%QFTIB
	XWD %QFCBI,%QFTBI
	XWD     77,%QFTBI
	XWD %QFCBI,%QFTBI
	XWD %QFCBI,%QFTBI

FILDEV:	BLOCK	1		;DEVICE FILE IS ON
FILNAM:	BLOCK	2		;FILE NAME
FILEXT=FILNAM+1			;EXTENSION
	SUBTTL	QUEOUT - INITIALIZATION CODE

	HELLO	(QUEOUT)	;ENTRANCE
	MOVE	A,[BYTE(9).QOHED,Q.FMOD+1(18)1]
	PUSHJ	P,GTINF$##	;GET QUE DEVICE, OTHER INFO
	SKIPN	A,@2(16)	;SPECIFYING OUTPUT QUEUE?
	MOVE	A,QUENAM	;NO. ASSUME LPT
	MOVSI	QD,-QUESZ	;FIND IT IN TABLE
	CAME	A,QUENAM(QD)	;MATCH?
	 AOBJN	QD,.-1		;NO. TRY NEXT
	JUMPGE	QD,NOSUCH	;ANY MATCH?
	TLZ	QD,-1		;JUST KEEP INDEX
	PUSHJ	P,GETDEV	;GET THE DEVICE NAME
	 JRST	ILLDEV		;ILLEGAL
	PUSHJ	P,GETNAM	;GET THE FILE NAME
	 JRST	ILLNAM		;ILLEGAL
	MOVEI	A,16		;DUMP MODE
	MOVE	B,FILDEV	;DEVICE
	SETZ	C,		;NO BUFFERS
	OPEN	0,A		;OPEN DEVICE
	 JRST	ILLDEV		;CAN'T
	SUBTTL	QUEOUT - PICK UP VECTOR ARGUMENTS
	MOVEI	V,@3(16)	;SET ADDRESS OF ARG VECTOR
	SKIPG	A,(V)		;GET FILE:XX ARG
	MOVEI	A,.QFFAS	;DEFAULT IS ASCII
	CAILE	A,.QFF11	;LEGAL ARG?
	 JRST	ILLARG		;NO. ERROR
	CAIE	A,.QFFCR	;CREF?
	CAIN	A,.QFFRU	;RUNOFF?
	 MOVEI	A,.QFFAS	;TREAT AS ASCII
	DPB	A,[POINTR(Q.OMOD(Q),QF.FFM)]

	SKIPG	A,2(V)		;GET /COPIES:N
	 MOVEI	A,1		;DEFAULT ONE COPY
	CAILE	A,^D63		;LEGAL NUMBER?
	 MOVEI	A,^D63		;NO. MAXIMUM
	MOVEM	A,COPIES#	;REMEMBER
	DPB	A,[POINTR(Q.OMOD(Q),QF.COP)]

	SKIPG	A,3(V)		;GET /DISP:
	 MOVEI	A,.QFDPR	;DEFAULT IS PRESERVE
	CAILE	A,.QFDDE	;LEGAL DISPOSITION?
	 JRST	ILLARG		;NO. ERROR
	DPB	A,[POINTR(Q.OMOD(Q),QF.DSP)]

	DMOVE	A,4(V)		;GET /AFTER WORDS
	PUSHJ	P,DDAFT$##	;CONVERT TO PROPER FORMAT
	MOVEM	C,Q.AFTR(Q)	;STORE

	DMOVE	A,6(V)		;GET /DEADLINE WORDS
	PUSHJ	P,DDAFT$##	;CONVERT TO PROPER FORMAT
	MOVEM	C,Q.DEAD(Q)	;STORE

	SKIPG	A,^D8(V)	;GET /PRIORITY:N
	MOVEI	A,^D11		;DEFAULT IS 10
	CAILE	A,^D63		;LEGAL?
	MOVEI	A,^D63		;MAXIMUM
	SUBI	A,1		;REAL RANGE IS 0-62
	DPB	A,[POINTR(Q.PRI(Q),QP.PRI)]

	SKIPG	A,^D9(V)	;GET /PAPER:XXX SWITCH (PRINT,PLOT,PUNCH,TAPE)
	PUSHJ	P,DEFPAP	;GET DEFAULT PAPER MODE
	CAMLE	A,MAXPAP(QD)	;LEGAL?
	 JRST	ILLARG		;NO. ERROR
	DPB	A,[POINTR(Q.OMOD(Q),QF.PFM)]

	MOVSI	A,(QF.NFH)	;GET /HEAD:N
	SKIPLE	^D10(V)		;WANT A HEADER?
	IORM	A,Q.OMOD(Q)	;YES. SET IT

	SKIPG	A,^D11(V)	;GET /SPACE:XXX
	MOVEI	A,1		;DEFAULT IS SINGLE
	CAILE	A,3		;LEGAL?
	 JRST	ILLARG		;NO. ERROR
	DPB	A,[POINTR(Q.OMOD(Q),QF.SPC)]

	MOVEI	BP7,^D12(V)	;GET /FORMS SWITCH
	PUSHJ	P,ASC6.6##	;WHICH IS IN ASCII
	 JFCL			;ANY TERMINATOR OK
	MOVEM	WD,Q.OFRM(Q)	;STORE IT

	DMOVE	A,FILNAM	;GET FILE NAME
				;AND EXTENSION
	MOVEI	QF,Q.OSTR(Q)	;AND WHERE FILE BLOCK STARTS
	PUSHJ	P,DOFIL$##	;DO NECESSARY THINGS TO FILE
	 JRST	NOFILE		;FILE NOT FOUND

	MOVE	A,COPIES	;GET COPIES BACK
	IMUL	A,$RBSIZ##	;COMPUTE BLOCKS*COPIES/8
	IDIVI	A,^D1024
	ADDI	A,1
	HRRM	A,Q.OSIZ(Q)	;QS.BLK

	SKIPG	A,1(V)		;GET /LIMIT:N
	 PUSHJ	P,DEFLIM	;GET DEFAULT LIMIT BASED ON FILE SIZE
	CAILE	A,777776	;LEGAL SIZE?
	MOVEI	A,777776	;NO. MAKE MAXIMUM
	HRLM	A,Q.OSIZ(Q)	;QS.LIM

	PUSHJ	P,$DOQUE##	;GO ACTUALLY DO THE QUEING
	 JRST	ERRRET		;ERROR RETURN
	GOODBY	(5)		;RETURN
	SUBTTL	SUBROUTINE TO STORE COMPLEX DEFAULTS
DEFPAP:	JUMPE	QD,DFPAPL	;LPT.
	LDB	B,[POINT 4,$RBPRV##,12] ;GET FILE MODE
	CAIN	QD,3		;PLOTTER?
	 JRST	DFPAPP		;YES
	CAIN	QD,1		;CDP?
	 JRST	DFPAPC		;YES
DFPAPT:	HRRZ	A,PUNMOD(B)	;PTP. GET /TAPE BASED ON FILE MODE
	POPJ	P,
DFPAPP:	MOVEI	A,%QFPAS	;PLOT. ASSUME DEFAULT IS ASCII
	CAILE	B,1		;IS IT ASCII FILE?
	MOVEI	A,%QFPIM	;NO. USE OTHER MODE
	POPJ	P,
DFPAPC:	HLRZ	A,PUNMOD(B)	;CDP. GET /PUNCH BASED ON FILE MODE
	POPJ	P,
DFPAPL:	MOVEI	A,%QFLAR	;LPT. DEFAULT IS ARROW
	POPJ	P,

DEFLIM:	MOVE	A,$RBSIZ##	;GET FILE SIZE IN WORDS
	IMUL	A,COPIES	;TIMES COPIES
	IDIVI	A,^D128		;CONVERT TO BLOCKS
	SKIPE	B
	ADDI	A,1		;AND FRACTION
	IDIV	A,LIMDIV(QD)	;CALCULATE LIMIT
	ADD	A,LIMADD(QD)	;BASED ON DEVICE
	POPJ	P,		;RETURN
	SUBTTL	SUBROUTINES TO READ ASCII ARGS
GETNAM:	MOVEI	BP7,@1(16)	;GET ADDRESS OF ARGUMENT
	PUSHJ	P,ASC6.6##	;READ THE FILE NAME
	 JRST	GETNM1		;FUNNY TERMINATOR
	ILDB	CH,BP7		;GET THE TERMINATOR
GETNM1:	JUMPE	WD,CPOPJ	;ERROR
	MOVEM	WD,FILNAM	;STORE FILE NAME
	SETZM	FILEXT
	CAIN	CH," "		;NO EXTENSION?
	 JRST	CPOPJ1		;YES. OK
	CAIE	CH,"."		;EXTENSION COMING?
	 POPJ	P,		;NO. ERROR
	MOVEI	N,3		;NOW GET EXTENSION
	PUSHJ	P,ASC6.C##	;CONTINUING ON
	 JRST	GETNM3		;TERMINATOR
GETNM2:	HLLZM	WD,FILEXT	;STORE EXTENSION
CPOPJ1:	AOS	(P)		;SKIP RETURN. GOOD NAME
CPOPJ:	POPJ	P,
GETNM3:	CAIN	CH," "		;VALID TERMINATOR FOR EXT?
	 JRST	GETNM2		;YES. STORE IT
	POPJ	P,		;NO. ERROR

GETDEV:	MOVEI	BP7,@0(16)	;GET ADDRESS OF ARGUMENT
	PUSHJ	P,ASC6.5##	;FIVE CHARACTERS
	 JRST	GETDV2		;IGNORE COLON IF PRESENT
GETDV1:	JUMPN	WD,.+2		;GIVE A DEVICE?
	MOVSI	WD,'DSK'	;NO. ASSUME DISK
	MOVEM	WD,FILDEV
	DEVCHR	WD,		;GET CHARACTERISTICS
	TLNN	WD,(DV.TTY)	;IS IT A REAL DISK?
	TLNN	WD,(DV.DSK)	;SINCE NUL: HAS DV.DSK SET TOO
	 POPJ	P,		;NO. ERROR
	JRST	CPOPJ1		;GOOD DEVICE
GETDV2:	CAIE	CH," "		;END WITH SPACE
	CAIN	CH,":"		;OR COLON?
	 JRST	GETDV1		;YES. OK
	POPJ	P,		;NO. ERROR
	SUBTTL	ERROR ROUTINES
NOSUCH:	MOVEI	1,1		;UNDEFINED QUEUE
ERRRET:	MOVEM	1,@4(16)	;STORE ERROR CODE
	GOODBY	(5)		;RETURN

ILLDEV:	MOVEI	1,2		;ILLEGAL DEVICE
	JRST	ERRRET		;RETURN

ILLNAM:	MOVEI	1,3		;ILLEGAL FILE NAME
	JRST	ERRRET		;RETURN

NOFILE:	MOVEI	1,4		;NO SUCH FILE
	JRST	ERRRET		;RETURN

ILLARG:	MOVEI	1,5		;ILLEGAL ARGUMENT IN VECTOR
	JRST	ERRRET		;RETURN
	PRGEND
	TITLE	SUBMIT - ROUTINES TO MAKE INPUT QUEUE ENTRIES
	SUBTTL	USAGE INSTRUCTIONS

	SEARCH	FORPRM,QPRM,MACTEN,UUOSYM

; FORPRM IS UNIVERSAL FILE FROM FOROTS
; QPRM   IS UNIVERSAL FILE FOR QUEUE DEFINITIONS. SEE ...
; MACTEN IS UNIVERSAL FILE WITH USEFUL MACRO DEFINITIONS SEE ...
; UUOSYM IS UNIVERSAL FILE WITH UUO SYMBOLS DEFINITIONS SEE ...

COMMENT	%

USAGE		CALL SUBMIT(VECTOR)

	WHERE		VECTOR IS AN 19 WORD SINGLE PRECISION ARRAY CONTAINING
		VECTOR(1)	NAME OF CTL FILE. MAX. OF FIVE CHARACTERS ASCII.
				EXT IS ALWAYS .CTL
		VECTOR(2)	NAME OF LOG FILE. MAX. OF FIVE CHARACTERS ASCII.
				EXT IS ALWAYS .LOG. DEFAULT IS SAME AS CTL FILE
		VECTOR(3)	DISPOSITION FOR CTL FILE.
				0=PRESERVE
				1=DELETE
		VECTOR(4)	DISPOSITION FOR LOG FILE.
				0=PRESERVE
				1=DELETE
		VECTOR(5)	TIME LIMIT IN SECONDS. DEFAULT IS 60.
		VECTOR(6)	PAGE LIMIT. DEFAULT IS 200
		VECTOR(7)	CARD LIMIT. DEFAULT IS 0
		VECTOR(8)	PAPER TAPE LIMIT. DEFAULT IS 0
		VECTOR(9)	PLOTER LIMIT. DEFAULT IS 0
		VECTOR(10)	CORE LIMIT. DEFAULT IS CORMAX
		VECTOR(11)	RESTARTABLITY.
				0=YES
				1=NO
		VECTOR(12)	UNIQUENESS.
				0=RUN ANY NUMBER OF JOBS UNDER PPN
				1=GUARANTEE UNIQUE UNDER PPN
				2=GUARANTEE UNIQUE TO SFD
		VECTOR(13)	PRIORITY (1-62) STANDARD IS 10
		VECTOR(14)	OUTPUT SWITCH (0,1,2,3,4)
		VECTOR(15)	DEPENDENCY SWITCH (0-177777)
		VECTOR(16)	AFTER SWITCH PART ONE
				TIME OF DAY OR PLUS TIME IN MINUTES
				PLUS TIME IS INDICATED BY A NEGATIVE IN VECTOR(17)
		VECTOR(17)	AFTER SWITCH PART TWO
				DATE IN 15 BIT FORMAT OR ZERO FOR TODAY
				NEGATIVE INDICATES TIME IS PLUS FORMAT
		VECTOR(18)	DEADLINE SWITCH PART ONE. SAME AS AFTER
		VECTOR(19)	DEADLINE SWITCH PART TWO. SAME AS AFTER
%
	SUBTTL	DEFINITIONS AND DATA

; BITS THAT WE MUST DEFINE BECAUSE FORPRM AND UUOSYM DISAGREE
DV.DSK==1B1		;DEVICE IS A DSK
DV.TTY==1B14		;DEVICE IS A TTY

; AC DEFINITIONS
	F=0
	A=1
	B=2
	C=3
	WD=4		;SIXBIT ANSWER FROM ASCSIX
	T1=WD
	BP6=5		;SIXBIT POINTER
	T2=BP6
	BP7=6		;ASCII POINTER
	T3=BP7
	N=7		;NUMBER
	T4=N
	CH=10		;CHARACTER
	T5=CH
	V=11		;POINTER TO ARG VECTOR
	QD=12		;QUE TYPE
	QF=13		;POINTER TO CURRENT FILE BLOCK IN QUE BLOCK
	Q=14		;POINTER TO QUE AREA

; FLAGS IN LH OF F
NEDREN==400000		;FLAG IN DOFIL$ THAT A RENAME IS NEEDED
LOGFIL==200000		;FLAG TO DOFIL$ THAT THIS IS THE LOG FILE
CTLFIL==100000		;FLAG TO DOFIL$ THAT THIS IS THE CTL FILE
	SUBTTL	SUBMIT - INITIALIZATION CODE
	HELLO	(SUBMIT)
	MOVE	A,[BYTE(9).QIHED,Q.FMOD+1(18)2]
	PUSHJ	P,GTINF$##	;GET QUE DEVICE, OTHER INFO
	MOVEI	QD,4		;INP QUEUE
	MOVEI	V,@0(16)	;GET ADDRESS OF ARGUMENT VECTOR
	MOVEI	A,111301	;SET DEFAULT BITS ON CTL,LOG FILE MODES
	MOVEM	A,Q.CMOD(Q)
	TLO	A,(QF.LOG)	;SET LOG BIT TOO
	MOVEM	A,Q.LMOD(Q)
	MOVEI	BP7,(V)		;GET ADDRESS OF CTL NAME
	PUSHJ	P,ASC6.5##	;FIVE CHARACTERS
	 JFCL			;IGNORE ERRORS
	JUMPE	WD,ERRNAM	;ZERO NAME ILLEGAL
	MOVE	A,WD
	MOVSI	B,'CTL'
	MOVEI	QF,Q.CSTR(Q)	;ADDRESS OF CTL FILE BLOCK
	PUSHJ	P,OPDSK$##	;OPEN UP THE DISK
	 JRST	NODSK		;OOPS
	TLO	F,CTLFIL	;CTL FILE
	PUSHJ	P,DOFIL$##	;DO THE FILE THINGS
	 JRST	NTFND		;OOPS
	TLZ	F,CTLFIL	;NOT CTL FILE NOW
	MOVEI	BP7,1(V)	;GET ADDRESS OF LOG FILE NAME
	PUSHJ	P,ASC6.5##	;FIVE CHARACTERS
	 JFCL
	SKIPN	A,WD		;NOW DO THIS FILE
	MOVE	A,Q.LNAM(Q)	;DEFAULT IS CTL NAME
	MOVSI	B,'LOG'		;SET EXTENSION
	PUSHJ	P,OPDSK$##	;OPEN UP THE DISK
	 JRST	NODSK		;OOPS
	TLO	F,LOGFIL	;LOG NOW
	MOVEI	QF,Q.LSTR(Q)	;ADDRESS OF LOG FILE BLOCK
	PUSHJ	P,DOFIL$##	;DO THE FILE THINGS
	 JFCL			;OK IF LOG DOESNT EXIST
	TLZ	F,LOGFIL	;NOT LOG FILE NOW
	MOVE	A,Q.PPN(Q)	;ASSUME NO SFDS
	MOVEM	Q.IDDI(Q)	;IN DEFAULT PATH
	HRLO	A,THSJB$##	;GET OUR DEFAULT PATH
	MOVEM	A,PTHBL$##
	MOVE	A,[XWD ^D8,PTHBL$##]
	PATH.	A,
	 JRST	SUBARG		;JUST PPN
	MOVSI	A,PTHBL$##+2	;MOVE IT
	HRRI	A,Q.IDDI(Q)
	BLT	A,Q.IDDI+5(Q)
	SUBTTL	SUBMIT - PICK UP VECTOR ARGUMENTS
SUBARG:	SKIPL	A,2(V)		;/DISPOSE .CTL
	CAILE	A,1		;LEGAL?
	MOVEI	A,1		;DEFAULT IS DELETE
	MOVEI	B,.QFDDE
	SKIPN	A		;DELETE?
	MOVEI	B,.QFDPR	;PRESERVE
	DPB	B,[POINTR(Q.CMOD(Q),QF.DSP)]

	SKIPG	A,3(V)		;/DISPOSE .LOG
	CAILE	A,1		;LEGAL?
	MOVEI	A,1		;NO
	MOVEI	B,.QFDDE
	SKIPN	A		;DELETE?
	MOVEI	B,.QFDPR	;PRESERVE
	DPB	B,[POINTR(Q.LMOD(Q),QF.DSP)]

	SKIPG	A,4(V)		;GET /TIME
	MOVEI	A,^D60		;DEFAULT IS 60 SECONDS
	TLNE	A,-1		;TOO LONG?
	MOVEI	A,777777	;YES
	HRRM	A,Q.ILIM(Q)

	SKIPG	A,5(V)		;GET /PAGES
	MOVEI	A,^D200		;DEFAULT IS 200 PAGES
	TLNE	A,-1		;TOO LARGE
	MOVEI	A,777777	;YES
	HRLM	A,Q.ILM2(Q)

	SKIPG	A,6(V)		;GET /CARDS
	MOVEI	A,0		;USE DEFAULT LIMITS
	TLNE	A,-1		;TOO LARGE?
	MOVEI	A,777777	;YES
	HRRM	A,Q.ILM2(Q)

	SKIPG	A,7(V)		;GET /FEET (PAPER TAPE)
	MOVEI	A,0		;USE DEFAULT LIMITS
	TLNE	A,-1		;TOO LARGE?
	MOVEI	A,777777	;YES
	HRLM	A,Q.ILM3(Q)

	SKIPG	A,^D8(V)	;GET /TPLOT (PLOT TIME)
	MOVEI	A,0		;USE DEFAULT LIMITS
	TLNE	A,-1		;TOO LARGE?
	MOVEI	A,777777	;YES
	HRRM	A,Q.ILM3(Q)

	SKIPG	A,^D9(V)	;GET /CORE
	 PUSHJ	P,DEFCOR	;GET DEFAULT LIMIT
	CAIGE	A,^D512		;AT LEAST ONE PAGE?
	LSH	A,^D10		;NO. MUST MEAN K
	TLNE	A,-1		;TOO BIG?
	MOVEI	A,777777	;YES
	HRLM	A,Q.ILIM(Q)

	SKIPE	A,^D10(V)	;RESTARTABLE?
	MOVSI	A,(QI.NRS)	;NO. SAY SO
	IORM	A,Q.IDEP(Q)

	SKIPL	A,^D11(V)	;UNIQUENESS
	CAILE	A,.QIUSD	;VALID?
	MOVEI	A,.QIUSD	;NO. USE DEFAULT
	DPB	A,[POINTR(Q.IDEP(Q),QI.UNI)]

	SKIPLE	A,^D12(V)	;/PRIORITY
	CAILE	A,^D62		;LEGAL?
	MOVEI	A,^D10		;NO. USE DEFAULT
	DPB	A,[POINTR(Q.PRI(Q),QP.PRI)]

	SKIPL	A,^D13(V)	;/OUTPUT
	CAILE	A,.QIOAL
	MOVEI	A,.QIOAL	;INVALID. USE DEFAULT
	DPB	A,[POINTR(Q.IDEP(Q),QI.OUT)]

	SKIPG	A,^D14(V)	;DEPENDENCY
	MOVEI	A,0		;DEFAULT IS ZERO
	CAILE	A,177777	;LEGAL?
	MOVEI	A,177777	;USE MAX IF ILLEGAL
	DPB	A,[POINTR(Q.IDEP(Q),QI.DEP)]

	DMOVE	A,^D15(V)	;GET TWO WORDS OF /AFTER
	PUSHJ	P,DDAFT$##	;CONVERT TO INTERNAL FORMAT
	MOVEM	C,Q.AFTR(Q)	;STORE AFTER TIME

	DMOVE	A,^D17(V)	;GET TWO WORDS OF /DEAD
	PUSHJ	P,DDAFT$##	;CONVERT TO INTERNAL FORMAT
	MOVEM	C,Q.DEAD(Q)	;STORE DEADLINE TIME

	PUSHJ	P,$DOQUE##	;GO ACTUALLY DO THE QUEING
	 JRST	ERRXIT		;ERROR RETURN
	GOODBY	(1)		;RETURN
	SUBTTL	SUBROUTINE TO STORE COMPLEX DEFAULTS
DEFCOR:	MOVE	A,[%NSCMX]	;GET CORMAX
	GETTAB	A,
	 MOVEI	A,^D26*^D1024	;DEFAULT IS 26 K
	SETO	B,		;LESS ONE PAGE IF KI OR KL
	AOBJN	B,.+1
	SKIPN	B		;KA?
	 SUBI	A,^D512		;KI OR KL
	POPJ	P,
	SUBTTL	ERROR ROUTINES
NTFND:	OUTSTR	[ASCIZ/
% FILE NOT FOUND IN SUBMIT!
/]
ERRXIT:	RELEAS	0,
	GOODBY	1

NODSK:	OUTSTR	[ASCIZ/
% CANNOT OPEN DISK!
/]
	JRST	ERRXIT

ERRNAM:	OUTSTR	[ASCIZ/% NULL FILE NAME ILLEGAL. JOB NOT SUBMITTED.
/]
	GOODBY	1
	PRGEND
	TITLE	MISC. - DO /DEADLINE , /AFTER , CONVERT ASCII TO SIXBIT
	SUBTTL	DEFINITIONS AND DATA

	SEARCH	FORPRM
	ENTRY	DDAFT$,ASC6.5,ASC6.6,ASC6.C

; FORPRM IS UNIVERSAL FILE FROM FOROTS

; AC DEFINITIONS
	F=0
	A=1
	B=2
	C=3
	WD=4		;SIXBIT ANSWER FROM ASCSIX
	T1=WD
	BP6=5		;SIXBIT POINTER
	T2=BP6
	BP7=6		;ASCII POINTER
	T3=BP7
	N=7		;NUMBER
	T4=N
	CH=10		;CHARACTER
	T5=CH
	V=11		;POINTER TO ARG VECTOR
	QD=12		;QUE TYPE
	QF=13		;POINTER TO CURRENT FILE BLOCK IN QUE BLOCK
	Q=14		;POINTER TO QUE AREA
	SUBTTL	SUBROUTINES TO DO /DEADLINE AND /AFTER

DDAFT$::SETZ	C,		;ASSUME NO TIME
	JUMPL	A,CPOPJ		;NEGATIVE TIME IS ILLEGAL
	DATE	T1,		;GET DATE
	MSTIME	T2,		;AND TIME
	IDIVI	T2,^D1000*^D60	;IN MINUTES
	JUMPL	B,PLSTIM	;NEGATIVE DATE IS FLAG FOR PLUS TIME
	JUMPN	B,DEDAF1	;ANY DATE GIVEN?
	JUMPE	A,CPOPJ		;NO. ANY ARG AT ALL?
	MOVE	B,T1		;NO DATE. USE TODAY
DEDAF1:	PUSHJ	P,CNVDAT	;CONVERT DATE TO INTERNAL FORMAT
	HRLZ	C,T3		;AND STORE IN C
	MOVE	T3,A		;GET TIME
	MUL	T3,[1000000]	;* 2^18
	DIVI	T3,^D24*^D60	;/MINUTES PER DAY
	ADD	C,T3		;ALLOW TO OVERFLOW INTO DAYS
CPOPJ:	POPJ	P,

PLSTIM:	MOVE	B,T1		;TODAYS DATE
	ADD	A,T2		;TIME PLUS CURRENT TIME
	JRST	DEDAF1		;AND PROCESS THAT
RADIX	10
	DATOFS==38395
CNVDAT:	PUSH	P,T1
	PUSH	P,T2
	MOVE	T2,B		;GET DATE
	IDIVI	T2,12*31	;T2=YEARS-1964
	IDIVI	T3,31		;T3=MONTHS-JAN, T4=DAYS-1
	ADD	T4,DAYTAB(T3)	;T4=DAYS-JAN 1
	MOVEI	T5,0		;LEAP YEAR ADDITIVE IF JAN,FEB
	CAIL	T3,2		;CHECK MONTH
	MOVEI	T5,1		;ADDITIVE IF MAR-DEC
	MOVE	T1,T2		;SAVE YEARS FOR REUSE
	ADDI	T2,3		;MAKE LEAP YEARS COME OUT RIGHT
	IDIVI	T2,4		;HANDLE REGULAR LEAP YEARS
	CAIE	T3,3		;SEE IF THIS IS LEAP YEAR
	MOVEI	T5,0		;NO--WIPE OUT ADDITIVE
	ADDI	T4,DATOFS(T2)
	MOVE	T2,T1		;RESTORE YEARS SINCE 1964
	IMULI	T2,365		;DAYS SINCE 1964
	ADD	T4,T2		;T4 = DAYS EXCEPT FOR 100 YR. FUDGE
	HRREI	T2,64-99(T1)	;T2=YEARS SINCE 2000
	JUMPLE	T2,CNVDT1	;ALL DONE IF NOT YET 2000
	IDIVI	T2,100		;GET CENTURIES SINCE 2000
	SUB	T4,T2		;ALLOW FOR LOST LEAP YEARS
	CAIE	T3,99		;SEE IF THIS IS A LOST L.Y.
CNVDT1:	ADD	T4,T5		;ALLOW FOR LEAP YEAR THIS YEAR
	MOVE	T3,T4		;RETURN IN T3
	POP	P,T2		;RESTORE T2
	POP	P,T1		;T1
	POPJ	P,

DAYTAB:	EXP	0,31,59,90,120,151,181,212,243,273,304,334

RADIX	8
	SUBTTL	SUBROUTINES TO READ ASCII ARGS
ASC6.5::SKIPA	N,[5]		;GET FIVE CHARACTERS
ASC6.6::MOVEI	N,6		;GET SIX CHARACTERS
	HRLI	BP7,440700	;SET UP ASCII BYTE POINTER
ASC6.C::SETZ	WD,		;START WITH A BLANK
	MOVE	BP6,[POINT 6,WD]
ASCSIX:	ILDB	CH,BP7		;GET A CHARACTER
	CAIG	CH," "		;BREAK?
	MOVEI	CH," "		;MAKE IT A SPACE
	CAIL	CH,140		;LOWER CASE?
	CAILE	CH,172		;...
	 CAIA			;NO
	SUBI	CH,40		;YES. MAKE UPPER
	CAIL	CH,"0"		;ALPHANUMERIC?
	CAILE	CH,"Z"		;...
	 POPJ	P,		;NO.
	CAILE	CH,"9"		;...
	CAIL	CH,"A"		;...
	 TRCA	CH,40		;YES. CONVERT TO SIXBIT
	  POPJ	P,		;NO. ERROR
	TLNE	BP6,770000	;IF THERE IS ROOM,
	IDPB	CH,BP6		;STORE IT
	SOJG	N,ASCSIX	;LOOP FOR N CHARACTERS
	AOS	(P)		;GIVE GOOD RETURN
	POPJ	P,
	PRGEND
	TITLE	QUEUES - ROUTINES TO MAKE INPUT/OUTPUT QUEUE ENTRIES
	SUBTTL	DEFINITIONS AND DATA
	SEARCH	FORPRM,QPRM,MACTEN,UUOSYM

; FORPRM IS UNIVERSAL FILE FROM FOROTS
; QPRM   IS UNIVERSAL FILE FOR QUEUE DEFINITIONS. SEE ...
; MACTEN IS UNIVERSAL FILE WITH USEFUL MACRO DEFINITIONS SEE ...
; UUOSYM IS UNIVERSAL FILE WITH UUO SYMBOLS DEFINITIONS SEE ...

	ENTRY	DOFIL$,GTINF$,OPDSK$,$DOQUE

; BITS THAT WE MUST DEFINE BECAUSE FORPRM AND UUOSYM DISAGREE
DV.DSK==1B1		;DEVICE IS A DSK
DV.TTY==1B14		;DEVICE IS A TTY

; AC DEFINITIONS
	F=0
	A=1
	B=2
	C=3
	WD=4		;SIXBIT ANSWER FROM ASCSIX
	T1=WD
	BP6=5		;SIXBIT POINTER
	T2=BP6
	BP7=6		;ASCII POINTER
	T3=BP7
	N=7		;NUMBER
	T4=N
	CH=10		;CHARACTER
	T5=CH
	V=11		;POINTER TO ARG VECTOR
	QD=12		;QUE TYPE
	QF=13		;POINTER TO CURRENT FILE BLOCK IN QUE BLOCK
	Q=14		;POINTER TO QUE AREA

; FLAGS IN LH OF F
NEDREN==400000		;FLAG IN DOFIL$ THAT A RENAME IS NEEDED
LOGFIL==200000		;FLAG TO DOFIL$ THAT THIS IS THE LOG FILE
CTLFIL==100000		;FLAG TO DOFIL$ THAT THIS IS THE CTL FILE
QUESIX:	SIXBIT/LPT/
	SIXBIT/CDP/
	SIXBIT/PTP/
	SIXBIT/PLT/
	SIXBIT/INP/

SPLNAM:	SIXBIT/LPTSPL/
	SIXBIT/CDPSPL/
	SIXBIT/PTPSPL/
	SIXBIT/PLTSPL/
	SIXBIT/BATCON/

Q.LGTO==Q.OMOD		;LENGTH OF OUTPUT QUE
Q.LGTI==Q.LMOD		;LENGTH OF INPUT QUE
Q.LGTH==Q.LMOD		;LENGTH OF MAXIMUM QUE RECORD
QHEAD:	BLOCK	1		;UNUSED HEADER FOR QMANGR
QUEBLK:	BLOCK	Q.LGTH		;QUE RECORD

OLIST:	IOWD	Q.LGTH,QUEBLK
	0

QUEDIR:	BLOCK	1		;PPN FOR QUE
QUESTR:	BLOCK	1		;STR FOR QUE

THSJB$::BLOCK	1

$RBBLK::.RBDEV		;INCLUDE FILE STR/UNIT ARG
	BLOCK	.RBDEV	;ROOM FOR ARGUMENTS
$RBPPN=:$RBBLK+.RBPPN
$RBNAM=:$RBBLK+.RBNAM
$RBEXT=:$RBBLK+.RBEXT
$RBPRV=:$RBBLK+.RBPRV
$RBSIZ=:$RBBLK+.RBSIZ
$RBVER=:$RBBLK+.RBVER
$RBSPL=:$RBBLK+.RBSPL
$RBEST=:$RBBLK+.RBEST
$RBALC=:$RBBLK+.RBALC
$RBPOS=:$RBBLK+.RBPOS
$RBFT1=:$RBBLK+.RBFT1
$RBNCA=:$RBBLK+.RBNCA
$RBMTA=:$RBBLK+.RBMTA
$RBDEV=:$RBBLK+.RBDEV

PTHBL$::BLOCK	10
	SUBTTL	COMMON CODE FOR OUTPUT, SUBMIT

$DOQUE::MOVE	A,QUESIX(QD)	;GET GENERIC OUTPUT DEVICE
	MOVEM	A,Q.DEV(Q)	;AND STORE THAT
	CAIN	QD,4		;INP: ?
	MOVSI	A,'LPT'		;USE LPT FOR BATCH
	WHERE	A,		;FIND STATION FOR REQUEST
	 SETZ	A,		;ASSUME CENTRAL
	HRRM	A,Q.DEV(Q)	;STORE IT

	MOVE	A,[XWD 400000,16]	;PHYSICAL OPEN
	MOVE	B,QUESTR	;QUE DEVICE
	SETZ	C,		;NO BUFFERS
	OPEN	0,A		;OPEN IT
	 JRST	NOQUE		;CAN'T
	MOVSI	T3,'QUE'	;EXTENSION FOR UNINAM
	PUSHJ	P,UNINAM	;GET A UNIQUE NAME
	 LOOKUP	0,T2		;CHANNEL ZERO. T2-T5
	MOVSI	T4,177000	;NOW ENTER IT AND PROTECT IT
	ENTER	0,T2		;ENTER IT
	 JRST	NOENT		;CAN'T ENTER IT
	MOVNI	A,Q.LGTO	;NEGATIVE LENGTH OF OUTPUT ENTRY
	CAIN	QD,4		;INP:?
	MOVNI	A,Q.LGTI	;NEGATIVE LENGTH OF INPUT ENTRY
	HRLM	A,OLIST		;FIX IOWD
	OUTPUT	0,OLIST		;WRITE IT
	RELEAS	0,		;RELEAS IT
	MOVE	A,[%NSHJB]	;GET HIGHEST JOB NUMBER
	GETTAB	A,
	 MOVEI	A,^D64		;??
	MOVEI	B,1
CREDN2:	HRLZ	C,B		;LOOK AT JOB NAMES
	HRRI	C,.GTPRG	;IN MONITOR
	GETTAB	C,
	 JRST	CPOPJ1
	CAME	C,SPLNAM(QD)	;WHO WE QUEUED FOR?
	 JRST	CREDN3		;NO. LOOK AT MORE
	MOVE	C,B		;WAKE HIM
	WAKE	C,
	 JFCL			;OH WELL
CREDN3:	CAIGE	B,(A)		;LOOKED AT ALL JOBS?
	AOJA	B,CREDN2	;NO. CONTINUE
CPOPJ1:	AOS	(P)		;SKIP RETURN TO USER
CPOPJ:	POPJ	P,
	SUBTTL	SUBROUTINES TO DO COMMON THINGS FOR INPUT/OUTPUT

; GET COMMON INFO
GTINF$::MOVEI	Q,QHEAD		;SET ADDRESS OF QUEUE BLOCK
	SETZB	F,QHEAD		;START WITH NO FLAGS
	MOVE	T1,[XWD QHEAD,QHEAD+1]
	BLT	T1,Q.LMOD	;CLEAR QUEUE BLOCK
	MOVEM	A,Q.LEN(Q)	;STORE QUE HEADER
	MOVEI	A,12001		;VERSION 1, US, CREATE
	MOVEM	A,Q.OPR(Q)	;STORE IT
	HRROI	A,.GTNM1	;GET USER NAME
	GETTAB	A,
	 SETZ	A,
	MOVEM	A,Q.USER(Q)	;REMEMBER IT
	HRROI	A,.GTNM2	;GET REST OF USER NAME
	GETTAB	A,
	 SETZ	A,
	MOVEM	A,Q.USER+1(Q)	;REMEMBER THAT TOO
	HRROI	A,.GTCNO	;GET CHARGE NUMBER
	GETTAB	A,
	 SETZ	A,
	MOVEM	A,Q.CNO(Q)	;REMEMBER THAT
	MOVE	A,[%LDSTP]	;GET STANDARD PROTECTION
	GETTAB	A,
	 MOVSI	A,055000	;DEFAULT
	LSH	A,-^D27		;REALIGN
	DPB	A,[POINTR(Q.PRI(Q),QP.PRO)]
	PJOB	A,		;GET OUR JOB NUMBER
	MOVEM	A,THSJB$	;REMEMBER IT
	GETPPN	A,		;GET OUR PPN
	 JFCL			;JUST IN CASE
	MOVEM	A,Q.PPN(Q)	;STORE IT IN QUE BLOCK
	MOVSI	A,'QUE'		;FIND QUE DEVICE
	DEVCHR	A,		;SEE WHAT IT IS
	TLNE	A,(DV.DSK)	;REAL DISK?
	TLNE	A,(DV.TTY)	;MAYBE
	 JRST	PUBQUE		;NO
	MOVSI	A,'QUE'		;GET PPN ASSOCIATED
	DEVPPN	A,
	 MOVE	A,Q.PPN(Q)
	CAME	A,Q.PPN(Q)	;IS IT HIMSELF?
	 JRST	PUBQUE		;NO. PUBLIC QUEUE
	MOVSI	B,'QUE'		;GET ASSOCIATED STR
	DEVNAM	B,
	 MOVSI	B,'DSK'
	JRST	STOQUE		;STORE QUE
PUBQUE:	MOVE	A,[%LDQUE]	;GET QUE PPN
	GETTAB	A,
	 MOVE	A,[XWD 3,3]	;DEFAULT
	MOVE	B,[%LDQUS]	;GET QUE STR
	GETTAB	B,
	 MOVSI	B,'DSK'
STOQUE:	MOVEM	A,QUEDIR	;STORE QUE PPN
	MOVEM	B,QUESTR	;STORE QUE STR
	POPJ	P,
DOFIL$::SETZM	$RBPPN		;CLEAR UUO BLOCK
	MOVE	T1,[XWD $RBPPN,$RBNAM]
	BLT	T1,$RBDEV
	MOVEM	A,$RBNAM	;SET NAME TO FIND
	MOVEM	A,Q.FNAM(QF)	;AND IN QUE BLOCK
	MOVEM	A,Q.JOB(Q)	;STORE AS NAME OF JOB
				;(MAKES DEFAULT JOB NAME LOG NAME)
	MOVEM	B,$RBEXT	;EXTENSION TOO
	MOVEM	B,Q.FEXT(QF)	;AND IN QUE BLOCK
	MOVEI	B,0		;GET PPN ASSOCIATED WITH DEVICE
	DEVPPN	B,
	 MOVE	B,Q.PPN(Q)	;ASSUME SELF
	MOVEM	B,$RBPPN	;PPN OF FILE
	MOVEM	B,Q.FDIR(QF)	;AND IN QUE BLOCK
	MOVEI	A,.QFDPR
	CAME	B,Q.PPN(Q)	;IS IT HIS PPN?
	DPB	A,[POINTR(Q.FMOD(QF),QF.DSP)] ;NO. MAKE IS DISP:PRES
HISFIL:	TLZ	F,NEDREN	;ASSUME NO RENAME NEEDED
	MOVEI	A,1		;START AT BEGINNING
	DPB	A,[POINTR(Q.FBIT(QF),QB.SLN)]
; MAY COME BACK HERE IF DIS:REN FAILS
REFILE:	LOOKUP	0,$RBBLK	;IS FILE THERE?
	 JRST	[		;NOT THERE. MAY BE NEW LOG
		TLNN	F,LOGFIL	;LOG FILE?
		 POPJ	P,		;NO. ERROR
		MOVSI	A,(QF.DEF)	;FILE DOESN'T EXIST YET
		IORM	A,Q.LMOD(Q)	;ONLY ON LOG
		JRST	REL0		;RELEAS CHANNEL AND SKIP RETURN
	]
	MOVE	A,$RBDEV	;GET DEVICE FILE IS ON
	MOVEM	A,Q.FSTR(QF)	;STORE IT
	SETZM	PTHBL$		;SET ARG TO PATH
	MOVE	A,[XWD ^D8,PTHBL$]
	PATH.	A,		;GET FULL PATH TO FILE
	 JRST	NOPTH		;JUST PPN
	MOVSI	A,PTHBL$+2	;GET PPN AND SFDS
	HRRI	A,Q.FDIR(QF)	;INTO FILE DESCRIPTION
	BLT	A,Q.FDIR+5(QF)	;JUST SIX WORDS
NOPTH:	MOVSI	A,Q.CSTR(Q)
	HRRI	A,Q.LSTR(Q)
	TLNE	F,CTLFIL	;IS THIS THE CTL FILE
	BLT	A,Q.LNAM(Q)	;DEFAULT WHERE TO FIND LOG
				; INCLUDED STR,PATH,NAME. NOT EXT
	LDB	A,[POINT 9,$RBPRV,8]
	MOVEI	B,177		;MAKE SURE FILE IS PROTECTED IF WE RENAME
	DPB	B,[POINT 9,$RBPRV,8]
	TRNE	A,700		;IS IT PROTECTED?
	 JRST	PROTOK		;YES
	TLO	F,NEDREN	;FLAG TO DO A RENAME
	MOVSI	A,(QB.APF)	;MARK ARTIFICIALLY PROTECTED
	IORM	A,Q.FBIT(QF)
PROTOK:	LDB	A,[POINTR(Q.FMOD(QF),QF.DSP)]
	CAIE	A,.QFDRE	;IS IT DISPOSE RENAME?
	 JRST	NOCROS		;NO. SKIP THIS
	MOVEI	A,20		;FIND A FREE CHANNEL
GETCHN:	SOSG	B,A
	JRST	NOREN		;NO CHANNEL IF ZERO
	DEVCHR	B,		;DOES MONITOR KNOW ABOUT CHANNEL?
	JUMPN	B,GETCHN	;NOT FREE
	DPB	A,[POINT 4,CH1,12] ;MODIFY SOME INSTRUCTIONS
	DPB	A,[POINT 4,CH2,12]
	DPB	A,[POINT 4,CH3,12]
	MOVE	A,[XWD 400000,16]
	MOVE	B,$RBDEV
	SETZ	C,
CH1:	OPEN	A		;OPEN THE STR
	 JRST	NOREN		;CAN'T. THEREFORE NO DIS:REN
	MOVSI	T3,'QUD'	;EXTENSION FOR UNINAM
	PUSHJ	P,UNINAM	;FIND UNIQUE NAME VIA NEXT LOOKUP
CH2:	LOOKUP	T2		;MODIFIED BY CHANNEL NUMBER
CH3:	RELEAS			;MODIFIED BY CHANNEL
	HRR	T3,$RBEXT	;GET BLOCK WAY WE WANT IT
	MOVE	T4,$RBPRV	;INCLUDING DATES, PROTECTIONS, ETC
	RENAME	0,T2		;RENAME ACROSS DIRECTORIES
	 JRST	NOREN		;FAILED
	MOVEM	T2,Q.FRNM(QF)	;STORE RENAMED NAME
REL0:	RELEAS	0,
	JRST	CPOPJ1		;SKIP RETURN
NOREN:	OUTSTR	[ASCIZ/
% Cannot do DISPOSE:RENAME. DISPOSE:DELETE assumed.
/]
	MOVEI	A,.QFDDE	;CHANGE DISP TO DELETE
	DPB	A,[POINTR(Q.FMOD(QF),QF.DSP)]
	JUMPGE	F,REL0		;IF WE DON'T NEED A RENAME, WE'RE DONE
	JRST	REFILE		;YES. GET FILE BACK

NOCROS:	JUMPGE	F,REL0		;IF WE DON'T NEED A RENAME, WE'RE DONE
	RENAME	0,$RBBLK	;YES. DO IT
	 JFCL			;OOPS?
	JRST	REL0		;DONE
; SUBROUTINE TO FIND A UNIQUE QUE NAME
; CALL IS
;		MOVSI	T3,'EXT'
;		PUSHJ	P,UNINAM
;		 LOOKUP	CHAN,T2
;		   RETURNS HERE ALWAYS
;		WITH NAME IN T2, EXT IN T3, QUEDIR IN T5
;		USES A, T1-T5

UNINAM:	MSTIME	T1,		;FIND A UNIQUE NAME
	IDIVI	T1,^D100
UNINM1:	MOVE	T2,QUESIX(QD)	;QUE NAME
	MOVE	A,[POINT 6,T2,11]
	ADD	T1,THSJB$
	MOVE	T4,T1
UNINM2:	IDIVI	T4,^D10
	ADDI	T5,'0'
	IDPB	T5,A
	TLNE	A,(77B5)	;FILLED OUT SIX CHAR NAME YET?
	JRST	UNINM2		;NO
	TRZ	T3,-1		;JUST THE EXTENSION
	SETZ	T4,
	MOVE	T5,QUEDIR
	XCT	@(P)		;DO THE LOOKUP
	 TRNE	T3,-1		;NO SUCH FILE?
	JRST	UNINM1		;IT EXISTS
	MOVE	T5,QUEDIR	;NAME IS UNIQUE. RETURN PPN
	JRST	CPOPJ1

; SUBROUTINE TO OPEN DSK, CHANNEL ZERO
OPDSK$::MOVEI	T1,16		;OPEN DSK IN DUMP MODE
	MOVSI	T2,'DSK'
	SETZ	T3,
	OPEN	0,T1
	 POPJ	P,
	JRST	CPOPJ1
	SUBTTL	ERROR ROUTINES
NOQUE:	MOVEI	1,6		;CAN'T OPEN QUE DEVICE
	CAIE	QD,4		;INP REQUEST?
	POPJ	P,		;RETURN

NOENT:	MOVEI	1,7		;CAN'T ENTER QUEUE FILE
	OUTSTR	[ASCIZ/
% CANNOT ENTER QUEUE REQUEST IN QUE UFD!
% PLEASE NOTIFY OPERATOR!
/]
	POPJ	P,		;RETURN ERROR.
	PRGEND
	TITLE CHAINB
	EXTERN	OVTAB,OVBEG,.JBSA
	SEARCH	FORPRM

CHN==0

	HELLO	(CHAINB, )		;CHAINB ENTRY
	MOVEM	5,SAVAC+5
	MOVEI	5,SAVAC
	BLT	5,SAVAC+4
	MOVEI	T0,CHAINB
	HLRZ	T1,.JBSA
	CAIL	T0,OVBEG		;CHECK IF CHAIN IN OVERLAY
	CAILE	T0,(T1)			;
	JRST	OK1		;
	 JRST	CHNBD1		;OUTPUT DIAGNOSTIC TO TTY
OK1:	MOVE	T0,16		;NOW CHECK RETURN ADDRESS
	TLZN	T0,-1		;
	HRRZ	T0,(P)		;GET ADDRESS FROM PUSH DOWN LIST
	CAIG	T0,(T1)		;
	CAIGE	T0,OVBEG	;
	JRST	OK2		;
	 JRST	CHNBD2		;TRAPPED!
OK2:	MOVEI	T1,@1(16)	;ADDRESS OF FILE NAME STRING
	HRLI	T1,440700	;
	MOVE	T2,[POINT 6, CHNLK]
	MOVEI	T3,5
	SETZM	CHNLK		;
;CONVERT FIRST FIVE CHARACTERS TO SIXBIT
CHN2:	ILDB	T0,T1
	CAIL	T0,140		;LOWER CASE?
	SUBI	T0,40		;NO. MAKE IT
	SUBI	T0,40
	JUMPLE	T0,CHN1A	;SPACE OR LESS?
	IDPB	T0,T2
	SOJG	T3,CHN2
CHN1A:	SKIPE	CHNDEV		;DO WE KNOW WHERE FILE IS?
	 JRST	FNDCHN		;YES. USE IT
	HRROI	T0,40		;JBTLIM TABLE
	GETTAB	T0,
	 SETZ	T0,		;ASSUME NOT SYS
	TLNE	T0,(1B11)	;PROGRAM FROM SYS?
	 JRST	CHNSYS		;YES. GET CHAIN FROM SPECIAL AREA
	HRRZ	T3,.JBOPS##	;GET OBJECT TIME SYSTEM
	MOVE	T0,REGS.1(T3)	;PPN
	CAME	T0,[1,,4]	;DSK:[1,4]?
	CAMN	T0,[1,,5]	;OR  [1,5]?
	 JRST	CHNSYS		;YES. ASSUME FROM SYS SOME WAY
				;DON'T TRY TO HANDLE FUNNY LIB OR PATHS, AND
				;BOMB ON PSEUDO:[1,4]
	MOVEM	T0,CHNPPN	;STORE
	SKIPN	T1,REGS.2(T3)	;SAVE DEVICE
	MOVSI	T1,'DSK'	;ASSUME DISK
	MOVEM	T1,CHNDEV
	MOVEI	T0,17		;MODE. NOT PHY ONLY
	MOVEM	T0,OPNWRD	;REMEMBER
FNDCHN:	MOVE	T0,OPNWRD	;LOOK UP THE CHAIN
	MOVE	T1,CHNDEV
	SETZ	T2,
	OPEN	CHN,T0		;IF NOT THERE, ERROR
	 JRST	NOFILE
	HLLZS	CHNLK+1		;CLEAR POSSIBLE JUNK
	SETZM	CHNLK+2
	MOVE	T3,CHNPPN	;GET CHAIN PPN
	MOVEM	T3,CHNLK+3	;STORE
	LOOKUP	CHN,CHNLK	;LOOKUP FILE IN USER'S AREA
	 JRST	NOFILE		;ERROR IF NOT THERE
GETCHN:	SKIPG	T1,CURCHN	;GET CURRENT CHAIN NUMBER
	 JRST	REDCHN		;IF ANY
	HLRE	T2,OVTAB-1(T1)	;GET LENGTH OF CURRENT OVERLAY
	MOVM	T2,T2
	ADDI	T2,OVBEG-1	;GET HIGHEST ADDRESS IN OVERLAY
	HRRZ	T3,.JBOPS##	;GET FORMAT CHAIN
	MOVEI	T3,FMT.DY(T3)	;...
FUNRA0:	HRRZ	T1,(T3)		;LOCATE FORMAT POINTED TO
	JUMPE	T1,REDCHN	;DONE
	HRRZ	T4,1(T1)	;LOAD FORMAT ADDRESS
	CAIL	T4,OVBEG	;LOWER THAN OVERLAYS?
	CAILE	T4,(T2)		;OR HIGHER THAN TOP OF OVERLAY?
	 JRST	FUNRA2		;YES. GET NEXT FORMAT
	MOVE	T0,(T1)		;LINK FORMATS AROUND OVERLAY
	HRRM	T0,(T3)
	ADDI	T1,1		;SET POINTER FOR DECOR.
	HLLZS	-1(T1)		;AND CLEAR POINTER
	MOVEM	T1,CORADR	;STORE ADDRESS OF CORE TO RETURN
	PUSH	P,16		;SAVE AN AC
	MOVEI	16,ARGBLK	;SET UP ARGUMENT
	PUSHJ	P,DECOR.##	;RETURN FORMATS CORE TO FOROTS
	POP	P,16		;RESTORE AC
	JRST	FUNRA0		;LOOP
FUNRA2:	HRRZ	T3,(T3)		;GET NEXT FORMAT
	JRST	FUNRA0

REDCHN:	MOVE	T1,@(16)
	JUMPLE	T1,BADCHN	;MUST BE POSITIVE
	HLRE	T2,OVTAB-1(T1)	;GET SIZE OF OVERLAY
	JUMPGE	T2,BADCHN	;MUST HAVE SOME SIZE!
	MOVE	T2,OVTAB-1(T1)	;NUMBER OF OVERLAY DESIRED
	USETI	CHN,(T2)
	HRRI	T2,OVBEG-1
	MOVEI	T3,0
	INPUT	CHN,T2
	STATZ	CHN,760000
	 JRST	INERR
	RELEAS	CHN,
	MOVEM	T1,CURCHN	;REMEMBER CURRENT OVERLAY
	MOVSI	5,SAVAC
	BLT	5,5		;RESTORE ALL ACS
	GOODBY	(1)
CHNSYS:	MOVEI	T3,WHRNUM	;NUMBER OF PLACES TO LOOK
	MOVE	T0,[XWD 400000,17];DUMP MODE, PHY ONLY
CHNSY1:	MOVE	T1,WHRTAB-1(T3)	;GET DEVICE TO TRY
	SETZ	T2,
	OPEN	CHN,T0		;OPEN IT
	 SOJA	T3,NXTDEV	;TRY NEXT DEVICE
	HLLZS	CHNLK+1		;SET LOOKUP BLOCK
	SETZM	CHNLK+2
	SETZM	CHNLK+3
	LOOKUP	CHN,CHNLK	;FIND FILE
	 SOJA	T3,NXTDEV	;NOT THERE
	MOVEM	T1,CHNDEV	;REMEMBER DEVICE
	SETZM	CHNPPN		;NO PPN
	MOVEM	T0,OPNWRD	;AND HOW TO OPEN
	JRST	GETCHN		;GET CHAIN. ALREADY LOOKUP UP
NXTDEV:	JUMPLE	T3,NOFILE	;ERROR IF NO MORE DEVICES
	JRST	CHNSY1		;TRY ANOTHER DEVICE
CHNLK:	0
	SIXBIT .CHN.
	0
	0

WHRTAB:	SIXBIT .NEW.		;DEVICE NEW:[1,5]
	SIXBIT .OVL.		;DEVICE OVL: (NEW DEVICE FOR CHAINB,OVERLAY)
WHRNUM==.-WHRTAB

CURCHN:	0		;CURRENT CHAIN IN CORE
CHNDEV:	0		;DEVICE FOR CHAIN FILE
CHNPPN:	0		;PPN FOR CHAIN FILE
OPNWRD:	BLOCK	1	;MODE TO OPEN CHAIN DEVICE
CORADR:	BLOCK	1

	1,,0
ARGBLK:	EXP	CORADR

CHNBD2:	OUTSTR	[ASCIZ   .
CALL TO CHAIN MUST NOT BE IN THE OVERLAY

.]
	EXIT
CHNBD1:	OUTSTR	[ASCIZ   .
CHAIN MUST NOT BE IN THE OVERLAY

.]
	EXIT
NOFILE:	SETZM	CHNDEV		;FORGET WHERE FOUND DEVICE IF LOSE IT
	OUTSTR	[ASCIZ   .
CAN'T FIND CHAIN FILE

.]
	EXIT
INERR:	OUTSTR	[ASCIZ   .
ERROR READING OVERLAY

.]
	EXIT
BADCHN:	OUTSTR	[ASCIZ .
INVALID CHAIN NUMBER

.]
	EXIT

SAVAC:	BLOCK	6		;AC SAVE AREA
	PRGEND
	TITLE	CORAL	CORE ALLOCATION ROUTINES
	SUBTTL	ALLCOR	SUBROUTINE TO ALLOCATE CORE

	SEARCH	FORPRM

COMMENT	%

	WRITTEN BY NORM GRANT. W.M.U. MARCH 17, 1977

	CALL ALLCOR(MAX,IERR,IREL,S(1))

WHERE	MAX:	TOTAL NUMBER OF WORDS OF STORAGE TO BE ALLOCATED.
	IERR:	ERROR CODE.
		0	OK
		-1	INSUFFICIENT ROOM OR ILLEGAL ARGUMENT
		1	WARNING! CAN'T GET MUCH BIGGER
	IREL:	SUBSCRIPT ON SINGLE PRECISION ARRAY S SUCH THAT S(IREL)
		IS FIRST LOCATION IN ALLOCATED CORE.
		OTHER ARRAYS (BEYOND FIRST) ARE AT S(IREL+LENGTH1),
			S(IREL+LENGTH1+LENGTH2),ETC.
	S:	A ONE ELEMENT SINGLE PRECISION ARAY WHICH ALL
		  ALLOCATED CORE IS TO BE ADDRESSED RELATIVE TO.


THE WARNING(IERR=1) WILL ONLY BE GIVEN IF DOING ALLOCATION VIA CORE UUO.

ON PAGING SYSTEMS (VM) ALLOCATION WILL BE DONE BY PAGE. UUOS ABOVE THE
HIGH SEGMENT, SO THAT THE OBJECT TIME SYSTEM MAY BE SHARED.  THIS REQUIRES A
CHANGE TO FOROTS (ACTUALLY FORFUN AND FORPRM) SO THAT THE CBC FUNCTION
TRYING TO REDUCE CORE DOESN'T ZAP OUR NON-CONTIGUOUS PAGES.
THIS PATCH IS SHOWN ONE THE NEXT PAGE FOR FOROTS VERSION 4B.
AFTER INSTALLATION OF THE PATCH, IT WILL BE NECESSARY TO REASSEMBLE
FORPRM.MAC, FORINI.MAC, FOROTS.MAC, AND FORFUN.MAC.  IT WILL ALSO BE
NECESSARY TO FUDGE FORINI,FOROTS, AND FORFUN INTO FORLIB, AND RELOAD
FOROTS.SHR.  THIS PROCEDURE WILL HAVE NO EFFECT ON EXISTING SAVE FILES,
UNLESS THE ADDITIONAL SIZE SHOULD MAKE THEM TOO LARGE TO RUN.



%

IFDEF	PAG.TB,<FTPAGE==-1>		;IF THEY PATCHED FORPRM, ASSUME WANT PAGE. UUOS
IFNDEF	FTPAGE,<FTPAGE==0>		;OTHERWISE, ASSUME DON'T WISH TO DO PAGE. UUOS
COMMENT	%
File 1)	DSKB:FORPRM.ORG[10,7]	created: 0000 20-MAY-1976
File 2)	DSKB:FORPRM.MAC[10,7]	created: 0925 20-APR-1977

1)13	LOW.SZ==ZZ.		;SIZE OF THE STATIC LOW SEGMENT
****
2)13	STATIC(PAG.TB,20)	;WORDS FOR FORFUN TO DO PAGE. UUOS
2)	LOW.SZ==ZZ.		;SIZE OF THE STATIC LOW SEGMENT
**************
File 1)	DSKB:FORFUN.ORG[10,7]	created: 0000 19-MAY-1976
File 2)	DSKB:FORFUN.MAC[10,7]	created: 0932 20-APR-1977

1)16		MOVEI	P1,-1(T2)	;[311] LAST WORD WE NEED
1)		CORE	P1,		;[311]
1)		  JRST	FUNST0		;[311] NO CHANGE IF WE FAILED
1)		CAMLE	T2,.JBREL##	;[311] INCASE WE GAVE IT ALL AWAY
1)		JRST	FUNCB1		;[311] JUST CLEAR PREVIOUS
****
2)16	IFN <KA10-CPU>,<		;IF NOT A KA10
2)		MOVE	T3,[XWD 4,T4]	;CHECK FOR EXISTENCE OF PAGE. UUO
2)		MOVEI	T4,1		;BY GETTING A WORD OF WORKING SET TABLE
2)		PAGE.	T3,		;DO CALL
2)		 JRST	FUNCB3		;DOES NOT EXIST. NOT PAGING SYSTEM
2)		MOVEI	P1,776(T2)	;GET FIRST UNWANTED PAGE
2)		LSH	P1,-^D9
2)		HRRZ	T3,.JBREL##	;GET LAST UNWANTED PAGE
2)		LSH	T3,-^D9
2)		TLO	P1,(1B0)	;SET DELETING PAGES BIT IN P1
2)	RETAGN:	MOVSI	T5,-17		;MAX PAGES TO DO AT ONE TIME
2)		HRRI	T5,PAG.TB(P4)	;WHERE TO STORE WORDS
2)		SETZM	PAG.TB(P4)	;START WITH ZERO PAGES
2)	RETMOR:	CAIGE	T3,(P1)		;FINISHED?
2)		 JRST	RETDON		;YES. DO FINAL PAGE. UUO
2)		MOVEM	P1,1(T5)	;NO. STORE THIS PAGE.  (SHOULD BE AT LEAST ONE)
2)		AOS	PAG.TB(P4)	;AND COUNT IT
2)		ADDI	P1,1		;STEP TO NEXT PAGE
2)		AOBJN	T5,RETMOR	;LOOP FOR MORE PAGES
2)	RETDON:	MOVEI	T5,PAG.TB(P4)	;SET UP UUO ARG
2)		HRLI	T5,1		;DELETE PAGES FUNCTION
2)		PAGE.	T5,		;DO IT
2)		  JFCL			;IGNORE IT. MAY CAUSE PROBS?
2)		CAIL	T3,(P1)		;WAS THAT THE END?
2)		JRST	RETAGN		;NO. DO MORE
2)		JRST	FUNCB4		;YES. DONE
2)	>	;END IFN <KA10-CPU>
2)	FUNCB3:	MOVEI	P1,-1(T2)	;[311] LAST WORD WE NEED
2)		CORE	P1,		;[311]
2)		  JRST	FUNST0		;[311] NO CHANGE IF WE FAILED
2)	FUNCB4:	CAMLE	T2,.JBREL##	;[311] INCASE WE GAVE IT ALL AWAY
2)		JRST	FUNCB1		;[311] JUST CLEAR PREVIOUS
**************

%
	HELLO	(ALLCOR)	;ALLCOR ENTRY
	SKIPL	T1,@0(16)	;MAX NEGATIVE?
	CAILE	T1,400000	;OR GREATER THAN 128 K?
	 JRST	NOCORE		;YES. CAN'T DO ANYTHING
	SETZM	@1(16)		;ASSUME NO ERRORS
IFN <CPU-KA10>!FTPAGE,<
	MOVE	T1,[XWD 4,T2]	;GET WORKING SET BIT TABLE
	MOVEI	T2,1
	PAGE.	T1,		;GET TABLE FROM MONITOR
	 JRST	OLDCOR		;MUST DO OLD WAY. NOT VM SYSTEM
	MOVEI	T1,377777	;DO VIA PAGE. CHECK ARG MORE
	SKIPE	.JBHRL##	;ANY HIGHSEG?
	HRRZ	T1,.JBHRL##	;GET HIGHEST ADR IN HIGHSEG
	ADDI	T1,1		;PLUS ONE IS OUR FIRST ADDRESS
	MOVE	T2,@0(16)	;GET MAX AGAIN
	JUMPE	T2,DELALL	;ASKING FOR ZERO?
	ADDI	T2,-1(T1)	;NO. GET HIGHEST ADDR
	LSH	T1,-^D9		;FIRST PAGE NEEDED
	LSH	T2,-^D9		;HIGHEST PAGE NEEDED
	CAILE	T2,776		;LEAVE ROOM FOR PFH
	 JRST	NOCORE		;NOT ROOM. DO NOTHING
	MOVEM	T1,LOWPAG#	;STORE LOWEST PAGE
	MOVEM	T2,HIPAGE#	;HIGHEST PAGE
	MOVEI	T4,-1(T1)	;MAKE T4 CURRENT HIGHEST PAGE (MAY NOT EXIST)
CHKPAG:	MOVEI	T3,1(T4)	;SEE IF PAGES REALLY EXISTS
	HRLI	T3,6		;.PAGCA FUNCTION
	PAGE.	T3,		;ASK MONITOR
	 JRST	ENDPAG		;ASSUME T4 IS HIGH PAGE
	JUMPL	T3,ENDPAG	;DOES PAGE EXIST?
	CAIGE	T4,775		;YES. HIGH AS WANT TO LOOK?
	AOJA	T4,CHKPAG	;LOOP FOR MORE PAGES
ENDPAG:	MOVEM	T4,CURHGH#	;STORE HIGHEST PAGE
	CAMN	T4,HIPAGE	;IS IT THE HIGHEST DESIRED ALSO?
	 JRST	NOCHNG		;YES. NOTHING TO DO
	CAML	T4,HIPAGE	;NO. MORE THAN HE WANTS?
	 JRST	LESPAG		;YES. REDUCE CORE
	ADDI	T4,1		;WANTS MORE CORE.
	CAMGE	T4,LOWPAG	;START ALLOCATING AT
	MOVE	T4,LOWPAG	;LARGER OF (CURHGH+1), LOWPAG
	MOVEM	T4,FIRSTP#	;REMEMBER WHERE WE STARTED
	SETZM	ONDISK#		;START ALLOCATING PAGES IN CORE
CREPAG:	SETZM	PAGTAB		;ZERO PAGES SO FAR
	HRLZI	T1,-20		;AT MOST 16.P PER CALL
CREPG0:	HRRZM	T4,PAGTAB+1(T1)	;ALWAYS AT LEAST ONE TO ALLOCATE. STORE NUMBER
	AOS	PAGTAB		;AND COUNT IN TABLE ALSO
	ADDI	T4,1		;STEP TO NEXT PAGE
	CAMG	T4,HIPAGE	;WAS THAT THE LAST?
	AOBJN	T1,CREPG0	;NO. DO NEXT IF IT WILL FIT
CREPG1:	MOVSI	T2,(1B1)	;MUST WE ALLOCATE ON DISK?
	SKIPE	ONDISK		;???
	IORM	T2,PAGTAB+1	;YES. SETTING FOR ONE SETS FOR ALL
	MOVE	T2,[XWD 1,PAGTAB] ;ALLOCATE PAGES
	PAGE.	T2,		;FROM MONITOR
	 JRST	CREFAI		;FAILED. ON DISK INSTEAD?
	CAMG	T4,HIPAGE	;GOT THEM. MORE TO DO?
	JRST	CREPAG		;YES. START ANOTHER BLOCK
NOCHNG:	MOVE	T3,LOWPAG	;WHERE ALLOCATED CORE STARTS
	LSH	T3,^D9		;IN WORDS
	JRST	WHRCOR		;TELL WHERE IS AND LEAVE
CREFAI:	SKIPE	ONDISK		;ALREADY TRYING DISK?
	JRST	UNCRPG		;YES. GIVE BACK ANY WE ALLOCATED AND GIVE ERROR
	SETOM	ONDISK		;NO. TRY PUTTING SOME ON DISK
	JRST	CREPG1		;TRY THE ALLOCATION AGAIN. SAME PAGES
UNCRPG:	SETOM	@1(16)		;THIS WILL BE AN ERROR ON RETURN
	HRRZ	T1,PAGTAB+1	;GET FIRST PAGE IN BLOCK THAT FAILED
	CAMG	T1,FIRSTP	;ABOVE FIRST THAT TRIED FOR?
	 JRST	NOCORE		;NO. WE NEVER GRABBED ANY
	SUBI	T1,1		;LAST PAGE TO RETURN
	EXCH	T1,CURHGH	;GOES INTO CURHGH
	MOVEM	T1,HIPAGE	;AND OLD HIGHEST GOES INTO DESIRED HIGHEST
	JRST	DELPAG		;DEALLOCATE IT
LESPAG:	SETZM	@1(16)		;DEALLOCATING PAGES IS ALWAYS OK
DELPAG:	MOVE	T4,HIPAGE	;START DELETING AT HIPAGE DESIRE PLUS ONE
	AOS	T4		;PLUS ONE
	MOVSI	T3,(1B0)	;DELETEING PAGES BIT
DELPG0:	SETZM	PAGTAB		;START WITH ZERO COUNT
	MOVSI	T1,-20		;AT MOST 16.P PER CALL
DELPG1:	MOVEM	T4,PAGTAB+1(T1)	;STORE COMMAND. MUST BE AT LEAST ONE
	AOS	PAGTAB		;COUNT IT TOO
	IORM	T3,PAGTAB+1(T1)	;SET DELETE BIT
	ADDI	T4,1		;STEP TO NEXT PAGE
	CAMG	T4,CURHGH	;WAS THAT LAST ONE?
	AOBJN	T1,DELPG1	;DO NEXT PAGE IF IT WILL FIT
DELPG2:	MOVE	T2,[XWD 1,PAGTAB] ;DELETE THE PAGES
	PAGE.	T2,		;FROM OUR IMAGE
	  JFCL			;IGNORE FAILURE
	CAMG	T4,CURHGH	;WAS THAT END OF IT
	JRST	DELPG0		;NO. START ANOTHER BLOCK
	SKIPE	@1(16)		;DID WE HAVE ERROR
	JRST	NOCORE		;YES. ON ALLOCATION
	JRST	NOCHNG		;NO ERROR. RETURN ADDRESS
DELALL:	HRRZ	T1,.JBREL##	;GET CURRENT HIGHEST IN CONTIGUOUS LOWSEG
	CORE	T1,		;CUT TO JUST THAT
	 JFCL			;IF POSSIBLE
	SETZB	T3,@1(16)	;NO ERRORS
	JRST	WHRCR1		;AND AN OFFSET OF 1 = S(1)
PAGTAB:	BLOCK	21		;ROOM FOR HEADER WORD AND 16P = 8K
>;END IFE <CPU-KA10>!FTPAGE
; HERE TO DO ALLOCATION BY CORE UUO IN HIGH SEGMENT
OLDCOR:	SKIPE	.JBHRL##	;ANY HIGH SEGMENT?
	 JRST	GOTHI		;YES. DON'T MAKE ONE
	HRRZ	T2,.JBREL##	;WHERE DOES LOW SEG END?
	ADDI	T2,1		;PLUS ONE
	CAIGE	T2,400000	;BELOW 400000?
	MOVEI	T2,400000	;YES. START OUR HIGHSEG AT 400000
	MOVS	T2,T2		;...
	CORE	T2,		;MAKE HIGHSEG
	 JRST	NOCORE		;CAN'T?
	MOVEI	T2,10		;RELATIVE LENGTH OF INITIAL HIGHSEG
	HRLM	T2,.JBHRL##
GOTHI:	PUSHJ	P,CLRUWP	;WRITE ENABLE HIGHSEG
	MOVE	T1,@0(16)	;GET MAX
	HRRZ	T2,.JBREL##	;FIGURE OUT HIGH SEG ORIGIN
	TRNN	T2,400000	;OVER 400000?
	MOVEI	T2,377777	;NO. ASSUME ORIGIN IS 400000
	MOVE	T3,[XWD -2,100]	;GET ORIGIN FROM .GTUPM
	GETTAB	T3,		;IN MONITOR
	 HRLI	T3,1(T2)	;ASSUME LOW PLUS ONE
	HLRZ	T3,T3		;GET ORIGIN IN RIGHT
	HLRZ	T2,.JBHRL##	;GET RELATIVE LENGTH
	ADDI	T3,0(T2)	;ADD TO ORIGIN
	ADDI	T1,-1(T3)	;AND ADD THAT TO MAX -1
	TLNE	T1,-1		;EXCEED ADDRESS SPACE?
	 JRST	NOCORE		;YES. NO CAN DO
	MOVS	T2,T1		;MAKE CORE WORD
	ADDI	T1,^D512	;ALSO TRY FOR EXTRA PAGE
	MOVSS	T1		;CORE WORD FOR THAT
	TRNN	T1,-1		;EXCEED ADDRESS SPACE?
	CORE	T1,		;NO. GET CORE
	 AOS	@1(16)		;CAN'T. WARNING
	CORE	T2,		;GET RIGHT AMOUNT
	 JRST	NOCORE		;THAT NEITHER
WHRCOR:	SUBI	T3,@3(16)	;CALCULATE OFFSET INTO S
WHRCR1:	ADDI	T3,1		;SUBSCRIPT CALC IS BASE-1+SUBSCRIPT
	MOVEM	T3,@2(16)	;RETURN IT
	GOODBY	4
NOCORE:	SETOM	@1(16)		;ERROR RETURN
	GOODBY	4
	SUBTTL	CLRUWP	CLEAR HISEG WRITE PROTECTION

COMMENT	%

	WRITTEN BY NORM GRANT. WMU. JANUARY 22, 1974


	USAGE	CALL CLRUWP


	PURPOSE CLEAR USER WRITE PROTECTION ON HIGH SEGMENT

%

	HELLO	(CLRUWP)		;CLRUWP ENTRY
	SETZ	0,
	SETUWP	0,
	 JRST	.+2
	GOODBY
	OUTSTR	[ASCIZ/
Cannot write-enable high segment data area.
/]
	EXIT
	PRGEND
	TITLE CORE MANIPULATION FOR LOW SEGS VIA FOROTS
	SEARCH	FORPRM

COMMENT	%

USAGE		CALL GTCORE(WORDS,BASE,OFFSET,ERROR,RESERVE)
	WHERE	WORDS   - IS NUMBER OF WORDS OF CORE TO GET
		BASE    - IS ARRAY RELATIVE TO WHICH ADDRESS IS TO BE RETURNED
		OFFSET  - IS ADDRESS OF CORE RELATIVE TO BASE
		ERROR   - ERROR CODE
			   0 = OK
			  -1 = INSUFFICIENT CORE
			   1 = CANNOT OBTAIN REQUESTED RESERVE CORE
		RESERVE - NUMBER OF WORDS TO RESERVE FOR LATER

	CALL LSCORE(BASE,OFFSET)
	WHERE BASE AND OFFSET HAVE SAME MEANING AS ABOVE.
 THIS ROUTINE MUST BE CALLED TO RETURN CORE BEFORE IT CAN BE REUSED.

NOTE:	GTCORE DOES NOT FUNCTION PROPERLY WITH LINK-10 OVERLAYS
	IN MOST CASES. SEE FORLIB.MAN FOR MORE COMMENTS

%

	XWD -1,0
M1:	Z 2,AMT#		;TO ALLOCATE CORE

	XWD -1,0
M2:	Z 2,[-1]		;TO ALLOCATE ALL OF CORE

	XWD -1,0
M3:	Z 2,ADR#		;TO RETURN CORE
	HELLO	(GTCORE)
	SETOM	GETTNG#		;GETTING CORE. DO NOT DELETE FORMATS ON RETURN
	MOVEM	16,SAVE16#
	PUSH	P,P4		;SAVE P4
	MOVE	P4,.JBOPS##	;GET BASE OF OTS
	SETZM	@2(16)		;CLEAR OFFSET
	SETZM	@3(16)		;CLEAR ERROR
	SKIPLE	T1,@0(16)	;MUST BE POSITIVE
	TLNE	T1,-1		;MORE THAN 18 BITS?
	JRST	NOCORE		;YES. NO WAY
	MOVEM	T1,SAVESZ#	;SAVE THE SIZE FOR LATER
	SETZM	RSVSW#		;FLAG RESERVE ARG ABSENT
	SETZM	RSVADR#		;FLAG NO RESERVE CORE YET
IFN F40LIB,<
	TLNN	16,-1		;F10 CALL
	 JRST	NOTF40		;YES
	HLRZ	0,4(16)		;F40 CALL
	TRZ	0,740		;CLEAR AC FIELD
	CAIE	0,(JUMP)	;IS IT AN ARG?
	 JRST	RSVNOT		;NO
	JRST	RSVYES		;YES
NOTF40:>
	HLRE	0,-1(16)
	MOVN	0,0		;CHANGE SIGN
	CAIGE	0,5		;AT LEAST FIVE ARGS?
	 JRST	RSVNOT		;NO.
RSVYES:	MOVE	0,@4(16)	;GET AMOUNT OF RESERVE
	JUMPLE	0,RSVNOT	;OK IF NONE
	SETOM	RSVSW		;ASKED FOR RESERVE
	TLNN	0,-1		;MORE THAN 18 BITS?
	PUSHJ	P,GETCOR	;GET THE RESERVE CORE
	 JRST	NORESV		;NO RESERVE
	MOVEM	1,RSVADR	;SAVE RESERVE ADR
RSVNOT:	PUSHJ	P,DEFRAG	;FIND LARGEST POSSIBLE PIECE
	MOVE	1,ADR		;WHERE IS IT?
	HLRZ	0,-1(1)		;HOW BIG?
	CAMG	0,SAVESZ	;BIG ENOUGH FOR REQUEST AND OVERHEAD WORD?
	 JRST	GETOWN		;NO
	MOVE	0,SAVESZ	;YES. GET SIZE BACK
	PUSHJ	P,GETCOR	;GET CORE FROM FOROTS
	 JRST	CORERR		;CAN'T GET IT
SETADR:	MOVE	16,SAVE16	;GET ARG LIST BACK
	SUBI	1,@1(16)	;SUBTRACT BASE FROM ADDRESS
	ADDI	1,1		;FORTRAN PASSES BASE-1+OFFSET
	MOVEM	1,@2(16)	;STORE AS OFFSET
RETRSV:	SKIPN	RSVSW		;RESERVE ARG GIVEN?
	 JRST	GTRET		;NO. RETURN
	MOVE	0,RSVADR	;YES. GET ADDRESS ALLOCATED
	JUMPLE	0,GTRET		;NONE. RETURN
	PUSHJ	P,GIVCOR	;GIVE CORE BACK TO FOROTS
GTRET:	MOVE	16,SAVE16	;GET ARG LIST BACK
	POP	P,P4		;RESTORE P4
	GOODBY	400004		;RETURN

CORERR:	SKIPLE	T1,RSVADR	;DID USER WANT A RESERVE?
	 JRST	CORER1		;NO. (OR WE COUDN'T GET IT)
	MOVE	16,SAVE16	;GET ARG LIST BACK
	SETO	0,		;ERROR IS -1
	EXCH	0,@3(16)	;REPLACE ANY OLD ERROR AND REMEMBER
	JUMPE	0,RETRSV	;IF NO PREVIOUS ERROR, RETURN ANY RESERVE
	JRST	GTRET		;ELSE JUST RETURN
CORER1:	MOVEM	T1,ADR		;STORE ADDRESS
	PUSHJ	P,RETADR	;RETURN THE CORE
	SETZM	RSVADR		;DON'T HAVE IT ANYMORE

NORESV:	MOVE	16,SAVE16	;GET ARGS BACK
	MOVEI	0,1		;NO RESERVE ERROR
	MOVEM	0,@3(16)
	JRST	RSVNOT		;NOW FIND REAL CORE

NOCORE:	SETOM	@3(16)		;COMPLETE FAILURE
	JRST	GTRET		;RETURN
	HELLO	(LSCORE)
	SETZM	GETTNG#		;RETURNING CORE FROM PROGRAM. RETURN FORMATS
				;AND ETC. SO CAN TRY TO SHRINK
	PUSH	P,P4		;SAVE P4
	MOVE	P4,.JBOPS##	;GET OTS WORD
	MOVEI	1,@(16)		;GET ARG WORD
	ADD	1,@1(16)	;PLUS OFFSET
	SUBI	1,1		;MINUS THE FUDGE FACTOR FROM FORTRAN
	HLRZ	2,.JBSA##	;CHECK AGAINST LOWER CORE
	CAIGE	1,1(2)		;INCLUDING LINK WORD
	 JRST	ILCORE		;TO LOW
	HLRZ	2,-1(1)		;AND CHECK UPPER END
	ADDI	2,-2(1)		;GET EXACT UPPER ADDRESS
	TLNN	2,-1		;NEGATIVE?
	CAMLE	2,.JBREL##	;OR GREATER THAN .JBREL?
	 JRST	ILCORE		;YES. ILLEGAL
	MOVE	0,1		;CALL GIVCOR
	MOVEM	16,SAVE16#
	PUSHJ	P,GIVCOR	;GIVE IT BACK
	MOVE	16,SAVE16
LSRET:	POP	P,P4		;RESTORE P4
	GOODBY	(2)

ILCORE:	OUTSTR	[ASCIZ/
Attempting to return core at illegal address in LSCORE
/]
	HALT	LSRET
GETCOR:	MOVEM	0,AMT		;ALLOCATE CORE
	PUSHJ	P,DEFRAG	;DEFRAGMENT CORE FIRST AND ALWAYS
	MOVEI	16,M1
	PUSHJ	P,ALCOR.##	;GET IT FROM FOROTS
	 JUMPL	0,GIVCOR	;IF ERROR, TRY TO SHRINK CORE
	MOVE	1,0		;RETURN ADDRESS IN AC 1
	MOVE	0,AMT		;RETURN AMOUNT IN ZERO
CPOPJ1:	AOS	(P)		;SKIP RETURN
CPOPJ:	POPJ	P,		;RETURN

GETBIG:	MOVEI	16,M2		;GET LARGEST POSSIBLE CHUNK
	PUSHJ	P,ALCOR.##	;FROM FOROTS
	MOVEM	0,ADR		;STORE ADRRESS
	POPJ	P,		;RETURN

DEFRAG:	PUSHJ	P,GETBIG	;GET LARGEST POSSIBLE PIECE
	JRST	RETADR		;AND RETURN IT TO FOROTS (DEFRAGMENTS CORE)

FNDHGH:	SETZ	T1,		;ASSUME ZERO HIGHEST
	MOVEI	T2,FRE.DY(P4)	;GET ADDRESS OF FIRST BLOCK
	MOVE	T3,T2		;SAVE AS PREVIOUS
FNDHG1:	MOVE	T4,T3		;SAVE PREVIOUS
	HRRZ	T3,(T3)		;GET ADDRESS OF BLOCK
	JUMPE	T3,CPOPJ	;RETURN IF NONE
	CAILE	T1,(T3)		;IS NEW ADDRESS HIGHER
	 JRST	FNDHG1		;NO. LOOP
	MOVEI	T1,(T3)		;YES. REMEMBER
	MOVE	T2,T4		;AND REMEMBER PREVIOUS
	JRST	FNDHG1		;LOOP
GETOWN:	SETZM	GOTHGH#		;ASSUME WILL NOT FIND BLOCK AT TOP
	PUSHJ	P,FNDHGH	;TRY TO FIND BLOCK AT TOP OF CORE
	 JUMPE	T1,GETOW1	;NO CORE BLOCKS AT ALL
	HLRZ	T3,(T1)		;GET SIZE OF HIGHEST BLOCK
	ADDI	T3,-1(T1)	;GET HIGHEST ADDRESS IN BLOCK
	CAME	T3,.JBREL##	;TOP OF CORE?
	 JRST	GETOW1		;NO.
	SETOM	GOTHGH		;YES. REMEMBER
	HRRZ	T3,(T1)		;GET ADDRESS OF NEXT
	HRRM	T3,(T2)		;LINK FROM PREVIOUS
	HLLZS	(T1)		;CLEAR FORWARD LINK
	JRST	GETOW2		;STORE ADDRESS OF BLOCK AS LOWEST FREE
GETOW1:	MOVE	T1,.JBFF##	;GET ADDRESS OF FIRST FREE WORD
GETOW2:	MOVEM	T1,SAVLOW#	;STORE THAT
	ADD	T1,SAVESZ	;PLUS SIZE IS OUR HIGHEST
	CORE	T1,		;TRY TO GRAB CORE
	 JRST	OWNERR		;DIDN'T GET IT. FAIL
	HRRZ	T3,.JBREL##	;GOT IT
	MOVE	T1,.JBFF##	;GET OLD FIRST FREE
	SUBI	T3,-1(T1)	;GET SIZE OF CHUNK
	ADDB	T3,.JBFF##	;AND UPDATE .JBFF
	SUB	T3,SAVESZ	;GET ADR OF LOWEST WORD FOR USER
	MOVEM	T3,SAVUSR#	;SAVE IT
	MOVE	T2,SAVESZ	;GET SIZE TO STORE
	ADDI	T2,1		;INCLUDING OVERHEAD
	HRLZM	T2,-1(T3)	;STORE IN BLOCK
	SUB	T3,SAVLOW	;FIND SIZE OF REMAINDER
	SOJLE	T3,GETOWX	;MUST BE POSITIVE TO RETURN
	HRLZM	T3,@SAVLOW	;STORE SIZE
	AOS	T1,SAVLOW	;GET ADDRESS
	MOVEM	T1,ADR		;AND STORE IT
	PUSHJ	P,RETADR	;RETURN TO FOROTS
GETOWX:	MOVE	1,SAVUSR	;GET THE ADDRESS OF THE BLOCK BACK
	JRST	SETADR		;SET UP THE OFFSET AND RETURN TO USER

OWNERR:	AOS	T1,SAVLOW	;GET LOWEST PLUS ONE
	MOVEM	T1,ADR		;STORE IT
	SKIPE	GOTHGH		;GOT IT FROM FOROTS?
	 PUSHJ	P,RETADR	;YES. RETURN IT TO FOROTS
	JRST	CORERR		;GIVE CORE ERROR
GIVCOR::MOVEM	0,ADR		;DEALLOCATE CORE
	PUSHJ	P,RETADR	;RETURN THE CORE
	SKIPE	GETTNG		;IF JUST GETTING CORE, SKIP FORMATS
	JRST	SHRINK		;AND COMPRESS CORE
GVCOR1:	PUSHJ	P,DEFRAG	;DEFRAGMENT THE CORE
	SETZM	FRAGED#		;AND SAY ITS NOT FRAGMENTED
	PUSHJ	P,FNDHGH	;FIND HIGHEST BLOCK OF CORE
	 JUMPE	T1,CPOPJ	;IF NONE (IMPOSSIBLE) RETURN
	HLRZ	T3,(T1)		;GET SIZE OF HIGHEST BLOCK
	ADDI	T3,-1(T1)	;GET HIGHEST ADDRESS OF BLOCK
	CAMN	T3,.JBREL##	;TOP OF CORE?
	 JRST	SHRINK		;YES. SHRINK THE CORE IF WORTH IT
	SKIPE	GETTNG		;WORTH LOOKING AT FORMATS?
	 POPJ	P,		;NO. RETURN
	MOVEM	T1,CURHGH#	;SAVE ADDRESS OF HIGHEST BLOCK
	HLRZ	T1,FMT.DY(P4)	;GET ADDRESS OF FORMAT ENCODING BLOCK
	CAMG	T1,CURHGH	;ABOVE HIGHEST?
	 JRST	GVCOR2		;NO. CONTINUE
	HRRZS	FMT.DY(P4)	;YES. DELETE IT
	ADDI	T1,1		;SET ADDRESS THE WAY FOROTS EXPECTS
	MOVEM	T1,ADR		;AND RETURN THE CORE
	PUSHJ	P,RETADR	;TO FOROTS
	SETOM	FRAGED		;THE CORE IS NOW FRAGMENTED
GVCOR2:	MOVEI	T1,FMT.DY(P4)	;NOW LOOK AT THE ENCODED FORMATS
GVCOR3:	HRRZ	T1,(T1)		;GET NEXT ONE
	JUMPE	T1,GVCOR4	;NO MORE
	CAMG	T1,CURHGH	;ABOVE HIGHEST BLOCK
	 JRST	GVCOR3		;NO. LOOK AT NEXT
	HRRZ	T1,FMT.DY(P4)	;GET THE ADDRESS OF FIRST ENCODED FORMAT
	ADDI	T1,1		;PLUS ONE FOR FOROTS
	MOVEM	T1,ADR		;STORE ADDRESS
	HLLZS	FMT.DY(P4)	;DELETE THE ENCODED FORMAT LIST
	PUSHJ	P,RETADR	;RETURN THE CORE TO FOROTS
	JRST	GVCOR1		;CORE IS NOW FRAGMENTED, SO TRY AGAIN
GVCOR4:	SKIPE	FRAGED		;IS CORE FRAGMENTED?
	JRST	GVCOR1		;YES
	POPJ	P,		;NO
SHRINK:	HRRZ	T3,(T1)		;GET ADDRESS OF NEXT BLOCK
	HRRM	T3,(T2)		;STORE IN PREVIOUS AS LINK
	HLLZS	(T1)		;ZERO POINTER
	ADDI	T1,1		;CHANGE POINTER TO WAY FOROTS EXPECTS
	MOVEM	T1,ADR		;STORE FOR LATER
	TROE	T1,777		;ROUND ADDRESS UP TO PAGE
	ADDI	T1,1000		;EXTRA PAGE
	CAML	T1,.JBREL##	;WORTH DELETING?
	 JRST	RETADR		;NO. RETURN THE BLOCK
	CORE	T1,		;RETURN SOME CORE
	 HALT	.		;OOPS?
	HRRZ	T3,.JBREL##	;GET NEW HIGHEST
	ADDI	T3,1		;NEW .JBFF
	MOVEM	T3,.JBFF##
	MOVE	T1,ADR		;GET THE BLOCK ADDRESS BACK
	SUBI	T3,-1(T1)	;COMPUTE SIZE
	HRLM	T3,-1(T1)	;AND STORE IT
RETADR:	MOVEI	16,M3		;RETURN IT
	PUSHJ	P,DECOR.##	;VIA FOROTS
	POPJ	P,
	END