Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-10 - 43,50521/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
	HRRZS	IOUT		;IF NEGATIVE, MAKE JUST RIGHT HALFWORD
	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:	100,,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	CHKCHN
;WRITTEN BY RUSSELL R. BARR III - 7-DEC-77 - WMU.
;(WITH MUCH GRATEFUL THEFT FROM FORWMU.MAC, WRITTEN BY 
;NORMAN D. GRANT - WMU)
;
;PURPOSE:
;	FIND AN UNUSED FORTRAN UNIT NUMBER OR INQUIRE WHETHER A UNIT
;	NUMBER IS IN USE, AND RETURN THAT NUMBER AND THE NUMBER OF THE
;	ASSOCIATED SOFTWARE CHANNEL.
;
;USE:
;	CALL CHKCHN(NMUNIT,NUMFND,NMSOFT)
;			OR
;	CALL CHKCHN(NMUNIT,NUMFND)
;	WHERE:
;		NMUNIT	- FORTRAN UNIT NUMBER DESIRED
;			1-63	- UNIT NUMBER DESIRED
;			0(ZERO)	- TO REQUEST ANY FREE UNIT NUMBER
;
;		NUMFND	- UNIT NUMBER FOUND
;			1-63	- FORTRAN UNIT NUMBER AVAILABLE
;			0(ZERO)	- IF NONE AVAILABLE
;				  (OR REQUESTED UNIT NOT AVAILABLE)
;			-1	- ARGUMENT RANGE ERROR
;
;		NMSOFT	- SOFTWARE CHANNEL RETURNED(OPTIONAL ARGUMENT)
;			-1	- IF NMUNIT = 0
;			-1	- IF NMUNIT IS AVAILABLE
;			0-17	- IF NMUNIT IS NOT AVAILABLE
;
	SEARCH	FORPRM

	HELLO	(CHKCHN)

	PUSH	P,2			;SAV ACS
	PUSH	P,3
	SETZM	@1(16)			;ZERO THE RETURNED UNIT #
	SETZM	CHNFRE			;ZERO FREE CHANNEL NUMBER
	SETOM	CHNSFT#			;# OF SOFTWARE CHANNEL
	MOVE	2,@0(16)		;GET ARGUMENT
	SETZM	CHNFRE#			;# OF FREE CHANNEL
	MOVEI	0,^D15			;# OF FREE CHANNELLS POSSIBLE
	MOVEM	0,NUMFRE#
	MOVNI	0,5			;-5 IS LOOP LIMIT
	JUMPL	2,CKBADZ		;NO NEGATIVES ALLOWED
	CAILE	2,FLU.MX		;LEGAL UNIT #?
	JRST	CKBADZ			;NO
CKLUP:	MOVE	2,0			;GET COPY OF INDEX
	JUMPE	2,CHKINC		;UNIT 0 IS NOT ALLOWED
CKLOOP:	MOVEI	2,6(2)			;GET FOROTS INTERNAL FLU NUMBER
	IDIVI	2,6			;SIX ENTRIES PER WORD IN OTS TABLE
	IMULI	3,6			;# OF BITS LEFT
	ROT	3,-6			;POSITION FOR BYTE POINTER
	HRRZ	1,.JBOPS##		;BASE FOR OTS DATA
	IOR	3,[POINT 6,FLU.TB(1),35]	;SET FULL SIZE
	ADDI	3,(2)			;POINT TO WORD ENTRY(SOFTWARE CHANNEL)
	LDB	2,3			;LOAD CHANNEL ENTRY(SOFTWARE CHANNEL)
	MOVE	3,2			;GET SOFTWARE CHANNEL
	ADDI	2,CHN.TB(1)		;SET OFSET FOR CHANNEL CONTROL WORD
	SKIPN	(2)			;UNIT # FREE IF ZERO(PHYNAM IF NOT)
	JRST	CKAVAL			;THIS UNIT # AVAILABLE
	SOS	NUMFRE			;DECRIMENT NUMBER OF REMAINING FREE CHANELS
	SKIPN	@(16)			;REQUESTS SPECIFIC UNIT #?
	JRST	CHKINC			;NO, TRY NEXT
	CAME	0,@(16)			;YES,IS THIS THE ONE?
	JRST	CHKINC			;NO, TRY NEXT
	MOVEM	3,CHNSFT		;RETAIN THE ASSOC. SOFTWARE CHANNEL
	JRST	CHKINC			;MORE AVAILABLE, KEEP LOOKING
CKAVAL:	SKIPG	NUMFRE			;ANY CHANNELS LEFT?
	JRST	CHKINC			;NOPE?
	JUMPLE	0,CHKINC		;CAN'T RETURN NEG OR ZERO
	SKIPN	@(16)			;REQUESTS SPECIFIC UNIT #?
	JRST	CHKANY			;NO, RETURN ANY UNIT #
	CAME	0,@(16)			;YES, IS THIS THE ONE?
	JRST	CHKINC			;THIS IS NOT THE ONE, TRY NEXT
CHKANY:	SKIPN	CHNFRE			;FOUND A FREE CHANNEL YET?
	MOVEM	0,CHNFRE		;NO,SAVE LOWEST FREE FOUND
CHKINC:	ADDI	0,1			;INCREMENT INDEX
	CAIG	0,FLU.MX		;END OF LIST?
	JRST	CKLUP			;NO, GO BACK FOR ANOTHER
	MOVE	0,CHNFRE		;GET NUM OF FREE CHANNEL, IF ANY
	JUMPE	0,CKBAK			;JUMP IF NO FREE CHANNEL FOUND

CKGOT:	SKIPLE	NUMFRE			;ANY LEFT?
	JRST	CKGOTA			;YES
	SETZM	CHNFRE			;CAN'T HAVE FREE UNIT #'S IF NO SOFT CHNLS
	JRST	CKBAK			;NOPE
CKGOTA:	SKIPE	@(16)			;SINGLE UNIT DESIRED?
	MOVE	0,@(16)			;YES, GET UNIT # DESIRED
	MOVEM	0,@1(16)		;RETURN INDEX TO ARG2
	JRST	CKBAK
CKBADZ:	SETOM	@1(16)
	JRST	CKBAK
CKBAK:
IFN	F40LIB,<
	TLNN	16,-1			;F10 CALL?
	JRST	CHKF10			;YES
	HLRZ	2,2(16)			;GET LEFT HALF FROM ARG BLOCK(3RD WORD)
	ANDI	2,777037		;CLEAR AC BITS
	CAIN	2,(JUMP)		;ARG?
	JRST	CKARG3			;YES
	JRST	CKARG2			;NO, 2 ARGS ONLY
CHKF10:
>
	HLRE	2,-1(16)		;GET # OF ARGS
	MOVMS	2			;MAKE IT POSITIVE
	CAIGE	2,3			;3 ARGS?
	JRST	CKARG2			;LESS, WE'RE DONE
CKARG3:	SETOB	3,@2(16)
	SKIPN	@0(16)			;SPECIFIC UNIT # REQUESTED?
	JRST	CKNSFT			;NO, DON'T RETURN CHANNEL #
	SKIPN	CHNFRE			;FOUND FREE CHANNEL?
	MOVE	3,CHNSFT		;NO, GET ASSCOC. SOFTWARE CHANNEL
CKNSFT:	MOVEM	3,@2(16)		;NO, STORE SOFTWARE CHANNEL
CKARG2:	POP	P,3			;RESTORE ACS
	POP	P,2
	GOODBY	(3)

	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/
Cannot initialize tape!
/]
	EXIT
ILDEV:	OUTSTR	[ASCIZ/
Not a DECtape!
/]
	EXIT
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 0,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 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 (ALSO FORFUN AND FORPRM) SO THAT THE CBC FUNCTION
TRYING TO REDUCE CORE DOESN'T ZAP OUR NON-CONTIGUOUS PAGES, AND NEITHER DOES QMANGR.
NOTE THAT GALAXY QMANGR STILL WILL ZAP OUR NON-CONTIGUUOUS PAGES SINCE IT
DOES A CORE UUO EVEN WHEN TOLD NOT TO.
THIS PATCH IS SHOWN ON THE NEXT TWO PAGES 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
**************
File 1)	DSKC:FOROTS.CUR[10,6]	created: 0000 21-APR-1977
File 2)	DSKC:FOROTS.MAC[10,6]	created: 1038 12-OCT-1977

1)55		PUSH	P,.JBHRL##	;[346] SAVE HIGH SEGMENT LENGTH
****
2)55	; CLOS.Q+	S.M. #485.25	NDG/ 10-12-77
2)		TLO	T1,40000	;TELL QMANGR NOT TO DO ANY CORE SHRINKING
2)		PUSH	P,.JBHRL##	;[346] SAVE HIGH SEGMENT LENGTH
**************
1)55		PJRST	UPDCHN		;[240] UPDATE CHANNEL TABLE
1)	QUE.TB:				;TABLE OF QUEUE CODES
****
2)55		PUSHJ	P,UPDCHN	;[240] UPDATE CHANNEL TABLE
2)		HRRZ	T2,.JBFF	;GET WHERE WE THINK CORE ENDS
2)		CAML	T2,.JBREL	;QMANGR CHANGE?
2)		 POPJ	P,		;NO. OK
2)	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	QUECB3		;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)		POPJ	P,		;YES. DONE
2)	>	;END IFN <KA10-CPU>
2)	QUECB3:	MOVEI	P1,-1(T2)	;WHERE TO SHRINK BY CORE UUO
2)		CORE	P1,		;DO IT
2)		 JFCL			;CAN'T FAIL
2)		POPJ	P,		;RETURN
2)	QUE.TB:				;TABLE OF QUEUE CODES
**************

%
	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