/FIP VERSION 8.24 (01-JANUARY-75)
/
/
/
/
/COPYRIGHT (C) 1975
/DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
/
/
/THIS SOFTWARE IS FURNISHED UNDER A LICENSE FOR USE ONLY
/ON A SINGLE COMPUTER SYSTEM AND MAY BE COPIED ONLY WITH
/THE  INCLUSION  OF  THE  ABOVE  COPYRIGHT NOTICE.  THIS
/SOFTWARE, OR ANY OTHER COPIES THEREOF,  MAY NOT BE PRO-
/VIDED OR OTHERWISE  MADE AVAILABLE TO ANY  OTHER PERSON
/EXCEPT FOR USE ON SUCH SYSTEM  AND TO ONE WHO AGREES TO
/THESE  LICENSE  TERMS.  TITLE TO AND  OWNERSHIP  OF THE
/SOFTWARE SHALL REMAIN IN DEC.
/
/THE  INFORMATION IN THIS  DOCUMENT IS SUBJECT TO CHANGE
/WITHOUT NOTICE AND SHOULD  NOT BE  CONSTRUED  AS A COM-
/MITMENT BY DIGITAL EQUIPMENT CORPORATION.
/
/DEC   ASSUMES   NO   RESPONSIBILITY   FOR  THE  USE  OR
/RELIABILITY  OF  ITS SOFTWARE ON EQUIPMENT WHICH IS NOT
/SUPPLIED BY DEC.

/FIP HANDLES ALL NON-RESIDENT FILE IOT'S

/RUNS IN AN UPPER FIELD IN PLACE OF USER IT IS SERVING

/RUNS IN EXEC MODE

FIELD 1				/FIP LOADS ONTO DISK TRACK 1

*0
	JMP I	.+1
	FIP0
LNS01,	LNS0
RETBK1,	RETBKS
LNK01,	LNK0
ZDS1,	DS1			/

*10
INDEX,	0			/ONLY REGISTER AVAILABLE IN FIP FOR INDEXING
P5400,	5400
P2000,	2000
P0077,	0077
P0007,	7
FIDEXP,				/TO REPLACE FIDEXP, FIPDEX WHERE FIPDEX=4
P0004,	4
FIPFLD,				/FIELD WE ARE RUNNING IN
C0020,	20
C002,
FILPRP,	FILPRO


FIPDAT=	155			/DATA REFERENCED BY FIP
*FIPDAT

FIPJOB,	.
C0400,	400
SEGSIZ=	C0400			/# WORDS PER SEGMENT
FIBASE,	SWDEX+JOBMAX		/BASE ADDRESS OF ALLOCATABLE DISC STORAGE
JOB,	.			/# OF CURRENT JOB
JOBDAT,	.			/ADDRESS OF CURRENT JOB DATA LIST. MUST RESIDE IN DATA FIELD.
P7000,
CORTBA,	CORTBL-1		/CORE ALLOCATION TABLE
DEVTBA,	DEVTBL			/DEVICE TABLE
DEVEND,	DEVTBE			/START OF ASSIGNABLE DEVICE TABLE
DSBUSY,	.			/DISC BUSY COUNT

/THE DATE IS KEPT AS A 12 BIT NUMBER IN THE FORMAT
/DATE=((YEAR-1974)*12+(MONTH-1))*31+DAY-1

DATE,	.

BLTA,	BLT0			/BLOCK TRANSFER
BLT=	JMS I BLTA
CORSRA,	CORSRC
CORE=	JMS I CORSRA
GETBA,	GETB
GETBLK=	JMS I GETBA
GETDBA,	GETDB0			/GET A DATA BLOCK
GETDDB=	JMS I GETDBA
PRINTA,	PRINT0			/TYPE OUT A CHARACTER
PRINT=	JMS I PRINTA
GETJT0,	GETJTB			/GET JOB DATA TABLE ADDRESS
GETJTA=	JMS I GETJT0
RETBA,	RETB			/RETURN BLOCK TO FREE STORAGE
RETBLK=	JMS I RETBA
WAITA,	WSCHED
WAIT=	JMP I WAITA
DEVOVR,	JOBTBL			/END OF DEVICE TABLE; START OF JOB TABLE

*20
FIUSAC,	0			/SAVED USER AC
FIJOB,	0			/JOB NUMBER FILE PHANTOM IS REPRESENTING
FIOPTR,	0			/POINTER TO FIELD 0 IOT
GDRETP,	0			/RETRIEVAL POINTER, SET BY GD0 ROUTINE
WNDREM,	0			/REMAINDER FROM DIVISION BY 7
BUFSTA,	0			/BUFFER STATUS, 7777 IF FULL
BUFMOD,	1			/BUFFER MODIFIED IF =0; UNCHANGED IF =1
SATSTA,	0			/SATSTATUS, 7777 IF CHANGED THIS RUN
TABSTA,	0			/TABLE STATUS, 7777 IF CHANGED THIS RUN

/POINTERS TO FILE PHANTOM'S INTERNAL TABLES

JOBTAB,	JTABLE			/TABLE OF PROJ,PROG NUMBERS FOR ALL ACTIVE JOBS
ENTEND,				/END OF ENTRY TABLE
UFDTBL,	UTABLE			/TABLE OF ALL ACCESSED UFD'S
UFDEND,				/TOP OF UFD TABLE
RETTBL,	RTABLE			/TABLE OF RETRIEVAL INFORMATION FOR ALL ACCESSED UUFD'S
ENTTBL,	ENTABL-10		/TABLE REFLECTING STATE OF ALL POSSIBLE FILE NUMBERS
BUFFER,	5400			/BUFFER FOR DIRECTORY MANIPULATIONS
SATBOT,	-SATSIZ			/BOTTOM OF STORAGE ALLOCATION TABLE

/SUBROUTINE POINTERS

DE01,	DE0			/GET A DIRECTORY ENTRY
DS01,	DS0			/DIRECTORY SEARCH
GE01,	GE0			/GET A DIRECTORY WORD INTO CORE
GD01,	GD0			/GET A FILE DIRECTORY ENTRY INTO CORE
WRT1,	WR1			/MAKE SURE THE BUFFER IS EMPTY
DTE01,	DTE0
FIO01,	FIPIO			/COMMON DISC I/O ROUTINE
SATL1,	SATLOK			/GET A FREE SEGMENT FROM SAT
TF01,	TF0			/FREE AN ENTRY ON UFD TABLE
UC01,	UC0			/USER-OWNER FILE CHECK
UFO01,	UFO0			/OPEN A UFD
UTS01,	UTS0			/SEARCH UFD TABLE FOR PROJ,PROG NUMBER
CL01,	CL0			/CLOSE A FILE
WND201,	WND20			/DIVIDE BY SEVEN
FIEXIT,	FIX0			/EXIT ROUTINE
BLDP1,	BLDP			/BUILD A POINTER TO ENTTBL
ENR01,	ENR0
REL01,	REL00
WR01,	WR0
GTBLO1,	GTBLOK
EBLD0,	EBLD
JBLD0,	JBLD
FIX401,	FIX40
IFN01,	IFN0
LGI201,	LGI20			/-1 TO USER AC
FGETJT=	JMS I	.
	FGETJ0
DIRBAD,	BADDIR

/CONSTANTS

C0006,	6
C0200,	200
P0037,	37
P0003,	3
P6000,	6000
P0777,	777
C0605,	6605
C0005,	5
C0603,	6603
C7774,	-4
C4400,	4400
C7771,	7771
P7770,	7770

CFLD=	CDF 20			/FIP IS ALWAYS IN FIELD 2
EXQ1,
UTPRNU,	0			/USED BY UTS0 ROUTINE TO HAVE THE PTR TO UFD TABLE WHILE SEARCHING
CFH,	0			/THIS LOCATION IS USED FOR TEMP STORAGE BY MANY ROUTINES
ACC01,	ACT01			/SEE IF CALLING USER IS ACCOUNT 1
BASCO1,	BASCO0			/SEE IF THE FILE IS BASIC
BASSWT,	0			/SWITCH FOR BASIC
C0010,	10
C7700,	7700
BASWIN,	WINBAS			/FIELD 1 ADDRESS OF BASIC WINDOW
BAS1A,	BAS0			/CREATES A BASIC WINDOW
SEGLIM,	0
REWNDC,
REL6,	0



FIOSTK,	0			/STACK HOLDING IOT LINKAGE
	0
	0
	0
	0
	0
	0
	0

FLPARB,	0			/TABLE FOR READ OR WRITE PARAMETER CONSTRUCTION
	0
	0
	0
	0
	0
	OVERLA
	0

/ROUTINE TO RELEASE FREE BLOCK, (IF ANY), IF IT IS
/NECESSARY TO ABORT FIP FOR SOME REASON.
RETURN,	TAD	FIOSTK		/GET THE IOT THAT BROUGHT US HERE
	CMA			/IS THERE A PARAMETER BLOCK?
	AND	C4010
	SZA CLA
	JMP I	FIEXIT		/NONE, OK TO EXIT
	DATFLD
	TAD I	FIOPTR		/GET THE BLOCK
	JMS I	RETBK1		/RETURN IT SO IT WON'T BE LOST FOREVER
	CLA
	JMP I	FIEXIT		/NOW IT'S OK TO LEAVE

C4010,	4010			/MASK FOR FINF AND WHO

/FILE PHANTOM START
/FIP'S FIRST JOB IS TO PICK UP THE IOT WHICH IT IS TO PERFORM
/AND THE PARAMETERS WHICH GO ALONG WITH IT (IF ANY). THESE
/ARE MOVED INTO AN 8-WORD BLOCK CALLED 'FIOSTK.' THE FIRST REG-
/ISTER IN THIS BLOCK CONTAINS THE IOT, PARAMETERS FOLLOW
*200

FIP0,	CLL CLA IAC
	DCA	BUFMOD		/MARK BUFFER AS NOT MODIFIED
	DCA	SATSTA		/CLEAR SAT STATUS
	DCA	TABSTA		/CLEAR TABLE STATUS
	TAD	BUFSTA		/IS THERE VALID DATA IN THE BUFFER?
	SZA CLA
	IAC			/YES; RE-CALCULATE DISK PARAMETERS IF NEEDED
	DCA	BUFSTA
	6201			/CDF FIELD ZERO
	TAD I	JOB		/GLOBAL TO "JOB"
	AND	P0037
	DCA	FIJOB		/SAVE IT
	CFLD
	FGETJT			/SAVE USER AC
	JOBREG+2
	DCA	FIUSAC		/ADDRESS OF USER'S AC
	FGETJT
	JOBLNK			/IOT REQUEST WORD
	DCA	FIOPTR		/POINTER TO IOT LINKAGE
	DATFLD
	TAD I	FIUSAC
	DCA	FIUSAC		/USER'S AC
	TAD I	FIOPTR		/PICK UP LINKAGE
	AND	IC7400		/IS IT AN IOT? (IF IT IS, JOBLNK WILL HAVE BITS 0-3 CLEARED)
	SNA CLA
	JMP	FIP2		/IS AN IOT, SO GO MOVE IT INTO FIOSTK (AC IS PARAMETER)
	TAD I	FIOPTR		/IS A POINTER, PICK UP LINKAGE
	DCA	FIP6		/POINTER TO LINKAGE TABLE
	CFLD
	6202			/CIF FIELD 0
	BLT			/MOVE IOT PARAMETERS INTO FIOSTK
	DATFLD
FIP6,	0
	6221			/CDF THIS FIELD
	FIOSTK			/IOT LINKAGE BUFFER
	-10
	TAD	FIOSTK
	SPA CLA			/WILL THE IOT PARAMETER BLOCK BE NEEDED TO RETURN PARS?
	JMP	FIP4		/YES, SO DON'T RETURN IT
	TAD	FIP6
	JMS I	RETBK1		/RETURN THE IOT PARAMETER BLOCK TO FREE CORE
	CLA CLL
	DATFLD
	DCA I	FIOPTR		/CLEAR JOBLNK TO AVOID CONFUSION LATER
	CFLD

/COMES HERE WHEN IOT AND ITS PARAMETERS ARE COMFORTABLY
/NESTLED IN FIOSTK
FIP4,	TAD	IOTABL
	DCA	FITPTR		/TABLE POINTER
FIP5,	ISZ	FITPTR		/PICK UP IOT FROM TABLE
	TAD I	FITPTR
	SNA			/END OF TABLE?
	JMP I	LGI201		/DON'T KNOW WHAT TO DO SO PASS BACK AN ERROR AT LEAST
	CIA			/NO
	TAD	FIOSTK		/IOT FROM USER
	SZA CLA			/DISPATCH?
	JMP	FIP5		/NO
	TAD	IOTABL		/YES, FIND PROPER POINTER
	CIA
	TAD	FITPTR
	TAD	IODSPA
	DCA	FITPTR
	TAD I	FITPTR		/PICK UP DISPATCH ADDRESS
	DCA	FITPTR
	TAD	FIOSTK		/IS THIS AN IOT WHICH DOES REQUIRE PARAMETERS TO BE
				/RETURNED IN AN IOT PARAMETER BLOCK?
	SMA CLA			/...IF SO, USER AC CONTAINS A PTR TO WHERE THEY WILL GO
	DCA	FIUSAC		/CLEAR USER AC
	JMP I	FITPTR		/DISPATCH

/COMES HERE FOR A "SHORT" IOT. SAVED AC IS ONLY PARAMETER
/PUT IT IN FIOSTK+1
FIP2,	TAD I	FIOPTR		/PICK UP IOT
	DCA	FIOSTK		/PLACE ON STACK
	TAD	FIUSAC		/USER ACCUMULATOR
	DCA	FIOSTK+1	/SIMULATE LINKAGE
	JMP	FIP4-2

IOTABL,	.			/TABLE OF USER FILE IOT'S
	ASD			/ASSIGN A DEVICE
	REL			/RELEASE A DEVICE
	REN			/RENAME A FILE
	OPEN			/OPEN A FILE
	CLOS			/CLOSE A FILE
	RFILE			/FILE READ (WINDOW MOVE)
	PROT			/FILE PROTECTION
	WFILE			/FILE WRITE (WINDOW MOVE)
	CRF			/CREATE A FILE
	EXT			/EXTEND A FILE
	RED			/REDUCE A FILE
	FINF			/FILE INFORMATION
	LIN			/LOGIN
	LOUT			/LOGOUT
	WHO			/RETURN PASSWORD
	SEGS			/RETURN # OF DISK SEGMENTS AVAILABLE
	0

IODSPA,	IODISP-1
FITPTR,	0
IC7400,	7400

/ROUTINE TO GET A DIRECTORY ENTRY INTO CORE

/CALLING SEQUENCE:
/	TAD (INTERNAL FILE NUMBER)
/	JMS GD0
/	RETURN (BUFFER POINTER IN AC, 0=ERROR)

GD0,	0
	JMS I	EBLD0
	DCA	GDUFDP
	TAD I	GDUFDP		/RELATIVE POSITION IN UFD TABLE
	JMS I	BLDP1
	DCA	GDRETP		/POINTER TO UFD RETRIEVAL INFORMATION
	ISZ	GDUFDP
	TAD I	GDUFDP		/PICK UP ENTRY ADDRESS WITHIN UFD
	DCA	GD1
	TAD	GDRETP
	JMS I	GE01		/GET ENTRY INTO CORE
GD1,	0
	JMP I	GD0
GDUFDP,	0

IFN0,	0
	TAD	FIOSTK+1
	AND	P0003
	DCA	FIOSTK+1
	JMP I	IFN0

EBLD,	0
	DCA	CFH
	TAD	FIJOB
	CLL RTL
	TAD	CFH
	RAL
	TAD	ENTTBL
	JMP I	EBLD

WR0,	0			/WRITE OUT THE CONTENTS OF THE BUFFER
	TAD	C0605		/WRITE IOT
	DCA	FLPARB		/I/O PARAMETER BLOCK
	JMS I	FIO01		/PERFORM THE WRITE
	HLT			/ERROR ON WRITE, TOO BAD
	CLA IAC
	DCA	BUFMOD		/SET NOT-MODIFIED STATUS
	JMP I	WR0

/ROUTINE TO OPEN A FILE

OPN0,	JMS I	BASCO1		/IF BASIC SET BASSWT TO -1
	DCA	OPENTT		/PTR TO ENTTBL
	JMS I	JBLD0		/PROJ PROG # OF THIS JOB IN AC
	DCA	PRJPRO		/SAVE PROJ, PROG #
	TAD	FIOSTK+2
	SNA			/IF HE OWNS THE FILE THEN FIOSTK+2 IS 0
	JMP	OPNOWN		/YES, HE DOES
	CIA
	TAD	PRJPRO		/IF HE HAS MENTIONED THE PROJ, PROG #
	SNA CLA			/CHECK IF HE IS THE OWNER
	JMP	OPNOWN
	STA
	TAD	FIOSTK+2	/TRYING TO OPEN ACCOUNT 1 FILE?
	SZA CLA
	JMP	.+6		/NO, OK
	TAD	FIOSTK+3	/WHOSE UFD?
	CIA
	TAD	PRJPRO		/HIS/HER OWN?
	SZA CLA
	JMP	OPN3		/NO, TELL HIM/HER FILE NOT FOUND
	TAD	FIOSTK+2
	AND	C7700		/TAKE OUT JUST THE PROJ # OF THE FILE
	CIA
	TAD	PRJPRO		/DOES IT AGREE WITH JOB'S PROJ #?
	AND	C7700
	SNA CLA
	TAD	P0003		/4 IN AC SAME PROJ #
	CLL IAC			/1 IN AC DIFF PROJ #
	JMP	.+4
OPNOWN,	TAD	PRJPRO
	DCA	FIOSTK+2
	TAD	C0010		/10 IN AC IF HE OWNS THE FILE
	DCA	PRJPRO		/STORE PROTECTIVE BITS FOR READ CASE
	TAD	FIOSTK+2	/PICK UP THE PROJ PROG # OF THE FILE
	JMS I	UTS01		/SEARCH OPEN UFD TABLE  RETURN WITH PTR IN AC
	JMP	OPN6		/UFD NOT OPEN, GO OPEN IT
OPN2,	DCA I	OPENTT		/SAVE ITS RELATIVE PTR IN ENTTBL
	TAD I	OPENTT		/GET RELATIVE ADDRESS OF UFD TBL
	JMS I	BLDP1		/BUILD A PTR TO RETTBL ENTRY
	DCA	FIOSTK+2	/SAVE IT
	JMS I	DS01		/3 WORD SEARCH
	FIOSTK+2
	JMP	OPN3		/NO SUCH FILE
	TAD	P0007		/PTR TO RETRIEVAL ENTRY IN BUFFER
	DCA	OPBUFP
	ISZ	OPENTT
	TAD I	ZDS1		/GET THIS FILE'S DIRECTORY ADDRESS
	DCA I	OPENTT		/SAVE IN SECOND WORD OF ENTTBL ENTRY
	CLL CMA RTL		/-3 IN AC
	TAD	OPBUFP		/PTR TO PROTECTION BIT
	JMS I	OPN11A		/CHECK PROTECTION OF THE FILE
PRJPRO,	0
	TAD I	OPBUFP		/ADD POINTER TO FIRST RETRIEVAL WINDOW AND
	DCA	PRJPRO		/SAVE WITH PROTECTION BIT
	TAD	OPNFI0		/JOB STATUS WORD FILE FOR FILE 0
	TAD	FIOSTK+1
	DCA	OPACSC		/FOR LINKING A BLOCK
	TAD I	OPBUFP		/GET RETRIEVAL WINDOW
	DCA	OPBUFP		/SAVE IT
	TAD	FIOSTK+2
	JMS I	GE01		/GET RETRIEVAL WINDOW IN CORE
OPBUFP,	0
	DCA	OPENTT		/SAVE THE BUFFER ADDRESS
	FGETJT			/GET THE ADDRESS OF JOB STATUS FOR THIS FILE
OPACSC,	0
	DCA	OPACSC		/SAVE POINTER
	TAD	OPACSC
	JMS I	GTBLO1		/GET A BLOCK LINKED FOR FILE CONTROL
	JMP	OPNOT		/NO FREE CORE; CAN'T OPEN THEN
	DCA	OPBUFP		/SAVE IT TO BUILD THE FILE CONTROL BLOCK
	ISZ	BASSWT
	JMP	OPN123
	TAD I	BASWIN		/IS BASIC WINDOW ALREADY SET UP?
	IAC
	SNA CLA			/YES THEN HAS -1
	JMP	OPRET1		/BASIC WINDOW ALREADY LOADED
	TAD	OPENTT		/BUFFER ADDRESS OF THE WINDOW
	JMS I	BAS1A		/CREATE BASIC WINDOW
OPRET1,	TAD	BASWIN		/PUT BASIC WINDOW POINTER IN CONTROL BLOCK
	DCA I	OPBUFP
OPRET,	CFLD
	CLA CMA			/ACCESS COUNT IN UFDTBL
	TAD I	UTPRNU		/INCREASE BY -1
	DCA I	UTPRNU
	DATFLD
	ISZ	OPBUFP
	ISZ	OPBUFP		/POINTS TO PROTECTION BIT
	TAD	PRJPRO
	DCA I	OPBUFP		/PUT IN THE WRITE PROT BIT CREATED BEFOREHAND
	JMP I	.+1		/EXIT AND WRITE OUT TABLES
	TABOUT

OPN123,	TAD	OPBUFP		/LINK A BLOCK
	JMS I	GTBLO1
	JMP	OPN4		/NO FREE CORE, CAN'T OPEN
	DCA	OPENTU
	CFLD
	CIF
	BLT
	CFLD			/SOURCE
OPENTT,	0
	DATFLD
OPENTU,	0
	-10
	JMP	OPRET

OPN5,	SNA			/DID THE ACCOUNT EXIST?
	JMP	OPNOT		/YES; LACK OF ROOM IN UFDTBL
OPN3,	STL CLA RTR		/NOT FOUND ERROR
OPNPRE,	TAD	P2000		/PROTECTED
	TAD	P2000
OPNOT,	CLL CML RAR		/NOT OPEN, LACK OF SYSTEM RESOURCES
	DCA	FIUSAC
	TAD	FIOSTK+1
	JMS I	EBLD0		/BE SURE TO REMOVE ALL THE POINTERS PUT IN BY OPEN
	DCA	OPENTT
	DCA I	OPENTT
	JMP I	FIEXIT

OPN4,	TAD I	OPACSC		/CONTROL BLOCK ADDR
	JMS I	RETBK1		/RETURN IT
	DATFLD
	DCA I	OPACSC		/CLEAR POINTER FROM JOB BLOCKS
	CFLD
	JMP	OPNOT		/TELL HIM/HER WE COULDN'T OPEN

OPN6,	TAD	FIOSTK+2	/PICK UP PROJ PROG #
	JMS I	UFO01		/OPEN UFD
	JMP	OPN5		/NO LUCK, ERROR
	JMP	OPN2		/OPENED RELATIVE POSITION IN AC


OPNFI0,	JOBF0
OPN11A,	OPN11


/ROUTINE TO CLOSE A FILE

*600

CLS0,	DCA	CLSIFN		/INTERNAL FILE NUMBER
	TAD	C7774
	DCA	CLCNTR		/COUNTER FOR BIT SCAN
CLS1,	TAD	FIOSTK+1	/PICK UP BIT PATTERN
	RAL
	DCA	FIOSTK+1
	SZL
	JMP	CLS3
CLS2,	ISZ	CLSIFN		/NEXT FILE NUMBER
	ISZ	CLCNTR		/DONE ALL FOUR?
	JMP	CLS1		/NO, KEEP AT IT
	JMP I	FIEXIT		/THROUGH
CLS3,	TAD	CLSIFN		/PICK UP INTERNAL FILE NUMBER
	JMS	CL0		/CLOSE THE FILE
	JMP	CLS2		/LOOK FOR MORE

CLSIFN,	0
CLCNTR,	0

/ROUTINE TO DO ACTUAL FILE CLOSE
CL0,	0
	JMS I	EBLD0
	DCA	CLENTP
	TAD	CFH
	JMS I	LNK01		/RETURNS WITH PTR TO FILE CONTROL BLOCK FROM JOB STATUS BLOCK
	SNA
	JMP	CL3		/FILE WAS NOT OPEN
	DCA	CLPARP		/SAVE IT
	DCA I	CFH		/CLEAR POINTER TO FILE CONTROL BLOCK --- INDICATES FILE CLOSED
	CFLD			/SET DATA FIELD TO THIS FIELD
	TAD	CLPARP		/POINTER TO PARAMETER BLOCK
	JMS I	CLOBA		/PROPERLY CLOSE TESTING FOR BASIC
	DCA	CLO3		/SWITCH SET TO -1 IF BASIC FILE
	CLA CMA CLL
	TAD I	CLENTP		/RELATIVE POINTER TO UFD RETRIEVAL TABLE
	CLL RTL
	IAC
	TAD	UFDTBL
	DCA	CLUFDP		/POINTER TO ACCESS COUNTER
	DCA I	CLENTP		/CLEAR PTR IN ENTTBL TO INDICATE FILE IS CLOSED
	CLA CMA
	DCA	TABSTA		/SET TABLE STATUS TO WRITE OUT
	ISZ I	CLUFDP		/REMOVE THIS JOB FROM ACCESS COUNT IN UFDTBL
	JMP I	CL0

/THIS WAS THE ONLY GUY USING THIS UFD, SO CLOSE IT OUT
	ISZ	CLO3		/IS IT BASIC FILE BEING CLOSED?
	JMP	CL11		/NO, PROCEED FURTHER
	DATFLD			/YES, JUST ZERO ONE LOC IN FIELD 1
	DCA I	BASWIN
	CFLD
CL11,	CLA CMA			/NO ONE IS NOW ACCESSING THIS UFD
	TAD	CLUFDP
	JMS I	TF01		/FREE A TABLE ENTRY
CL3,	CFLD
	JMP I	CL0

CLOBA,	CLOBAS
CLPARP,	0
CLENTP,	0
CLUFDP,	0

/SKIPS IF NO OTHER USER IS ACCESSING THIS FILE
ENR0,	0
	TAD	FIOSTK+1
	JMS I	EBLD0
	DCA	ENR1		/PTR INTO ENTTBL
	ISZ	ENR1
	TAD I	ENR1		/GET ADDR IN ENTTBL
	DCA	ENR1
	TAD	GDRETP		/RTABLE
	JMS I	ENS01		/HOW MANY PEOPLE HAVE THIS FILE OPEN?
ENR1,	0
	SKP			/FOUND THE SAME FILE OPEN
	ISZ	ENR0		/...ONLY ONE WHO HAS IT OPEN
	JMP I	ENR0

ENS01,	ENS0

/CHANGE THE PROTECTION OF A FILE

PRT0,	TAD	FIOSTK+1	/PICK UP INTERNAL FILE NUMBER
	RTR
	RTR
	RAR
	AND	P0003		/AND OFF PROTECTION BITS
	DCA	PRIFNU		/INTERNAL FILE NUMBER
	TAD	PRIFNU
	JMS I	UC01		/CHECK TO SEE IF USER IS OWNER
	JMP	PRT1		/ERROR RETURN, USER IS NOT OWNER
	JMS I	ACC01		/IS HE UNDER ACCOUNT 1?
	JMP	PRT1+1		/YES; ERROR - HE MUST USE #RENAME#
	TAD	PRIFNU
	JMS I	GD01		/GET THIS DIRECTORY ENTRY INTO CORE
	SNA
	JMP I	DIRBAD		/**************DEBUG*************
	TAD	P0004
	DCA	PRENTP		/POINTER TO PROTECTION BITS OF THIS FILE
	TAD	C7637
	AND	FIOSTK+1	/PICK UP NEW PROTECTION BITS
	DCA I	PRENTP		/RESTORE
	DCA	BUFMOD		/SCHEDULE WRITE
	JMP I	FIEXIT

PRT1,	SZA CLA			/ERROR
	CLL CML RAR
	CLL CML RAR
	DCA	FIUSAC
	JMP I	FIEXIT

CLO3,
PRIFNU,	0
PRENTP,	0
C7637,	7637


WHO0,	JMS I	JBLD0
	DCA	PAS1
	CMA			/ONE WORD SEARCH
	JMS I	DS01		/SEARCH THE MFD FOR THIS ACC'T #
	PAS0
	JMP I	DIRBAD		/************DEBUG ONLY***********
	DCA	PAS1
	TAD I	PAS1		/GET ACC'T # FROM UFD FILE NAME BLOCK
	ISZ	PAS1
	DCA	FIOSTK+1	/STORE ACC'T #
	TAD I	PAS1
	ISZ	PAS1
	DCA	FIOSTK+2	/STORE FIRST TWO CHRS OF PASSWORD
	TAD I	PAS1
	DCA	FIOSTK+3	/STORE LAST TWO CHARS OF PASSWORD
	JMP I	PAINF5		/GO STORE THIS INFORMATION FOR RETURN TO MONITOR

PAINF5,	INF5
PAS0,	RTABLE
PAS1,
JBLD,	0
	TAD	FIJOB
	TAD	JOBTAB
	CFLD
	DCA	CFH
	TAD I	CFH
	JMP I	JBLD

/ROUTINE TO MOVE THE RETRIEVAL WINDOW IN FIELD ZERO
*1000

WND0,	TAD	FIOSTK+2	/PICK UP INTERNAL FILE NUMBER
	AND	P0003		/AND OFF FIELD BITS
	JMS I	EBLD0
	DCA	WNENTP		/POINTER TO RETRIEVAL INFORMATION POINTER
	TAD I	WNENTP
	JMS I	BLDP1		/GENERATE ABSOLUTE PTR INTO RETTBL
	DCA	WNRETP		/RETRIEVAL POINTER
	TAD	FIOSTK+7
	DCA	WNFCBP		/PTR TO THIS FILE'S FILE CONTROL BLOCK
	TAD	FIOSTK+5
	DCA	WND5		/LOW ORDER DISK ADDRESS
	DCA	WNDCNT		/GET INTO CORE
	TAD	WNDCCT		/INITIALIZE COUNT
	DCA	WNDSCT
	TAD	C0177
	AND	FIOSTK+1	/GET HIGH ORDER FILE ADDRESS
	DCA	WNDIRP
	TAD	SEGSIZ		/GET RID OF ADDRESS WITHIN SEGMENT
	CLL CIA
	AND	WND5
	RAL
	TAD	WNDIRP		/NOW HAVE FILE SEGMENT #; NEED TO SHIFT IT
	SKP
	RAL
	ISZ	WNDSCT		/SHIFT SEGCCT TIMES?
	JMP	.-2
	DCA	WNSEGC
	DATFLD			/WNSEGC NOW HAS SEGMENT NUMBER TO GET
	TAD I	WNFCBP		/PICK UP FIELD 0 WINDOW POINTER
	DCA	WNDPTR		/PNTS TO FILE RETRIEVAL WINDOW FOR THIS FILE
	ISZ	WNFCBP
	TAD I	WNFCBP		/PICK UP NUMBER OF CURRENT SEGMENT IN WINDOW
	DCA	WNCURS		/CURRENT SEGMENT IN WINDOW
	TAD	WNSEGC		/SEGMENT TO GET
	JMS I	WND201		/DIVIDE BY 7 (IGNORE REMAINDER)
	JMS	WND30		/MULTIPLY BY 7
	DCA	WNSEGC		/FIRST SEGMENT IN PROPER WINDOW
	CLA CMA
	TAD I	WNDPTR		/GET FIRST WORD OF FILE RETRIEVAL WINDOW
	SNA CLA			/=7777?
	JMP	WND6		/INVALID WINDOW POINTER
	TAD	WNCURS		/CURRENT SEGMENT AT TOP OF CURRENT CORE WINDOW
	CIA

/NOW SEE IF THE SEGMENT BEING SOUGHT IS ONE WHICH FOLLOWS
/THOSE WHICH ARE PRESENTLY IN THE CORE WINDOW. IF THE
/SOUGHT BLOCK DOES FOLLOW THE PRESENT ONE, WE CAN LOOK
/THROUGH THE RETRIEVAL INFORMATION BLOCKS STARTING AT THE ONE
/NOW IN CORE. OTHERWISE, WE MUST START AT THE VERY BEGINNING
/OF THE LIST OF FILE RETRIEVAL INFORMATION BLOCKS
	TAD	WNSEGC
	SPA SNA
	JMP	WND6		/PREVIOUS BLOCK, SO MUST START AT BEGINNING OF STRING
	JMS I	WND201		/DIVIDE BY 7
	CIA
	DCA	WNDCNT		/MOVE FORWARD THIS MANY WINDOWS
	TAD	WNDPTR
WND10,	DCA	WNDIRP
	TAD I	WNDIRP		/PICK UP ADDRESS OF NEXT WINDOW
	CFLD			/CHANGE TO CURRENT FIELD
	SNA
	JMP	WND13		/END OF STRING
	DCA	WND11
	TAD	WNRETP		/POINTER TO UFD RETRIEVAL INFORMATION
	JMS I	GE01		/GET ENTRY INTO CORE
WND11,	0
	ISZ	WNDCNT		/HAVE WE MOVED AHEAD ENOUGH BLOCKS?
	JMP	WND10		/NOT PROPER WINDOW, KEEP LOOKING
	DCA	WNDIRP
WND13,	6202			/CIF FIELD 0
	BLT
	6221			/SOURCE FIELD (ALWAYS 2)
WNDIRP,	0			/SOURCE
	DATFLD			/DESTINATION FIELD
WNDPTR,	0			/DESTINATION
	-10			/WORD COUNT
	TAD	WNDCNT		/CORRECT FOR WINDOWS THAT WEREN'T THERE
	JMS	WND30		/MULTIPLY BY 7
	TAD	WNSEGC		/SEGMENT NUMBER OF FIRST IN WINDOW
	DATFLD
	DCA I	WNFCBP		/FILE CONTROL BLOCK POINTER
	ISZ	WNFCBP		/POINT AT PROTECTION WORD IN CONTROL BLOCK
	TAD I	WNFCBP		/GET CURRENT STATUS
	AND	P0007		/SAVE ONLY STATUS BITS
	TAD	WND11		/ADD IN POINTER TO CURRENT RETRIEVAL WINDOW
	DCA I	WNFCBP		/AND SAVE
	JMP I	.+1		/GO SET #JSIOTC# BEFORE EXITING
	INF6

WND6,	CFLD			/CHANGE TO CURRENT FIELD
	CLA CLL
	TAD	WNSEGC		/SEGMENT TO GET INTO IN CORE WINDOW
	JMS I	WND201		/DIVIDE BY 7
	CMA
	DCA	WNDCNT		/WINDOW NUMBER TO GET INTO CORE
	ISZ	WNENTP
	TAD I	WNENTP		/UFD ENTRY ADDRESS OF OPEN FILE
	DCA	WND5
	TAD	WNRETP		/RETRIEVAL INFORMATION POINTER
	JMS I	GE01		/GET ENTRY INTO CORE
WND5,	0
	TAD	P0007
	JMP	WND10

/ROUTINE TO MULTIPLY A NUMBER BY 7

WNDSCT,
WND30,	0
	DCA	CFH
	TAD	CFH
	CLL RAL
	TAD	CFH
	CLL RAL
	TAD	CFH
	JMP I	WND30

WNFCBP,	0
WNENTP,	0
WNRETP,	0
WNDCNT,	0
WNSEGC,	0
WNDCCT,	7773
WNCURS,	0
C0177,	177


IODISP,
	ASD1
	REL1
	REN0
	OPN0
	CLS0
	WND0
	PRT0
	WND0
	CRF0
	EXT0
	RED0
	INF0
	LGI0
	LGO0
	WHO0
	SEGS0

*1200

/ROUTINE TO CREATE A NEW FILE

CRF0,	TAD	FIOSTK+1
	SNA CLA
	JMP	CRF30
	JMS I	JBLD0
	JMS I	UTS01		/SEARCH THE UFD TABLE
	JMP I	DIRBAD		/***************DEBUG**************
	JMS I	BLDP1		/BUILD A PTR TO RETTBL
	DCA	FIOSTK		/MAKE A LINKAGE FOR DIRECTORY SEARCH
	JMS I	ACC01		/IS IT ACCOUNT 1?
	CMA			/YES; MAKE IT A ONE WORD SEARCH
	JMS I	DS01		/SEARCH THE DIRECTORY FOR THIS NAME
	FIOSTK			/POINTER TO SEARCH PARAMETERS
	JMP	CRF2		/COULD NOT FIND THIS NAME, CONTINUE
	DCA	CRBUFP		/FOUND A FILE OF THIS NAME IN UFD. PTR INTO CRBUFP
	JMS I	ACC01		/SEE IF THIS IS ACCOUNT 1
	JMP	CRF30		/CAN'T DELETE UFD'S AS THOUGH THEY ARE FILES
	TAD I	ZDS1		/POINTER TO "DS1"=ADDR WITHIN UFD WHERE THIS FILE NAME'S BLOCK IS
	DCA	CRF11		/UFD ADDRESS OF DIRECTORY ENTRY
	TAD	FIOSTK
	JMS I	CRENS		/SEARCH ENT TABLE FOR ACCESSES TO THIS FILE
CRF11,	0			/UFD ADDR OF DIRECTORY ENTRY
	JMP	CRF10		/ERROR, FILE IS OPEN
/COMES HERE IF A FILE BY THIS NAME ALREADY EXISTS, BUT NO ONE HAS OPENED IT
	TAD	CRF11
	DCA I	CRGD11		/GD1
	TAD	FIOSTK
	DCA	GDRETP
	TAD	CRBUFP		/PTR TO WHERE IN CORE BUFFER THE UFD BLOCK FOR THIS FILE IS
	JMS I	SAVCRA		/DELETE THE EXISTING FILE OF THIS NAME
	JMS I	DS01		/SEARCH THE UFD FOR AN EXISTING FILE OF THE SAME NAME
	FIOSTK
	SKP			/NONE THERE, SO OKAY TO CREATE ONE
	JMP I	DIRBAD		/**************DEBUG ONLY**********

/NOW ALL SET TO CREATE THE FILE. TO DO THIS, WE NEED TWO BLOCKS OF
/THE UFD -- ONE FOR A NAME BLOCK AND THE SECOND FOR A FILE RETRIEVAL INFORMATION
/BLOCK. THESE BLOCKS ARE OBTAINED BY TWO CALLS TO DE0. AFTER THE FIRST,
/A DUMMY 7777 IS PUT IN THE FOUND BLOCK TO PREVENT THE SECOND CALL
/TO DE0 FROM FINDING THE SAME BLOCK. IF BOTH BLOCKS CANNOT BE OBTAINED,
/THE CREATE CANNOT BE EXECUTED.
CRF2,	DCA	CRLINK		/ADDR OF LINK WORD OF LAST ENTRY IN UFD CHAIN
	ISZ	UTPRNU		/POINTS AT LOGIN DISK QUOTA
	TAD I	UTPRNU		/-SEGMENTS ALLOWED WHILE LOGGED IN
	TAD	SEGLIM		/PLUS NUMBER OF SEGMENTS FOUND WHILE SEARCHING HIS/HER DIRECTORY
	ISZ	UTPRNU		/POINT AT HOLD REG FOR SEGMENT COUNT
	SMA CLA			/IS HE ALLOWED ONE MORE?
	JMP	CRF1		/NO; TELL HIM/HER DIRECTORY FULL
	TAD	FIOSTK		/POINTER TO RETRIEVAL INFORMATION
	JMS I	DE01		/FIND AN EMPTY DIRECTORY ENTRY
	JMP	CRF1		/ERROR, NO AVAILABLE ENTRIES
	DCA	CRF4		/ADDRESS OF THIS ENTRY
	JMS	CRF40		/GET THIS ENTRY INTO CORE
	CLA CMA
	DCA I	CRBUFP		/SIMULATE A USED ENTRY
	DCA	BUFMOD		/SCHEDULE WRITE
	TAD	FIOSTK
	JMS I	DE01		/FIND ANOTHER ENTRY
	JMP	CRF51		/ERROR
	DCA	CRF3
	TAD	FIOSTK
	JMS I	GE01		/MAKE SURE SECOND ENTRY IS IN CORE
CRF3,	0
	DCA	INDEX
	JMS I	SATL1		/FIND A FREE SEGMENT IN THE SAT
	SNA
	JMP	CRF20		/COULD NOT FIND A FREE SEGMENT

/AT THIS POINT, WE HAVE A DISC SEGMENT AND TWO BLOCKS FROM THE
/UFD. THIS IS ALL THAT IS NEEDED, SO GO AHEAD AND EXECUTE THE CREATE
	DCA	CRF11		/SAVE SEGMENT NUMBER
	TAD	CRF11
	DCA I	INDEX		/PUT IT IN THE FIRST BLOCK OF RETRIEVAL
	DCA	BUFMOD		/SCHEDULE WRITE
	JMS	CRF40		/GET FIRST FOUND ENTRY INTO CORE
	TAD	FIOSTK+1	/TRANSFER FILE NAME INTO DIRECTORY ENTRY
	DCA I	CRBUFP
	TAD	CRBUFP		/MOVE POINTER TO AUTO-INDEX
	DCA	INDEX
	TAD	FIOSTK+2
	DCA I	INDEX
	TAD	FIOSTK+3
	DCA I	INDEX
	DCA I	INDEX		/ZERO LINK (THIS IS THE LAST FILE)
	TAD	CRPROT		/PICK UP PROTECTION BITS
	DCA I	INDEX		/STORE INITIAL PROTECTION CODE
	JMS I	CRFUFA		/GO SEE IF WE'RE CREATING A NEW ACCOUNT
	CDF			/CDF FIELD 0
	TAD I	DATE		/GLOBAL TO DATE
	CFLD			/CHANGE TO CURRENT FIELD
CRFUFR,	DCA I	INDEX		/STORE DATE OF CREATION
	TAD	CRF3		/POINTER TO RETRIEVAL
	DCA I	INDEX		/SET UP PTR TO RETRIEVAL INFORMATION
	DCA	BUFMOD		/SCHEDULE WRITE
	TAD	FIOSTK		/GET LAST ENTRY ON STRING INTO CORE
	JMS I	GE01
CRLINK,	0
	DCA	CRBUFP		/PTR TO WHERE THE PRESENT LAST ENTRY IS
	TAD	CRF4
	DCA I	CRBUFP
	DCA	BUFMOD		/SCHEDULE WRITE
	JMS I	ACC01		/IS HE CREATING A NEW UFD?
	JMP	CRFUFZ		/YES
	IAC
CRFSEG,	TAD	SEGLIM		/STORE SEGMENT COUNT IN THE UFDTBL
	DCA I	UTPRNU
	JMP I	.+1		/REMEMBER TO WRITE OUT THE TABLES
	TABOUT

CRFUFZ,	TAD	CRF11
	JMS I	SCL01		/WRITE OUT DIRECTORY BLOCK & CLEAR NEW UFD BLBOCK
	JMP I	FIEXIT		/DON'T MODIFY THE MFD'S ENTRY IN THE UFDTBL

CRF20,	STL RTR			/DISK FULL
	STL RTR
	DCA	FIUSAC		/SAVE PARTIAL ERROR CODE
CRF51,	JMS	CRF40		/GET FIRST ENTRY BACK AGAIN
	DCA I	CRBUFP		/ZERO OUT THE -1 WE PUT THERE
	DCA	BUFMOD		/SCHEDULE WRITE
CRF1,	CLA CLL CML RTR
	CLL CML RAR
	TAD	FIUSAC		/GET PARTIAL ERROR CODE
	DCA	FIUSAC		/SAVE ERROR CODE; EITHER DISK FULL OR DIRECTORY FULL
	JMP	CRFSEG		/GO SAVE SEGMENT COUNT ANYWAY
CRF30,	CLA CLL CML RTR
CRF10,	TAD	C4400
	DCA	FIUSAC		/SAVE ERROR CODE; EITHER FILE IN USE OR BAD FILE NAME
	JMP I	FIEXIT

CRF40,	0
	TAD	FIOSTK
	JMS I	GE01
CRF4,	0
	DCA	CRBUFP
	JMP I	CRF40


CRPROT,	12
CRGD11,	GD1
CRENS,	ENS0
SAVCRA,	SAVCRE
SCL01,	SCL0
CRFUFA,	CRFUFD
CRBUFP,	0

/ROUTINE TO EXTEND A FILE

*1400

EXT0,	JMS	EXT1		/MAKE SURE IT'S OKAY TO EXTEND THIS FILE
	TAD	P0007		/...EXT1 RETURNS WITH PTR TO NAME BLOCK FOR THIS FILE
	DCA	EXBUFP		/SAVE POINTER TO RETRIEVAL CHAIN
	JMS I	EXTQUA		/CHECK THE DISK QUOTA FOR THIS USER
/NOW TRACE THROUGH TO LAST RETRIEVAL INFORMATION BLOCK FOR THIS FILE
EXT4,	TAD I	EXBUFP
	SNA			/END OF CHAIN?
	JMP	EXT3		/YES
	DCA	EXWNDP		/WINDOW POINTER
	TAD	EXWNDP
	JMS	EXGE0		/GET WINDOW INTO CORE
	DCA	EXBUFP		/SAVE POINTER TO NEXT RETRIEVAL WINDOW
	JMP	EXT4		/KEEP LOOKING FOR END

EXT3,	TAD	C7771
	DCA	EXT1		/7 SEGS PER WINDOW
EXT5,	ISZ	EXBUFP
	TAD I	EXBUFP		/PICK UP ENTRY IN WINDOW
	SNA CLA			/IS IT THE FIRST FREE?
	JMP	EXT7		/YES, FIND A SEGMENT
	ISZ	EXT1		/END OF WINDOW?
	JMP	EXT5		/NO, KEEP LOOKING
EXT9,	TAD	GDRETP		/RETRIEVAL POINTER
	JMS I	DE01		/FIND AN EMPTY ENTRY
	JMP	EXT20		/PARTIALLY SATISFIED
	DCA	EXNFRE		/FREE SEGMENT ADDRESS
	TAD	EXWNDP		/CURRENT WINDOW POINTER
	JMS	EXGE0		/GET IT INTO CORE
	DCA	EXBUFP
	JMS I	SATL1		/GET A FREE DISK SEGMENT FOR THE NEXT WINDOW
	SNA
	JMP	EXT20		/THERE ARE NONE; AVOID LINKING TO NEXT WINDOW
	DCA	EXPROP		/SAVE UNTIL WINDOWS ARE LINKED UP
	TAD	EXNFRE		/NEXT FREE WINDOW
	DCA I	EXBUFP		/LINK IT ONTO CHAIN
	DCA	BUFMOD		/SCHEDULE WRITE
	TAD	EXNFRE
	DCA	EXWNDP		/UPDATE CURRENT WINDOW POINTER
	TAD	EXWNDP
	JMS	EXGE0		/GET NEW WINDOW INTO CORE
	IAC
	DCA	EXBUFP		/POINTER TO FIRST ENTRY OF NEW WINDOW
	TAD	C7771		/ALLOW 7 ENTRIES IN NEW WINDOW
	DCA	EXT1
	TAD	EXPROP		/GET DISK SEGMENT

EXT12,	DCA I	EXBUFP		/STORE SEGMENT IN RETRIEVAL WINDOW
	DCA	BUFMOD		/SCHEDULE WRITE
	ISZ I	EXQ1		/INCREMENT TOTAL COUNT IN UFDTBL
	ISZ	EXBUFP		/INCR WINDOW POINTER
	ISZ	EXSEGC		/HAVE WE EXTENDED FAR ENOUGH?
	JMP	EXT6		/NO
EXT20,	TAD	EXSEGC
	CIA
	DCA	FIUSAC		/NUMBER OF SEGMENTS WE FAILED TO FIND
	TAD	FIOSTK+1	/REQUEST IS SATISFIED
	JMS I	GD01		/GET DIRECTORY ENTRY INTO CORE
	TAD	C0005
	DCA	EXBUFP		/POINTER TO SEGMENT COUNT
	TAD	FIOSTK+2	/NUMBER OF WORDS TO BE ADDED
	TAD I	EXBUFP		/NUMBER ALREADY IN FILE
	TAD	EXSEGC		/MINUS NUMBER WE FAILED TO GET
	DCA I	EXBUFP		/UPDATE ENTRY
	DCA	BUFMOD		/SCHEDULE WRITE
	JMP I	.+1		/EXIT AND WRITE OUT TABLES
	TABOUT

EXT6,	ISZ	EXT1		/END OF CURRENT WINDOW?
	SKP			/NOT YET
	JMP	EXT9		/YES, TRY LINKING TO ANOTHER
EXT7,	JMS I	SATL1		/GET A FREE SEGMENT FROM SAT
	SNA
	JMP	EXT20		/PARTIALLY SATISFIED
	JMP	EXT12		/SAVE NEW SEGMENT
EXGE0,	0			/GET WORD OF THIS UFD INTO CORE
	DCA	EXGE1
	TAD	GDRETP
	JMS I	GE01
EXGE1,	0
	JMP I	EXGE0

EXT30,	TAD	C4400
	JMP	EXT10+2

EXT10,	CLL CML RAR
	CLL CML RAR
	DCA	FIUSAC
	JMP I	FIEXIT

EXTQUA,	EXTQU0
EXFCBP,	0
EXPROP,	0
EXBUFP,	0
EXWNDP,	0
EXSEGC,	0
EXNFRE,	0

/ROUTINE TO SET UP TO ALTER A FILE (BY EITHER EXTENDING IT OR
/REDUCING IT). CHECK PROTECTION CODE TO SEE IF THIS IS ALLOWED. MAKE SURE
/NO ONE ELSE HAS THIS FILE OPEN. JMP TO ERROR EXIT ON EITHER OF THESE CON-
/DITIONS. IF ALL IS OKAY. RETURN WITH PTR TO UFD NAME BLOCK ENTRY
EXT1,	0
	JMS I	IFN01		/MASK OFF BITS 0-9 OF FIOSTK+1
	TAD	FIOSTK+1	/INTERNAL FILE NUMBER
	JMS I	LNK01		/GET PTR TO APPROPRIATE FILE CONTROL BLOCK
	SNA
	JMP	EXT10+1		/ERROR, FILE NOT OPEN
	DCA	EXFCBP		/FILE CONTROL BLOCK POINTER
	JMS I	ACC01		/AS HE UNDER ACCOUNT1?
	JMP	EXT2		/YES; SKIP PROTECTION CHECK
	TAD	FILPRP		/GLOBAL TO "FILPRO"
	TAD	EXFCBP
	DCA	EXPROP		/POINTER TO PROTECTION BIT
	DATFLD			/CDF FIELD 1
	TAD I	EXPROP		/PICK UP PROTECTION BIT
	CFLD			/CHANGE TO CURRENT FIELD
	AND	P0004		/STRAIN OFF ANY EXTRANEOUS BITS
	SZA CLA
	JMP	EXT10		/WRITE PROTECTED
EXT2,	TAD	FIOSTK+1	/INTERNAL FILE NUMBER
	JMS I	GD01		/GET DIRECTORY ENTRY INTO CORE
	DCA	REL6		/POINTS TO WHERE UFD NAME BLOCK IS IN CORE
	JMS I	ENR01		/IS THIS THE ONLY USER WHO HAS THIS FILE OPEN?
	JMP	EXT30		/NO, SO ABORT AND RETURN ERROR CODE
	TAD	FIOSTK+2	/ARE ANY SEGMENTS INVOLVED?
	SNA
	JMP I	FIEXIT		/NO, NOTHING TO DO THEN
	CIA
	DCA	EXSEGC		/SAVE NEGATIVE COUNT
	DATFLD
	TAD I	EXFCBP		/GET POINTER TO CURRENT WINDOW
	DCA	EXPROP
	IAC
	DCA I	EXPROP		/INVALIDATE THE WINDOW
	CFLD
	TAD	REL6
	JMP I	EXT1

/ROUTINE TO REDUCE A FILE

*1600

RED0,	JMS I	EXT11		/MAKE SURE IT'S OKAY TO REDUCE THIS FILE
	DCA	REBUFP		/...IF OKAY, RETURNS WITH PTR TO FILE NAME BLOCK
	JMS I	ACC01		/IS HE UNDER ACCOUNT 1?
	JMS I	REDUFD		/SEE IF HE'S REDUCING A UFD
	TAD	REBUFP
	TAD	C0005
	DCA	RELINK		/NOW POINTS TO NUMBER OF SEGMENTS PRESENTLY IN FILE
	TAD	FIOSTK+2	/SEGMENTS TO BE REMOVED
	SPA			/IS IT NEGATIVE?
	JMP	RED5		/YES; DELETE THE ENTIRE FILE
	CIA
	TAD I	RELINK
	SMA SZA			/DELETE THE FILE?
	JMP	RED6		/NO, REDUCE IT
RED5,	CLA CLL			/YES, WIPE IT OUT AND CLOSE
	TAD	REBUFP
	JMS	RED1		/WIPE OUT THE FILE NAME BLOCK FROM THE UFD
	TAD	FIOSTK+1	/INTERNAL FILE NUMBER
	JMS I	CL01		/CLOSE THIS FILE SINCE IT NO LONGER EXISTS
	JMP I	FIEXIT
RED6,	DCA I	RELINK		/UPDATE SEGMENT COUNT
	DCA	BUFMOD		/SCHEDULE WRITE
	TAD I	RELINK
	DCA	CFH
	ISZ	RELINK
	ISZ	RELINK
	TAD I	RELINK
	DCA	RELINK		/POINTER TO FIRST WINDOW ON CHAIN
	TAD	CFH
	JMS	RED40		/WIPE OUT REST OF FILE
	JMP I	FIEXIT

REDGD1,	GD1

RED40,	0
	JMS I	WND201		/DIVIDE BY 7
	CMA
	DCA	REWNDC		/NUMBER OF WHOLE WINDOWS WHICH ARE TO REMAIN
	TAD	RELINK		/GET POINTER TO FIRST RETRIEVAL WINDOW
	JMS I	RED302		/ROUTINE TO DO ACTUAL REDUCTION
	JMP I	RED40

EXT11,	EXT1
LINK01,	LINK0
RED302,	RED30
REDUFD,	REDUF0
REBUFP,	0

/ROUTINE TO DELETE A FILE

UFBUFP,
RED1,	0
	DCA	REBUFP		/PTR TO THE UFD ENTRY FOR THE FILE
	TAD	REBUFP
	TAD	P0003
	DCA	RELINK		/LINK TO NEXT FILE NAME IN THIS UFD
	TAD I	RELINK
	DCA	RED3
	TAD I	REDGD1		/UFD ADDR OF THIS DIRECTORY ENTRY
	DCA	RED4
	TAD	REBUFP
	TAD	P0007
	DCA	RELINK		/NOW POINTS TO A RETRIEVAL BLOCK FOR THIS FILE
	TAD I	RELINK
	DCA	RELINK
RED2,	DCA I	REBUFP		/CLEAR OUT FIRST WORD OF ENTRY
	ISZ	REBUFP
	TAD	REBUFP
	AND	P0007
	SZA CLA			/END OF CURRENT WINDOW?
	JMP	RED2		/NO, KEEP CLEARING
	DCA	BUFMOD		/SCHEDULE WRITE
	JMS I	LINK01
RED4,	0			/UFD ADDR OF THIS DIRECTORY ENTRY
RED3,	0			/UFD ADDR OF DIRECTORY ENTRY WHICH IS NEXT IN THE CHAIN
	JMS	RED40		/GO WIPE OUT ACTUAL FILE
	JMP I	RED1

/ROUTINE TO EXTEND A UFD

/CALLING SEQUENCE:
/	TAD (RETRIEVAL POINTER)
/	JMS UFD0
/	ERROR RETURN
/	NORMAL RETURN

UFD0,	0
	DCA	UFRETP		/RETRIEVAL POINTER
	TAD	C7771
	DCA	CFH		/COUNTER FOR OVERSIZE UFD
/NOW SCAN DOWN THE UFD'S FILE RETRIEVAL BLOCK
UFD2,	TAD I	UFRETP
	SNA CLA
	JMP	UFD1		/FOUND THE END OF THE LIST OF SEGMENT NUMBERS
	ISZ	UFRETP		/POINT TO NEXT SEGMENT NUMBER
	ISZ	CFH		/UFD ALREADY MAXIMUM SIZE?
	JMP	UFD2		/NO, LOOK AT NEXT WORD
	JMP I	UFD0		/YES, ERROR RETURN

/COMES HERE WHEN IT HAS FOUND THE END OF THE RETRIEVAL BLOCK'S LIST OF SEGMENTS
UFD1,	JMS I	SATL1		/GET A FREE SEGMENT FROM SAT
	SNA
	JMP I	UFD0		/NO MORE FREE SEGMENTS
	DCA I	UFRETP		/ADD TO RETRIEVAL INFORMATION
	TAD	UFRETP
	JMS I	ENS31		/CONVERT ABS RETTBL PTR TO A RELATIVE ENTRY NUMBER
	CLL RTL			/...TIMES FOUR
	TAD	UFDTBL		/...PLUS BASE ADDR OF UFDTBL
	DCA	CFH		/POINTER TO PROJ,PROG NUMBER OF FILE OWNER
	TAD I	CFH		/PICK UP PROJ,PROG NUMBER
	JMS I	UFO61		/GO GET THE RETRIEVAL INFO FOR THIS GUY'S UFD INTO CORE
	JMP I	DIRBAD		/*************DEBUG ONLY***********
	DCA	UFBUFP		/PTR TO RETRIEVAL INFORMATION
	ISZ	UFBUFP
	TAD I	UFBUFP
	SZA CLA			/SCAN TO END OF LIST OF SEGMENT NUMBERS
	JMP	.-3
	TAD I	UFRETP		/GET NUMBER OF NEW SEGMENT
	DCA I	UFBUFP		/PUT IT IN RETRIEVAL BLOCK LIST
	DCA	BUFMOD		/SCHEDULE WRITE
	STA
	DCA	TABSTA		/SET TABLE STATUS TO CHANGE
	TAD I	UFRETP		/NEW SEGMENT NUMBER
	JMS	SCL0		/ZERO OUT THE NEW SEGMENT
	ISZ	UFD0		/SET UP NORMAL RETURN
	JMP I	UFD0

ENS31,	ENS3
UFO61,	UFO6

/ROUTINE TO ZERO OUT A DISC SEGMENT
/IT ZEROES THE CORE BUFFER THEN EXECUTES A CALL
/TO RD301 (THE ACTUAL READ NEVER HAPPENS).
/THUS, THE SYSTEM THINKS THAT THE SEGMENT BEING
/CLEARED IS ACTUALLY IN CORE. IT WILL BE WRITTEN OUT LATER.
SCL0,	0
	DCA	UFRETP		/SEGMENT NUMBER
	JMS I	WRT1		/MAKE SURE THE BUFFER IS EMPTY
	TAD	P7400
	DCA	CFH		/SET UP COUNTER FOR CLEARING SEGMENT
	TAD	BUFFER
	DCA	UFBUFP
UFD3,	DCA I	UFBUFP		/START TO CLEAR BUFFER AREA
	ISZ	UFBUFP
	ISZ	CFH
	JMP	UFD3
	STA
	TAD	UFRETP		/SEGMENT NUMBER
	JMS I	SCL11		/NOW FAKE A READ
	DCA	BUFMOD		/SCHEDULE WRITE
	JMP I	SCL0
RELINK,
UFRETP,	0
SCL11,	SCL1
P7400,	7400


/ROUTINE TO PROVIDE FILE INFORMATION

*2000

INF0,	JMS I	IFN01		/GET INTERNAL FILE NUMBER IN FIOSTK+1
	TAD	FIOSTK+1	/INTERNAL FILE NUMBER
	JMS I	EBLD0
	DCA	CFH		/RELATIVE POINTER TO UFD RETRIEVAL INFORMATION
	TAD I	CFH		/GET PTR TO RETTBL OUT OF ENTTBL
	SNA			/DOES IT EXIST?
	JMP	INF1		/NO, SO FILE IS NOT OPEN
	CIA
	CLL CMA RTL		/SUBTRACT ONE; MULTIPLY BY FOUR
	TAD	UFDTBL
	DCA	INUFDP		/POINTER TO USER PROJ,PROG NUMBER
	TAD I	INUFDP
	DCA	FIOSTK+2	/SET UP LINKAGE FOR GD0
	TAD	FIOSTK+1	/INTERNAL FILE NUMBER
	JMS I	GD01		/GET DIRECTORY ENTRY FOR THIS FILE INTO CORE
	CIA
	CMA
	DCA	INDEX		/SET UP INDEX REGISTER FOR TRANSFER
	TAD I	INDEX		/OF NAME AND OTHER DIRECTORY INFORMATION
	DCA	FIOSTK+3
	TAD I	INDEX
	DCA	FIOSTK+4
	TAD I	INDEX
	DCA	FIOSTK+5
	ISZ	INDEX
	TAD I	INDEX
	DCA	FIOSTK+6
	TAD I	INDEX
	DCA	FIOSTK+7
INF5,	DATFLD
	TAD I	FIOPTR		/PICK UP JOBLNK WORD FROM JOB STATUS BLOCK
	DCA	INF4		/DESTINATION IN FIELD 0
	CFLD			/CHANGE TO PRESENT FIELD
	6202			/CIF FIELD 0
	BLT			/MOVE FIOSTK INFORMATION INTO IOT PARAMETER BLOCK
	6221			/SOURCE FIELD
	FIOSTK			/SOURCE
	DATFLD			/DESTINATION FIELD
INF4,	0			/DESTINATION
	-10			/WORD COUNT

INF6,	CDF
	TAD I	OURFLD
	AND	C0200
	SZA CLA
	JMP I	FIEXIT		/WE WERE CALLED BY SI - DON'T SET JSIOTC OR WE'LL GAG
	DATFLD
	TAD I	JOBDAT		/GLOBAL TO "JOBDAT"
	IAC
	DCA	INSPTR		/NOW POINTS TO STATUS WORD
	TAD	INIOTC		/JSIOTC
	CMA
	AND I	INSPTR		/SET JSIOTC TO INDICATE THAT FIP
	TAD	INIOTC		/...IS RETURNING INFORMATION IN THE IOT PAR. BLOCK
	DCA I	INSPTR
	JMP I	FIEXIT		/EXIT

INF1,	DCA	FIOSTK+2
	JMP	INF5

INUFDP,	0
INSPTR,	0
OURFLD,	CORTBL+1
INIOTC,	40


/ROUTINE TO SKIP IF CALLING USER IS NOT SYSTEM MANAGER
ACT01,	0
	JMS I	JBLD0		/GET PPN
	CLL RAR
	SZA CLA			/IS IN ACCOUNT 1?
	ISZ	ACT01		/NO; SKIP ON RETURN
	JMP I	ACT01

/LOGIN ROUTINE

LGI0,	TAD	RETTBL		/MFD RETRIEVAL IS IN ENTRY 0
	DCA	FIOSTK+1	/SET UP PTR TO RETRIEVAL INFORMATION CONTAINED IN RETTBL
	TAD	FIOSTK+2	/ACCOUNT #0
	SNA CLA
	JMP	LGI20		/UNAUTHORIZED ACCOUNT
	JMS I	DS01		/SEARCH THE MFD (AC=0 TO INDICATE 3-WORD SEARCH)
	FIOSTK+1		/ADDR OF PTR TO RETRIEVAL INFORMATION OF DIRECTORY TO BE SEARCHED
	JMP	LGI20		/COULD NOT FIND ENTRY IN MFD
	DCA	LGMFDP		/OK TO LOG IN - POINTER TO DIRECTORY ENTRY IS IN ACC.
	TAD	FIOSTK+2	/PROJ,PROG NUMBER
	JMS I	UTS01		/SEARCH THE UFD TABLE
	SKP			/THIS PROJ,PROG NUMBER NOT THERE
	JMP	LGI1		/UFD ALREADY ON TABLE - RETURNS WITH ITS RELATIVE POSITION IN TABLE
	TAD	FIOSTK+2	/PROJ,PROG NUMBER
	JMS I	UFO01		/OPEN THE UFD - I.E. MAKE AN ENTRY IN UFDTBL, RETTBL
	JMP	LGI20		/COULD NOT FIND ROOM ON TABLE

LGI1,	CLA CMA
	TAD I	UTPRNU
	DCA I	UTPRNU		/ACCOUNT FOR NEW ENTRY IN ACCESS COUNT

/COMES HERE WHEN THE UFDTBL & RETTBL HAVE BEEN UPDATED
/TO INCLUDE THIS LOGIN

	FGETJT
	JOBSTS
	DCA	LGI3		/ADDRESS OF STR0
	TAD	FIOSTK+2	/ACCOUNT NUMBER?
	AND	C7774		/IS IT LESS THAN 4?
	SNA CLA
	TAD	C0200		/YES - SET ACCOUNT PRIVILEGE BIT
	DATFLD
	DCA I	LGI3		/AND SAVE IT
	JMS I	JBLD0
	CLA
	TAD	FIOSTK+2	/PROJ,PROG NUMBER
	JMP I	.+1
	RESET

LGI20,	CFLD
	CLA CMA			/COULD NOT LOGIN - RETURN WITH 7777
	DCA	FIUSAC		/INDICATE INABILITY TO LOG IN
	JMP I	FIEXIT

LGMFDP,	0

LGI3,
GTBLOK,	0			/ VRS: reconstructed from working TSS-8
	DCA	LGMFDP
	CFLD
	TAD	LGMFDP
	CIF 0
	GETBLK
	JMP I	GTBLOK
	DATFLD
	TAD I	LGMFDP
	ISZ	GTBLOK
	JMP I	GTBLOK
REN1,	SZA CLA
	CLL CML RAR
	CLL CML RAR
	DCA	FIUSAC
	JMP I	55
WR1,	0
	TAD	BUFSTA
	TAD	BUFMOD
	SPA CLA
	JMS I	WR01
	JMP I	WR1		/ VRS: End reconstruction


/DIRECTORY SEARCH

/CALLING SEQUENCE:
/	CLA OR CIA (3 OR 1 WORD SEARCH)
/	JMS DS0
/	POINTER-----------------RETRIEVAL STACK POINTER
/	RETURN IF NOT FOUND	NA
/	GOOD RETURN		ME
/	(POINTER IN AC)		XX

*2200
DS0,	0
	SNA CLA			/SKIP IF ONE WORD SEARCH
	CLL CML RTL		/THREE WORD COMPARE
	CMA
	DCA	DSWDNR		/MINUS NUMBER OF WORDS TO COMPARE
	TAD I	DS0		/PICK UP POINTER TO RETRIEVAL INFORMATION
	DCA	DSRETS
	ISZ	DS0
	TAD	DSM160		/SET UP COUNTER ON # ENTRIES CHECKED
	DCA	DSKCNT
	TAD I	DSRETS		/GET RETRIEVAL POINTER
	CIA
	TAD	RETTBL
	SNA CLA
	STA			/INHIBIT SEGMENT COUNTING OF THE MFD
	DCA	SEGLIM		/ZERO SEGMENT COUNTER
DS2,	DCA	DS1
	TAD I	DSRETS		/GET PTR TO RETRIEVAL INFORMATION BLOCK
	JMS I	GE01		/GET THE ENTRY INTO CORE
DS1,	0			/WORD NUMBER -- I.E. THE ADDR WITHIN THE DIRECTORY
	SNA
	JMP	BADDIR		/FOULED-UP DIRECTORY!
	DCA	DSENTP		/STORE POINTER TO ENTRY
	TAD	C0005
	TAD	DSENTP
	DCA	DSCNTR		/POINTS TO SEGMENT COUNT
	TAD	SEGLIM		/THE TOTAL FOR THIS UFD
	SPA			/IS IT A UFD?
	JMP	DS4		/NO; SEE IF WE SHOULD RESET THE MFD
	TAD I	DSCNTR		/ADD THIS FILE'S COUNT
	DCA	SEGLIM		/SAVE NEW TOTAL
DS3,	TAD	DSWDNR		/NUMBER OF WORDS TO COMPARE
	DCA	DSCNTR
	TAD	DSRETS
	DCA	DSOBJT		/POINTER TO OBJECT NAME
	TAD	DSENTP
	DCA	DSENT		/POINTER TO NAME IN BUFFER
DSCOM2,	TAD I	DSENT
	ISZ	DSENT
	CIA
	ISZ	DSOBJT
	TAD I	DSOBJT
	SZA CLA
	JMP	DSCOM1		/NOT FOUND
	ISZ	DSCNTR
	JMP	DSCOM2		/LOOK AT NEXT WORD OF NAME
	ISZ	DS0		/FOUND THE ENTRY
	TAD	DSENTP		/PICK UP POINTER
	JMP I	DS0		/RETURN
/THIS ENTRY IS NOT THE ONE WE'RE LOOKING FOR, SO WE MUST
/GO LOOK AT THE NEXT ONE.  IN THIS ENTRY IS A RELATIVE PTR TO THE NEXT ONE
/GET IT.
DSCOM1,	ISZ	DSKCNT		/BAD DIRECTORY?
	JMP	DSCOM3		/IT ISN'T BAD AT THIS POINT
BADDIR,	DCA	RESFLG		/CLEAR AC AND RESET FLAG
	TAD	P5400		/YES, INDICATE BAD DIRECTORY AND GET OUT
	DCA	FIUSAC		/ONCE AGAIN, GOODNESS TRIUMPHS OVER EVIL
	JMP	RETURN		/GO CLEAN UP BEFORE ABORTING
DSCOM3,	TAD	P0003		/CREATE POINTER TO NEXT ENTRY
	TAD	DSENTP
	DCA	DSCNTR
	TAD I	DSCNTR
	SZA			/IS THIS THE END OF THE DIRECTORY CHAIN?
	JMP	DS2		/NO, SO CONTINUE SEARCH
	TAD	P0003
	TAD	DS1
	JMP I	DS0
DS4,	TAD	RESFLG		/SHOULD WE RESET?
	SZA CLA
	JMP	DS3		/NO
	DCA I	DSCNTR		/CLEAR CPU TIME ACCUMULATOR
	ISZ	DSCNTR
	DCA I	DSCNTR		/CLEAR DEVICE TIME ACCUMULATOR
	DCA	BUFMOD		/REMEMBER TO WRITE IT BACK
	JMP	DS3
DSWDNR,	0
ENRETP,
DSRETS,	0
ENADDR,
DSENTP,	0
DSOBJT,	0
DSENT,	0
DSM160,	-161			/-MAXIMUM # FILES USER CAN OWN (+2)
/RETURN A BLOCK OF FREE CORE
RESFLG,
RETBKS,	0
	CFLD
	CIF
	RETBLK
	JMP I	RETBKS
/RETURN A LINKED LIST OF FREE BLOCKS
ENTPTR,
DSKCNT,
RETBLS,	0
	SNA
	JMP I	RETBLS
	JMS	RETBKS
	JMP	.-3

/SEARCH ENTTBL FOR OPENINGS TO FILE
/CALLING SEQUENCE:
/	TAD (RETRIEVAL POINTER)
/	JMS ENS0
/	UFD ADDRESS OF DIRECTORY ENTRY
/	RETURN - FOUND AN ACCESS
/	RETURN - FOUND NO ACCESS

DSCNTR,
ENS0,	0
	JMS I	ENS30
	DCA	ENRETP		/RELATIVE POINTER
	TAD I	ENS0		/GET FILE DIRECTORY ADDRESS
	CIA
	DCA	ENADDR
	ISZ	ENS0		/SKIP PAST ARG
	TAD	ENTTBL
	DCA	ENTPTR
ENS2,	TAD	ENRETP
	CMA
	TAD I	ENTPTR
	ISZ	ENTPTR
	SZA CLA
	JMP	ENS1		/DIFFERENT UFD ACCESS
	TAD I	ENTPTR		/SAME UFD, SAME FILE?
	TAD	ENADDR
	SZA CLA
	JMP	ENS1		/DIFFERENT FILE
	TAD	FIOSTK		/WHICH IOT BROUGHT US HERE?
	TAD	ENSCRF		/IF IT'S "CRF" ONE MATCH IS ENOUGH
	SNA CLA
	JMP I	ENS0		/IT WAS; GET OUT
	TAD	FIOSTK+1	/FOUND A SIMILAR ENTRY
	JMS I	EBLD0		/SEE IF WE FOUND THE ENTRY FOR
	CMA			/THE GUY WHO CAUSED THE CALL TO
	TAD	ENTPTR		/ENS0; IF IT IS, IGNORE THIS MATCH
	SZA CLA
	JMP I	ENS0		/FOUND A SIMILAR ENTRY; DIFFERENT ENTTBL ENTRY
ENS1,	ISZ	ENTPTR
	TAD	ENTPTR
	CIA
	TAD	ENTEND		/END OF ENT TABLE
	SZA CLA
	JMP	ENS2		/KEEP LOOKING
	ISZ	ENS0		/SKIP ON RETURN
	JMP I	ENS0
ENS30,	ENS3
ENSCRF,	-CRF

/ROUTINE TO LOOK IN THE SAT FOR A FREE SEGMENT

/CALLING SEQUENCE:
/	JMS SATLOK
/	RETURN (SEGMENT NUMBER IN AC, 0=NONE AVAILABLE)
*2400
SATLOK,	0
	CLA CMA CLL RAL		/7776
	DCA	SATMSK		/MAKE TWO PASSES OF THE TABLE
	TAD I	SATCNT		/# OF AVAILABLE DISC SEGMENTS
	SNA			/ARE THERE ANY?
	JMP I	SATLOK		/NO, SO FORGET IT
	CIA
	CMA
	DCA I	SATCNT		/DECREMENT SATCNT
	DCA	SATCT2
	CLA CMA
	DCA	SATSTA		/SET SAT STATUS TO WRITE OUT
/LOOK FOR A WORD IN SAT TABLE WITH A ZERO BIT IN IT
SAT1,	TAD I	SATPNT		/GET A WORD FROM SAT TABLE
	CMA
	SZA CLA			/ARE ALL BITS SET TO ONE?
	JMP	SAT2		/NO, SO WE'VE FOUND A SEGMENT
	ISZ	SATPNT		/WAS THIS THE LAST WORD IN THE SAT TABLE?
	JMP	SAT1		/NO, SO KEEP LOOKING
	TAD	SAT5		/START LOOKING FROM THE BEGINNING
	DCA	SATPNT		/PTR INTO SAT TABLE
	ISZ	SATMSK
	JMP	SAT1		/MAKE 1 MORE PASS
	DCA I	SATCNT		/SOMETHING WRONG.. BETTER AVOID L2Q OVERFLOW
				/BY SAYING NO SEGMENTS AVAILABLE
	JMP I	SATLOK
SAT5,	-SATSIZ+2

/WE FOUND A SAT WORD WITH A ZERO BIT. NOW FIND THAT BIT.
SAT2,	CLL CML RAR		/4000 INTO ACC.
	DCA	SATMSK
	ISZ	SATCT2
	TAD I	SATPNT		/GET WORD FROM SAT TABLE
	AND	SATMSK		/IS THE BIT CORRESPONDING TO THE ONE IN SATMSK SET?
	SNA
	JMP	SAT3		/NO, SO WE FOUND THE ZERO BIT
	RAR			/MOVE MASK BIT ONE TO THE RIGHT
	JMP	SAT2+1		/...AND LOOK AT THE NEXT BIT


/FOUND THE BIT WITHIN THE WORD - SATCNT INDICATES WHICH ONE IT IS
SAT3,	TAD	SATMSK
	TAD I	SATPNT
	DCA I	SATPNT		/SET THE BIT IN SATTBL TO INDICATE THAT THIS SEGMENT IS NOW ALLOCATED
	TAD	SATPNT
	TAD	C0526
	DCA	SATMSK
/NOW CALCULATE THE NUMBER OF THE DISC SEGMENT
/WHICH CORRESPONDS TO THIS BIT IN THE SAT TABLE
	TAD	SATMSK
	CLL RAL
	TAD	SATMSK
	RTL
	TAD	SATCT2
	JMP I	SATLOK		/EXIT WITH DISC SEGMENT NUMBER IN AC


SATPNT,	-SATSIZ+2
SATCNT,	-SATSIZ+1
SATEMP,
SATCT2,	0
SATMSK,	0

/ROUTINE TO RELEASE A SEGMENT IN SAT

/CALLING SEQUENCE:
/	TAD (SEGMENT NUMBER)
/	JMS SATREL

/DIVIDE SEGMENT NUMBER BY 14 (12 DECIMAL)
/QUOTIENT INDICATES WHICH WORD IN SAT TABLE CORRESPONDS
/TO THIS DISC SEGMENT. REMAINDER INDICATES WHICH BIT IN
/THAT WORD.
SATREL,	0
	TAD	P2000		/SUBTRACT 14 X 400
	SZL			/WAS THE SEGMENT THAT BIG?
	JMP	.+3		/YES
	TAD	P6000		/NO, ADD 14 X 400
	CLL			/UN-DO THE LINK
	RAL			/SHIFT OUT A BIT OF THE QUOTIENT
	ISZ	CFH
	JMP	SATREL+1	/MORE TO DO YET
	DCA	SATPNT		/REMAINDER IN LINK THRU AC2; QUOTIENT IN AC3 THRU AC11
	TAD	SATPNT
	AND	P7000
	RTL
	RTL
	CMA			/NEGATE THE REMAINDER
	DCA	SATEMP
	TAD	SATPNT
	AND	P0777		/JUST THE QUOTIENT THIS TIME
	TAD	SAT5
	DCA	SATPNT
	CLL CMA
	RAR
	ISZ	SATEMP		/SET UP A MASK CORRESPONDING TO PROPER BIT
	JMP	.-2
	AND I	SATPNT		/CLEAR SAT TABLE BIT; SEGMENT IS NOW AVAILABLE
	DCA I	SATPNT
	ISZ I	SATCNT		/UPDATE THE AVAILABLE SEGMENTS COUNT
	CLL STA
	DCA	SATSTA		/REMEMBER WE CHANGED THE SAT TABLE
	JMP I	SATREL

/ACTUAL I/O ROUTINE
/SET UP ALL I/O PARAMETERS IN #FLPARB#, AND JMS FIPIO

FIPIO,	0
	TAD	FIPFLD
	RAR
	DCA	FLPARB+2	/='S FIELD WE'RE IN TIMES 4
	CDF
	TAD I	JOB
	AND	C0400		/FIP OR SI CORTBL BIT ON?
	SNA CLA
	JMP	.+3		/SI
	TAD	FIJOB
	DCA I	FIPJOB		/FIP - KEEP HIGH PRIORITY ON THE SCHEDULER
	TAD	FIRETP		/POINTER TO FIORET
	DCA	1		/RETURN ADDRESS - SET TO RETURN BELOW WHEN FIP IS RESTARTED
	TAD	FIO3		/GET FIPBLK
	DATFLD
	DCA I	FIUTBA
	CFLD
	CIF 00
	BLT			/MOVE DISC TRANSFER PARAMETERS INTO FREE BLOCK LINKED TO DSUTBL
	CFLD			/FIP ALWAYS IN FIELD 2
	FLPARB			/PARAMETER BLOCK
	DATFLD			/DESTINATION FIELD
FIO3,	FIPBLK			/DESTINATION
	-10			/WORD COUNT
	CDF CIF 00
	ISZ I	DSBUSY		/GLOBAL TO "DSBUSY"
	WAIT			/DISK BUSY
	JMP I	OVER		/GO TO FIELD 0 TO INITIATE THE TRANSFER

/MONITOR RETURNS CONTROL HERE AFTER COMPLETING THE TRANSFER
FIORET,	CLA			/RETURNS FROM DISC I/O COME HERE
	TAD	C0200		/RESET THE FIP STARTING ADDRESS
	DCA	1		/... TO 0200
	FGETJT
	JOBSTS
	DATFLD
	DCA	FIPTR1
	TAD I	FIPTR1		/PICK UP #JOBSTS#
	CFLD			/CHANGE TO CURRENT FIELD
	TAD	P0003
	AND	P0007		/CHECK ERROR BITS
	SZA CLA
	ISZ	FIPIO		/NO DISC TRANSFER ERROR
	JMP I	FIPIO		/EXIT WITHOUT SKIPPING TO INDICATE DISC TRANSFER ERROR

FIPTR1,	0
FIUTBA,	DSUTBL+4+4
FIRETP,	FIORET
C0526,	0526
OVER,	OVRLA1

/ROUTINE TO GET A DIRECTORY WORD INTO CORE
/CALLING SEQUENCE:
/	TAD (POINTER TO RETRIEVAL INFORMATION)
/	JMS GE0
/	WORD NUMBER
/	RETURN (BUFFER POINTER IN AC. 0 IF NON-EXISTENT)

*2600

GE0,	0
	DCA	GERETP		/STORE RETRIEVAL INFORMATION POINTER
	TAD I	GE0
	CLL RAL
	RTL
	RTL
	AND	P0007
	TAD	GERETP
	DCA	GERETP
	TAD I	GERETP
	SNA
	JMP	GE3
	CIA
	CMA
	DCA	RDTEMP
/FILE READ ROUTINE, CHECKS TO SEE IF BUFFER IS FULL.
/IF SO, IS IT THE SEGMENT WE ARE TRYING TO READ?
/IF YES, LEAVE. IF NO, WRITE OUT THE BUFFER
/BEFORE READING THE PROPER SEGMENT.
	TAD	RDCURR		/MAY THE DESIRED SEGMENT ALREADY BE IN THE BUFFER
	CIA
	TAD	RDTEMP
	SNA CLA
	TAD	BUFSTA		/PROBABLY; IS THE DATA STILL VALID?
	SPA
	JMP	RD3		/YES
	SNA			/MAYBE
	JMS I	WRT1		/WRONG SEGMENT, SO WRITE IT OUT (IF MODIFIED)
	DCA	BUFSTA		/SAVE BUFFER STATUS
	TAD	RDTEMP
	JMS	RD30		/SET UP PARAMETERS FOR A READ OPERATION
	TAD	BUFSTA		/WAS THE CORRECT DATA IN THE BUFFER AFTER ALL?
	SZA CLA
	JMP	RD3		/YES; ONLY NEEDED TO SET THE DISK PARAMETERS
	JMS I	FIO01		/PERFORM THE READ
	JMP I	DIRBAD		/ERROR ON READ
	IAC
	DCA	BUFMOD		/NEW DATA AS YET UNCHANGED
RD3,	CLA CMA
	DCA	BUFSTA		/SET BUFFER STATUS TO FULL
	TAD	C0377
	AND I	GE0		/ADDRESS WITHIN SEGMENT
	TAD	BUFFER		/CREATE A POINTER
GE3,	ISZ	GE0
	JMP I	GE0		/RETURN

GERETP,	0
RDTEMP,	0
RDCURR,	0
K7400,	7400
C0377,	0377



/ROUTINE TO DIVIDE A NUMBER BY 7
/REMAINDER IS LEFT IN WNDREM, PAGE 0

WND20,	0
	DCA	WNDREM
	DCA	CFH
	TAD	WNDREM
WND24,	TAD	C7771
	SPA
	JMP	WND21
	ISZ	CFH
	JMP	WND24
WND21,	TAD	P0007
	DCA	WNDREM
	TAD	CFH
	JMP I	WND20


/ROUTINE TO SET UP FOR A READ.
/ENTER WITH SEGMENT NUMBER. THIS IS CONVERTED TO
/A PHYSICAL DISC ADDRESS.
RD30,	0
	DCA	RDCURR		/SAVE SEGMENT NUMBER
	TAD	RDCURR
	CLL RTR
	RTR
	DCA	RDTEMP
	TAD	RDTEMP
	RAR
	AND	K7400
	DCA	FLPARB+5
	TAD	RDTEMP
	AND	C0377
	TAD	FIBASE
	CLL RTL
	DCA	FLPARB+1
	CFLD			/CHANGE TO CURRENT FIELD
	TAD	K7400
	DCA	FLPARB+3	/WORD COUNT (ONE BUFFER)
	CLA CMA
	TAD	BUFFER
	DCA	FLPARB+4	/CORE ADDRESS
	TAD	C0603		/READ IOT
	DCA	FLPARB
	JMP I	RD30

FIPFIP=	C0400


FIX301,	FIX30
C5600,	5600
USENAM,	0			/CALLED ONLY ONCE BY RE-NAME ROUTINE
	TAD	FIOSTK+1	/TO SEE IF THE NEW NAME EXISTS IN DIRECTORY
	DCA	FIOSTK
	JMS I	JBLD0
	JMS I	UTS01
	JMP I	DIRBAD
	JMS I	BLDP1
	DCA	FIOSTK+1
	JMS I	DS01
	FIOSTK+1
	ISZ	USENAM		/NO FILE OF THIS NAME FOUND - OK TO RENAME
	CLA
	JMP I	USENAM

NUCOR,	CORSRC-2
C7437,	SWAP LOCK NOTRUN FIP CJOB
JOBMX,	-JOBMAX
FIPLOC,	FIPLOK
FIPTIM,	TIMFIP

REL1,	TAD	FIOSTK+1	/RELEASE A DEVICE
	SPA			/DON'T LET THE USER RELEASE CONSOLES
	JMS I	REL01
	CLA
	JMP I	FIEXIT


FIX50,	TAD I	FIOPTR
	AND	FIPFIP		/GLOBAL TO "FIP"
	SNA CLA			/IF FIP BIT IS NOT SET, FIP WAS CALLED BY SI
	JMP I	FIX301		/GET THE SYSTEM INTERPRETER BACK INTO CORE
	TAD	C5600
	AND I	FIOPTR
	DCA I	FIOPTR		/CLEAR OUT THE LOCK BIT
	TAD	JOBMX
	DCA	CFH		/SAVE COUNT OF JOBS TO SCAN
	STL RTL
	TAD I	NUCOR
	SMA
	JMP	FIX51
	DCA I	FIPTIM
	TAD	C7437
	DCA I	FIPLOC
FIX51,	CLA
	DATFLD
	TAD	FIJOB
	TAD	DEVOVR
	DCA	INDEX

FIX50L,	TAD	INDEX
	TAD	JEND
	SZA CLA
	JMP	.+3
	TAD	DEVOVR
	DCA	INDEX
	TAD I	INDEX
	SZA
	JMS I	FIX5CK
	ISZ	CFH
	JMP	FIX50L
	JMP I	.+1
	FIXOUT
JEND,	-JOBTBL-JOBMAX
FIX5CK,	FIXSCH
/ROUTINE TO FREE AN ENTRY ON THE UFD TABLE AND RETTBL

/CALLING SEQUENCE:
/	TAD (POSITION ON UFDTBL)
/	JMS TF0
/	RETURN


TF0,	0
	DCA	TFUFDP		/POSITION ON TABLE
	DCA I	TFUFDP		/CLEAR OWNER'S PROJ,PROG NUMBER
	TAD	UFDTBL		/BEGINNING OF TABLE
	CIA
	TAD	TFUFDP
	CLL RTR			/RELATIVE POSITION ON TABLE
	IAC
	JMS I	BLDP1		/BUILD A PTR TO RETTBL
	DCA	TFUFDP		/POINTER TO RETRIEVAL INFORMATION
	TAD	P7770		/8 WORDS PER ENTRY
	DCA	TFCNTR
TF1,	DCA I	TFUFDP		/ZERO OUT THE ENTRY
	ISZ	TFUFDP
	ISZ	TFCNTR
	JMP	TF1
	JMP I	TF0

TFUFDP,	0
TFCNTR,	0


/ROUTINE TO CHECK WHETHER THE FILE A USER
/IS ATTEMPTING TO ACCESS IS HIS/HERS OR SOMEONE ELSE'S.

/CALLING SEQUENCE:
/	TAD (INTERNAL FILE NUMBER)
/	JMS UC0
/	ERROR RETURN (AC=0 IF FILE NOT OPEN)
/	NORMAL RETURN

UC0,	0
	JMS I	EBLD0
	DCA	UCENTP
	TAD I	UCENTP		/PICK UP ENTRY FOR THIS FILE OF THIS USER'S
	SNA
	JMP I	UC0		/FILE NOT OPEN
	CIA
	CLL CMA RTL		/SUBTRACT ONE; MULTIPLY BY FOUR
	TAD	UFDTBL
	DCA	UCUFDP		/POINTER TO OPEN UFD TABLE
	JMS I	JBLD0
	CIA
	TAD I	UCUFDP
	SNA			/SKIP IF DIFFERENT
	ISZ	UC0		/CORRECT RETURN
	JMP I	UC0

UCENTP,	0
UCUFDP,	0

/LOGOUT ROUTINE

LGO0,	JMS I	ACC01		/IS IT FROM ACCOUNT 1?
	TAD	FIOSTK+1	/YES; SEE IF HE WANTS TO RESET
	TAD	FIJOB		/SEE IF HIS/HER AC=JOB
	SNA CLA
	JMP I	LGRESA		/GO CLEAR EVERYBODY'S CPU & DEVICE TIME ACCUMULATORS
	TAD	FIOSTK+1	/DID HE SET HIS/HER AC= TO HIS/HER JOB #?
	CIA
	TAD	FIJOB
	SZA CLA
	JMP I	LGO1A		/NO; SO SEE IF HE WANTS COUNT OF USERS UNDER HIS/HER ACCOUNT
	JMS I	LNS01		/RELEASE ALL HIS/HER DEVICES
	JMP	.+3
	JMS I	REL01
	JMP	.-3		/KEEP GOING
	JMS I	CL01		/CLOSE FILE 0
	IAC
	JMS I	CL01		/CLOSE FILE 1
	CLL CML RTL
	JMS I	CL01		/CLOSE FILE 2
	TAD	P0003
	JMS I	CL01		/CLOSE FILE 3
	JMS I	JBLD0
	DCA	LOSRRI+1	/DELIVER TO CALLING SEQUENCE FOR SEARCH
	TAD	CFH
	DCA	LOJOBP
	CLA CMA
	JMS I	DS01		/FIND MFD ENTRY; 1 WORD SEARCH
	LOSRRI
	JMP I	DIRBAD		/************DEBUG ONLY***********
	TAD	C0006
	DCA	LOSRRI+1	/POINTER TO CP TIME COUNTER
	FGETJT
	JOBRTM			/JOB RUN TIME IN STATUS
	DCA	FIOSTK+6	/INTS TO LOW ORDER RUN TIME
	DATFLD
	TAD I	FIOSTK+6
	RTR
	RTR
	RTR			/USE ONLY HIGH ORDER OF LOW ORDER RUN TIME
	AND	P0077
	DCA	FIOSTK+7
	ISZ	FIOSTK+6
	TAD I	FIOSTK+6
	CFLD			/BACK TO THIS FIELD
	AND	P0077
	CLL RTL
	RTL
	RTL
	TAD	FIOSTK+7
	TAD I	LOSRRI+1
	DCA I	LOSRRI+1	/LOW ORDER TIME UPDATE
	DCA	BUFMOD		/SCHEDULE WRITE
	TAD I	LOJOBP		/PICK UP PROJ,PROG NUMBER
	JMS I	UTS01		/SEARCH UFD TABLE
	JMP	LGO2		/OOPS!! MIGHT AS WELL TRY TO LEAVE GRACEFULLY
	ISZ I	UTPRNU		/REMOVE THIS JOB FROM ACCESS COUNT
	JMP	LGO2
	CLA CMA			/LAST USER ACCESSING THIS UFD
	TAD	UTPRNU
	JMS I	TF01		/FREE THE UFD TABLE ENTRY
LGO2,	CLA
	DCA I	LOJOBP		/REMOVE USER FROM JOB TABLE
	TAD	LGO4A		/KLUDGE FIEXIT TO RETURN TO LGO4
	DCA I	LGKLUJ
TABOUT,	CLA CMA
	DCA	TABSTA		/FORCE TABLES OUT
	JMP I	FIEXIT
LOJOBP,	0

LOSRRI,	RTABLE
	0
LGO4A,	LGO4
LGO1A,	LGO1
LGKLUJ,	FIX500
LGRESA,	LGRES0

/ROUTINE TO OPEN A UFD

/CALLING SEQUENCE:
/	TAD (PROJ,PROG NUMBER)
/	JMS UFO0
/	ERROR RETURN (AC=0 IF TABLES FULL; OTHERWISE UFD NOT FOUND)
/	NORMAL RETURN (POSITION ON TABLE IN AC)

*3200

UFO0,	0
	JMS	UFO6		/GO GET THE RETR. INFO FOR THIS GUY'S UFD INTO CORE
	JMP I	UFO0		/COULDN'T GET IT
	DCA	UOBUFP		/POINTER TO RETRIEVAL INFORMATION
	TAD	UFDTBL
	IAC
	DCA	UOUFDP		/UFD TABLE POINTER
/SEARCH FOR A FREE SLOT IN UFDTBL
UFO3,	TAD I	UOUFDP
	SNA CLA
	JMP	UFO2		/FOUND A FREE SLOT ON THE TABLE
	TAD	UOUFDP		/THIS SLOT IS OCCUPIED
	TAD	P0004
	DCA	UOUFDP		/NEXT POSITION (ACCES COUNT ENTRY)
	TAD	UFDEND		/ARE WE AT THE END OF THE TABLE
	CMA
	TAD	UOUFDP
	SNA CLA			/HAVE WE SEARCHED THE WHOLE TABLE?
	JMP I	UFO0		/NO ROOM ON TABLE
	JMP	UFO3		/LOOK AT NEXT SLOT

/COMES HERE WITH UOUFDP POINTING TO A FREE SLOT IN UFDTBL
UFO2,	CLL STA RAL		/AC=-2
	TAD	UOUFDP		/BACK UP THE POINTER
	DCA	INDEX
	TAD	UFORET+1
	JMS I	UFQUOA		/LOAD THE UFD TABLE
	STA
	TAD	UFDTBL
	CIA
	TAD	INDEX
	CLL RTR
	DCA	UFO6		/RELATIVE POSITION ON TABLE
	TAD	UFO6
	JMS I	BLDP1		/GENERATE A PTR INTO RETTBL
	DCA	UFORET		/RETRIEVAL POINTER
	TAD	C7771
	DCA	CFH		/COUNTER FOR TRANSFER TO TABLE

/NOW MOVE RETRIEVAL INFORMATION FOR THIS GUY'S
/UFD INTO RETTBL
UFO4,	ISZ	UOBUFP
	TAD I	UOBUFP
	DCA I	UFORET
	ISZ	UFORET
	ISZ	CFH		/ENTIRE RETRIEVAL BLOCK TRANSFERRED?
	JMP	UFO4		/NO, KEEP IT UP
	ISZ	UFO0		/YES, PREPARE FOR NORMAL RETURN
	TAD	UFO6		/PICK UP RELATIVE POSITION
	JMP I	UFO0

UFORET,	0
	0
UFQUOA,	UFQUOT
UOUFDP=	UTPRNU
UOBUFP,	0


UFO6,	0
	DCA	UFORET+1	/SET UP CALLING SEQUENCE FOR MFD SEARCH
	TAD	RETTBL
	DCA	UFORET
	CMA
	JMS I	DS01		/ONE WORD MASTER FILE DIRECTORY SEARCH FOR PROJ,PROG MATCH
	UFORET
	JMP I	UFO6		/COULD NOT FIND UFD ENTRY
	TAD	P0004		/POINT AT DISK QUOTA WORD
	DCA	UFORET
	TAD I	UFORET
	AND	P0077		/SAVE ONLY LOGIN QUOTA
	DCA	SEGLIM		/SAVE FOR LATER
	TAD	P0003
	TAD	UFORET
	DCA	UFORET		/POINTER TO UFD RETRIEVAL INFORMATION
	TAD I	UFORET
	DCA	UFO1
	TAD	RETTBL		/POINTER TO RET. INFO OF FILE BEING SEARCHED (IN THIS CASE, THE MFD)
	JMS I	GE01		/GET RETRIEVAL INFORMATION INTO CORE
UFO1,	0
	ISZ	UFO6
	JMP I	UFO6

/ROUTINE TO SEARCH UFD TABLE FOR PROJ,PROG NUMBER

/CALLING SEQUENCE:
/	TAD (PROJ,PROG NUMBER)
/	JMS UTS0
/	NOT FOUND RETURN
/	NORMAL RETURN (RETRIEVAL POSITION IN AC)

UTS0,	0
	DCA	UTPR1		/PROJ,PROG NUMBER
	TAD	UFDTBL		/PTR TO HEAD OF UFDTBL
	DCA	UTUPTR
UTS1,	TAD	UFDEND		/END OF UFD TABLE
	CIA
	TAD	UTUPTR
	SNA CLA
	JMP I	UTS0		/COULD NOT FIND PROJ,PROG NUMBER ON TABLE
	TAD I	UTUPTR
	CIA
	TAD	UTPR1
	SNA CLA
	JMP	UTS3		/FOUND ENTRY, GET POINTER
	TAD	UTUPTR		/STEP UP ONE SLOT
	TAD	P0004
	DCA	UTUPTR
	JMP	UTS1		/LOOK IN THE NEXT ENTRY
UTS3,	TAD	UFDTBL
	CIA
	TAD	UTUPTR
	CLL RTR			/RELATIVE POSITION ON TABLE
	IAC			/THE RELATIVE POSITION
	ISZ	UTPRNU		/UTPRNU POINTS TO ACCESS COUNT OF THIS PROJ, PROG #
	ISZ	UTS0
	JMP I	UTS0

DVT1,
UTPR1,	0
UTUPTR=	UTPRNU

DVT0,	0			/COMPUTE DEVICE TIME AT RELEASE
	DCA	DVT1		/ELAPSED DEVICE TIME
	JMS I	JBLD0
	DCA	DVT3		/PROJ,PROG NUMBER OF CURRENT USER
	CLA CMA
	JMS I	DS01		/SEARCH MFD FOR PROJ,PROG NUMBER
	DVT4
	JMP I	DIRBAD		/***********DEBUG ONLY***********
	TAD	C0005
	DCA	CFH		/POINTER TO DEVICE TIME WORD
	TAD	DVT1
	TAD I	CFH		/UPDATE USER'S CUMULATIVE DEVICE TIME
	DCA I	CFH
	DCA	BUFMOD		/SCHEDULE WRITE
	DATFLD
	JMP I	DVT0

DVT4,	RTABLE
DVT3,	0



/COMES HERE IF FIP WAS CALLED BY S.I.
/READ S.I. BACK IN AND RETURN TO IT
FIX30,	CFLD			/CHANGE TO CURRENT FIELD
	TAD	C0603
	DCA	FLPARB		/SET UP READ IOT
	DCA	FLPARB+1	/SI IS ON TRACK 0 OF THE DISC
	JMS I	FIX401
	JMS I	FIO01		/RETURN WILL BE TO SI


SCL1,	0
	JMS I	RD301		/SET UP DISK PARAMETERS
	STA
	DCA	BUFSTA		/FUDGE TO APPEAR THAT READ WAS DONE
	JMP I	SCL1

RD301,	RD30

/EXIT ROUTINE
/COMES HERE WHEN FIP HAS COMPLETED ITS TASK
/FIRST, SEE IF ANY INTERNAL FILES HAVE BEEN CHANGED
/THOSE THAT HAVE CHANGED MUST BE WRITTEN BACK OUT TO DISC
*3400
/*** ANY DATA FIELD IS OK AT THIS POINT!!

FIX0,	JMS I	WRT1		/MAKE SURE THE BUFFER IS EMPTY
	ISZ	TABSTA		/CHECK TABLE STATUS
	JMP	FIX1		/NOTHING CHANGED IN TABLES
	TAD	JOBTAB		/BOTTOM OF TABLE AREA
	JMP	FIX2		/SAVE TABLES BEFORE EXIT

FIX1,	ISZ	SATSTA		/CHECK SAT STATUS
	JMP	FIX20		/NOTHING TO BE SAVED, EXIT
	TAD	SATBOT		/BOTTOM OF SAT
FIX2,	JMS I	FIX401
	TAD	FIDEXP		/GLOBAL TI "FIPDEX"
	DCA	FLPARB+1	/MEMORY FIELD
	TAD	C0605
	DCA	FLPARB		/WRITE IOT
	JMS I	FIO01		/PERFORM THE WRITE
	HLT			/ERROR ON WRITE, FATAL

/ALL DISC TABLES ARE NOW UP TO DATE (*** ANY DATA FIELD IS OK AT THIS POINT!!)
FIX20,	FGETJT
	JOBSTS
	DCA	FIOPTR
	DATFLD
	TAD I	FIOPTR
	AND	FISIOT
	DCA I	FIOPTR
	CFLD
	FGETJT			/RESTORE USER AC
	JOBREG+2
	DCA	FIOPTR		/ADDRESS OF USER'S AC
	TAD	FIUSAC
	DATFLD
	DCA I	FIOPTR
	CDF
	TAD	C002		/FIP ALWAYS RUNS IN FIELD 2 SO ADD 2 TO CORTBL
	TAD	CORTBA		/GLOBAL TO "CORTBL"
	DCA	FIOPTR		/POINTS TO THIS FIELD'S ENTRY IN CORTBL
	JMP I	.+1
FIX500,	FIX50

FISIOT,	-JSIOT-1

/ROUTINE TO DETERMINE IF A DEVICE IS ASSIGNED TO THIS JOB

/CALLING SEQUENCE:
/	TAD (DEVICE NUMBER)
/	JMS DTE0
/	0	(SET BY DTE0 TO POINT TO ENTRY IN DEVTBL)
/	RETURN (DEVICE NOT ASSIGNED TO THIS JOB)
/	RETURN (DEVICE ASSIGNED)

DTE0,	0
	SPA
	JMP	DTE10		/NON-TTY DEVICE
	TAD	NULNM1		/CHECK FOR VALID TTY NUMBER
	SMA
	JMP	DTE6		/INVALID TTY NUMBER
	CLL RAL			/TWO WORDS PER TTY
DTE4,	TAD	DEVEND		/FIND LOCATION IN DEVTBL
DTE5,	CFLD
	DCA I	DTE0		/RETURN ARGUMENT
	TAD I	DTE0
	ISZ	DTE0
	DCA	DTE2
	DATFLD
	TAD I	DTE2		/GET POINTER TO DDB
	SNA			/IS THERE ONE?
	JMP I	DTE0		/NO, RETURN
	DCA	DTE2		/YES
	ISZ	DTE2
	TAD I	DTE2		/GET JOB NUMBER
	CIA
	TAD	FIJOB		/NUMBER OF CURRENT JOB
	AND	P0037
	SNA CLA			/DOES DEVICE BELONG TO THIS JOB?
	ISZ	DTE0		/YES
	JMP I	DTE0		/RETURN
DTE6,	STA
	TAD	DEVTBA		/POINT TO DUMMY DEVTBL ENTRY
	JMP	DTE5


DTE2,	0
NULNM1,	-NULINE-1
P3777,	3777
NUDEVM,	DEVTBE-JOBTBL
NUDEV,	JOBTBL-DEVTBE

DTE10,	AND	P3777
	TAD	NUDEVM		/CHECK DEVICE NUMBER FOR VALIDITY
	SMA
	JMP	DTE6		/INVALID DEVICE NUMBER
	TAD	NUDEV		/GET DEVICE NUMBER BACK
	JMP	DTE4		/GO FINISH UP

LNK0,	0			/GET FILE LINKAGE
	TAD	LNKF
	DCA	LNK1
	FGETJT
LNK1,	0
	DCA	CFH
	DATFLD
	TAD I	CFH		/PTR TO FILE CONTROL BLOCK
	JMP I	LNK0
LNKF,	JOBF0
SAV1,
FGETJ0,	0
	CFLD
	TAD I	FGETJ0
	DCA	.+4
	TAD	JOBDAT
	CIF
	GETJTA
	0
	ISZ	FGETJ0
	JMP I	FGETJ0
SAVCRE,	0
	DCA	SAV1
	TAD	SAV1		/FILE ADDR
	TAD	P0004		/PTR TO PROTECTION BITS IN FILE
	DCA	SAV2
	TAD I	SAV2		/GET THE PROTECTION BITS
	AND	C0020		/IS IT WRITE PROTECTED AGAINST THE OWNER?
	SZA CLA
	JMP I	EXT10A		/YES, RETURN WITH PROT. VIOLATION MESSAGE
	TAD	SAV1		/NO, REDUCE THE FILE TO 0 SEGS
	JMS I	RED11		/GO DO REDUCTION
	JMP I	SAVCRE		/RETURN
RED11,	RED1
EXT10A,	EXT10
SAV2,
CRFUFD,	0
	JMS I	ACC01		/IS THIS ACCOUNT 1?
	JMP	CRFUF1		/YES
	IAC
	DCA I	INDEX		/FILE SIZE INITIALLY 1
	JMP I	CRFUFD		/BACK FOR THE DATE
CRFUF1,	DCA I	INDEX		/ZERO CPU TIME
	JMP I	.+1		/GO ZERO DEVICE TIME ALSO
	CRFUFR
/CONVERT AN ABSOLUTE PTR INTO RETTBL TO A RELATIVE ENTRY NUMBER
ENS3,	0
	CIA
	TAD	RETTBL		/REL. PTR TO ADDRESS WITHIN RETTBL
	CIA
	AND	P7770		/ANY POINTER WITHIN THE BLOCK IS OK
	CLL RTR
	RAR			/DIVIDE BY 8
	JMP I	ENS3

/ROUTINE TO ASSIGN A DEVICE

*3600
ASD1,	TAD	FIOSTK+1
	SMA			/TTY?
	JMP I	LGI201		/DON'T LET HIM/HER ASSIGN TTY'S! RETURN WITH AC=7777
	JMS I	DTE01		/IS THIS DEVICE ASSIGNED TO THIS JOB?
ASD2,	0			/SET BY DTE01 TO POINT TO PROPER ENTRY IN DEVTBL
	SKP
	JMP	ASD4		/YES
	TAD I	ASD2		/GET DDB ADDRESS FOR THIS DEVICE
	SZA			/ZERO?
	JMP	ASD11		/NO, SO SOMEONE HAS IT
/COMES HERE IF OKAY TO MAKE THIS ASSIGNMENT
	CFLD			/CHANGE TO CURRENT FIELD
	TAD	ASD2
	6202			/CIF FIELD 0
	GETDDB			/GET A BLOCK FROM THE FREE LIST AND LINK IT INTO DEVTBL
	JMP I	LGI201		/NO BLOCK.. REDO IN CASE OF USER OTHERWISE ERROR RETURN FOR SI
	DATFLD
	TAD I	ASD2			/PICK DDB ADDRESS FROM DEVTBL
	DCA	CFH		/SAVE IT
	TAD	FIOSTK+1
	AND	P0037		/CLEAR BIT 0
	DCA I	CFH		/SET TO REFLECT THE DEVICE NUMBER
	ISZ	CFH
	TAD	FIJOB
	DCA I	CFH		/PLUG IN THE JOB NUMBER
ASD7,	CFLD
	JMP I	FIEXIT

/COMES HERE IF ONE JOB ATTEMPTS TO ASSIGN AN ALREADY ASSIGNED DEVICE
ASD11,	IAC
	DCA	CFH
	TAD I	CFH
	SNA
	CMA
	DCA	FIUSAC		/DELIVER TO USER'S AC
	JMP	ASD7		/EXIT

ASD4,	TAD	FIOSTK+1
	CLL RAL
	SZA CLA			/PTR?
	JMP	ASD7		/NO
	TAD I	ASD2
	CIF 00
	JMS I	ASDCLR		/CLEAR THE READER BUFFER
	JMP	ASD7
ASDCLR,	SICLR

/ROUTINE TO PERFORM ACTUAL REDUCTION

/CALLING SEQUENCE:
/	TAD (NUMBER OF SEGMENTS TO REMAIN)
/	JMS RED30
/	RETRIEVAL CHAIN POINTER
/	UFD RETRIEVAL POINTER
/	RETURN


/FIRST TRACE THRU THE LINKED LIST OF FILE INFORMATION
/RETRIEVAL BBLOCKS UNTIL WE GET TO THE ONE IN WHICH THE
/NEW LAST SEGMENT IS
RED30,	0
	DCA	RED31		/LINKAGE TO RETRIEVAL CHAIN
	TAD	GDRETP		/PICK UP RETRIEVAL POINTER
	JMS I	GE01		/GET THIS WORD INTO CORE
RED31,	0
	DCA	REBUFF
	TAD I	REBUFF		/PICK UP LINK TO NEXT
	DCA	RED31		/SAVE LINK
	TAD	WNDREM		/DELETING ENTIRE WINDOW?
	SNA CLA
	JMP	RED36		/YES, REMOVE LINK TO LAST WINDOW AS WELL
RED37,	ISZ	REWNDC		/AT END OF CHAIN?
	JMP	RED30+2		/NO, KEEP SAVING
	DCA I	REBUFF		/YES, TERMINATE IT
/FOUND RETRIEVAL BLOCK IN WHICH TO CHOP OFF
/THE LIST OF SEGMENTS.
/START DELETING THE SEGMENT NUMBERS AND RETURNING
/THE ACTUAL DISC SEGMENTS TO THE POOL
	TAD	WNDREM
	IAC			/GET POINTER TO FIRST SEGMENT TO BE DELETED
	TAD	REBUFF
	DCA	REBUFF		/POINTER TO FIRST SEGMENT TO REMOVE
	DCA	SEGLIM		/CLEAR SEGMENT COUNTER
	TAD	WNDREM		/NUMBER OF SEGMENTS TO LEAVE IN RET. WINDOW
RED32,	TAD	C7771		/7 SEGMENTS PER RETRIEVAL WINDOW
	DCA	REWNDC		/SAVE COUNT
	DCA	BUFMOD		/REMEMBER TO WRITE OUT THE BUFFER
RED33,	TAD	REDM9
	DCA	CFH		/SET COUNT FOR SATREL DIVIDE
	STL STA
	TAD I	REBUFF		/PICK UP THE SEGMENT NUMBER
	SZL			/IS IT A REAL SEGMENT
	JMP	RED38		/NO; END OF WINDOW, END OF FILE
	JMS I	SATREA		/RELEASE IT ON SAT
	DCA I	REBUFF		/CLEAR THE CCELL
	ISZ	SEGLIM		/COUNT SEGMENT
	ISZ	REBUFF
	ISZ	REWNDC		/END OF CURRENT RETRIEVAL WINDOW?
	JMP	RED33		/NO, CONTINUE
	TAD	RED31		/YES, MOVE TO NEXT
	SNA			/END OF CHAIN?
	JMP	RED39		/YES, EXIT

RED34,	DCA	RED35		/NO
	TAD	GDRETP
	JMS I	GE01		/GET NEXT WINDOW
RED35,	0
	DCA	REBUFF
	TAD I	REBUFF
	DCA	RED31		/SET UP LINK TO NEXT
	DCA I	REBUFF		/CLEAR FIRST WORD OF WINDOW
	ISZ	REBUFF
	JMP	RED32		/KEEP WIPING OUT

RED36,	STL CLA RTL		/ARE WE TWO WINDOWS FROM THE END YET?
	TAD	REWNDC
	SZA CLA
	JMP	RED37		/NOT EXACTLY
	DCA I	REBUFF		/YES, CLEAR LINK TO NOW EMPTY WINDOW
	DCA	BUFMOD		/SCHEDULE WRITE
	JMP	RED37

RED38,	CLA
	DCA I	REBUFF		/CLEAR TO END OF WINDOW
	ISZ	REBUFF
	ISZ	REWNDC		/ARE WE THERE YET?
	JMP	RED38		/NO
RED39,	TAD	GDRETP		/GET RETRIEVAL POINTER
	JMS I	ENS32		/CONVERT IT INTO A RELATIVE ENTRY NUMBER
	STL RTL			/TIMES 4 PLUS 2
	IAC
	TAD	UFDTBL		/POINTS TO WORD3 OF UFDTBL ENTRY
	DCA	REBUFF
	TAD I	REBUFF		/HAS HIS/HER SEGMENT COUNT BEEN SET UP YET?
	SNA CLA
	JMP I	RED30		/NO; SO JUST EXIT
	TAD	SEGLIM		/NUMBER OF SEGMENTS WE REMOVED FROM THIS FILE
	CIA
	TAD I	REBUFF		/SUBTRACT FROM THOSE THAT WE KNEW ABOUT
	DCA I	REBUFF		/UPDATE UFDTBL ENTRY
	STA
	DCA	TABSTA		/REMEMBER TO WRITE OUT THE TABLES
	JMP I	RED30		/EXIT

ENS32,	ENS3
REDM9,	-11
SATREA,	SATREL
REBUFF,	0

*4000
/RENAME ROUTINE

REN0,	JMS I	ACC01		/IS IT ACCOUNT 1?
	JMP	PASSQU		/YES; GO CHANGE PASSWORD AND DISK QUOTA
	JMS I	IFN01
	TAD	FIOSTK+1	/PICK UP INTERNAL FILE NUMBER
	JMS I	UC01		/USER-OWNER CHECK
	JMP I	REN1A		/USER NOT OWNER, ERROR
	JMS I	FILNAM		/CHECK IF THIS NEW NAME IS IN DIRECTORY
	JMP I	BADNAM		/YES, DON'T RENAME
	TAD	FIOSTK		/PICK UP INTERNAL FILE NUMBER NOW SHIFTED TO FIOSTK
	JMS I	GD01		/GET THIS DIRECTORY ENTRY INTO CORE
	DCA	REENTP		/POINTER TO DIRECTORY ENTRY
	TAD	REENTP
	TAD	P0004
	DCA	REPRTP		/POINTER TO PROTECTION BITS
	TAD I	REPRTP		/PICK UP PROTECTION BITS
	AND	C0020		/WRITE PROTECTED AGAINST OWNER?
	SZA
	JMP I	REN1A		/YES, ERROR
	TAD	FIOSTK+2	/TRANSFER NEW NAME TO DIRECTORY
	SNA			/IS IT A NULL NAME?
	JMP I	BADNAM		/YES, DON'T RENAME
	DCA I	REENTP
	ISZ	REENTP
	TAD	FIOSTK+3
	DCA I	REENTP
	ISZ	REENTP
	TAD	FIOSTK+4
	DCA I	REENTP
	DCA	BUFMOD		/SCHEDULE WRITE
	JMP I	FIEXIT		/EXIT FROM FILE PHANTOM
REN1A,	REN1
FILNAM,	USENAM
BADNAM,	CRF30
SEGS0,	TAD I	SEGCNT
	DCA	FIUSAC
	JMP I	FIEXIT
SEGCNT,	-SATSIZ+1
SIFLD,	CORTBL+1

PASSQU,	CDF 00
	TAD I	SIFLD		/IS THIS REQUEST FROM SI?
	AND	C0200
	CFLD
	SZA
	JMP I	REN1A
	TAD	FIOSTK+1	/OR IS HE TRYING ACCOUNT 0?
	SNA
	JMP I	BADNAM		/YES; ERROR
	JMP I	.+1
	PASQU0

/BUILD A RETRIEVAL POINTER GIVEN RELATIVE POSITION ON RETTBL

/CALLING SEQUENCE:
/	TAD (RELATIVE POSITION)
/	JMS BLDP
/	RETURN (POINTER IN AC)

REENTP,
BLDP,	0
	DCA	CFH
	CLA CMA
	TAD	CFH
	CLL RAL
	RTL
	TAD	RETTBL
	JMP I	BLDP
/JMS I LINK01
/MISSING SEGMENT ADD
/REPLACEMENT

LINK0,	0
	DCA	LINK1
	TAD	GDRETP
	JMS I	GE01
LINK1,	0			/GET A DIRECTORY WORD INTO CORE
	TAD	P0003
	DCA	LINK2
	TAD I	LINK2
	CIA
	TAD I	LINK0
	SZA CLA			/SEARCH THROUGH UFD UNTIL WE FIND ENTRY BEING SOUGHT
	JMP	LINK3
	ISZ	LINK0
	TAD I	LINK0		/TAKE A BLOCK OUT OF THE CHAIN
	DCA I	LINK2
	DCA	BUFMOD		/SCHEDULE WRITE
	ISZ	LINK0
	JMP I	LINK0

REPRTP,
LINK2,	0

LINK3,	TAD I	LINK2
	JMP	LINK0+1

/ROUTINE TO SET UP A UFDTBL ENTRY AS FOLLOWS:
/WORD 0:	PROJECT, PROGRAMMER NUMBER
/WORD 1:	-ACCESS COUNT
/WORD 2:	-DISK SEGMENT QUOTA (LOGIN)
/WORD 3:	ACTUAL NUMBER OF SEGMENTS OWNED.
/(WORDS 1 AND 3 ARE INITIALLY SET TO 0.)
/WORD 3 IS LOADED BY "CREATE," OR BY "EXTEND" IF IT HAS NOT PREVIOUSLY
/BEEN LOADED. "CREATE" & "EXTEND" ALWAYS MODIFY WORD 3, "REDUCE" ONLY
/MODIFIES WORD 3 IF IT IS NON-ZERO.

UFQUOT,	0
	DCA I	INDEX		/SAVE PROJECT, PROGRAMMER NUMBER
	DCA I	INDEX		/ZERO ACCESSES SO FAR
	TAD	SEGLIM		/LOGGED IN QUOTA
	CLL RAL			/TIMES 2
	TAD	SEGLIM		/THREE
	RAL			/SIX
	RTL			/TWENTY FOUR
	TAD	SEGLIM		/TWENTY FIVE
	CIA			/NEGATE
	DCA I	INDEX		/SAVE LOGGED-IN SEGMENT QUOTA
	DCA I	INDEX		/NO KNOWN SEGMENTS AS OF YET
	JMP I	UFQUOT

/ROUTINE TO GET THE NUMBER OF A DEVICE ATTACHED TO THIS JOB

/CALLING SEQUENCE:
/	JMS LNS0
/	RETURN IF NONE AVAILABLE
/	NORMAL RETURN (DEVICE NUMBER IN AC)

LNS0,	0
	TAD	DEVTBA		/GLOBAL TO #DEVTBL#
	DCA	CFH
	DATFLD			/CDF FIELD 0
LNS4,	TAD I	CFH		/PICK UP POINTER TO DDB
	SNA
	JMP	LNS2		/DEVICE UNASSIGNED
	IAC
	DCA	LNS3		/POINTER TO SECOOND WORD OF DDB
	TAD I	LNS3
	AND	P0037		/PICK OFF THE JOB NUMBER OF OWNER
	CIA
	TAD	FIJOB		/NUMBER OF CURRENT JOB
	SNA CLA
	JMP	LNS5		/THIS DEVICE IS OURS
LNS2,	ISZ	CFH
	TAD	CFH
	CMA
	TAD	DEVOVR		/GLOBAL TO "JOBTBL"
	SZA CLA
	JMP	LNS4		/CONTINUE LOOKING DOWN TABLE
LNS7,	CFLD			/MAKE SURE WE ARE IN THIS FIELD
	JMP I	LNS0		/FOUND NOW DEVICES

LNS5,	TAD	DEVEND
	CIA
	TAD	CFH
	ISZ	LNS0
	SMA
	JMP	LNS6
	TAD	LNS10
	CLL RAR
	JMP	LNS7

LNS6,	TAD	C4000
	JMP	LNS7

LNS10,	DEVTBE-DEVTBL
LNS3,	0
C4000,	4000

/ROUTINE TO RELEASE A DEVICE

*4200

REL00,	0
	JMS I	DTE01		/IS THIS DEVICE ASSIGNED TO THIS USER?
REL5,	0			/SET BY DTE0 TO POINT TO DEVTBL ENTRY FOR THIS DEVICE
	JMP	REL13		/NO, SO DON'T RELEASE IT
	TAD I	REL5
	DCA	REL6		/SAVE ADDRESS OF DDB FOR LATER
	TAD	REL6
	TAD	P0003		/POSITION OF TIME IN DDB
	DCA	REL2
	TAD I	REL2		/GET TIME ASSIGNED
	CIA
	DCA	REL2		/-TIME ASSIGNED
	CDF
	TAD I	RELCK1		/GET TIME NOW
	RTL
	RTL
	AND	P0007		/JUST SIGNIFICANT PART OF LOW ORDER TIME
	DCA	REL3
	TAD I	RELCK2
	DATFLD
	RTL
	RAL
	AND	P7770		/JUST INSIGNIFICANT PART OF HI ORDER
	TAD	REL3		/TIME AT RELEASE
	CLL
	TAD	REL2		/-TIME AT ASSIGNMENT
	DCA	REL2		/TIME WE OWNED IT
	TAD	REL2
	SNL			/GONE THRU MIDNITE WHILE ASSIGNED?
	TAD	RELCON		/YES, FUDGE TO PROPER VALUE
	SZA
	JMS I	DVT01		/RECORD TIME SINCE WE USED A MEASURABLE AMOUNT
	STL
	TAD	REL5
	TAD	RELCDR		/IS IT A CARD READER OR DECTAPE OR RK05?
	SPA
	RAR			/NO - IS IT A KEYBOARD OR THE PTR?
	SNL
	JMP	REL11		/EITHER KEYBOARD, PTR, CDR, DTA, OR RK05
	TAD	RELREG		/EITHER PTP OR LPT

REL8,	DCA	REL6		/ENTER HERE FROM REL12 FOR TELEPRINTER
	STA
	TAD I	REL5
	DCA	INDEX		/POINT TO WORD 0 OF DDB (AUTOINDEXED)
	TAD I	INDEX		/CHECK STATUS IF TELEPRINTER
	SPA CLA
	JMP	REL4		/HE'S IN THE ^S CONDITION - FLUSH HIM/HER OUT
	DCA I	INDEX		/CLEAR THE JOB NUMBER
	ISZ	INDEX
	ISZ	INDEX
	TAD I	INDEX		/CHECK FILL POINTER
	SZA CLA
	JMP	REL9		/STILL BUSY - LET "CONOUT" RELEASE IT
	TAD	REL6
	SZA CLA			/ASSIGNABLE DEVICE?
	JMP	REL7		/YES
REL4,	TAD I	REL5
	CIF 00
	JMS I	RELTBL		/MAKE SURE THE BUFFER IS CLEAR
	DATFLD
	TAD I	REL5		/RELEASE THE DDB
	JMS I	RETBK1
	CLA
	DATFLD
	DCA I	REL5
REL9,	CFLD
	JMP I	REL00
REL7,	CIF 20			/INHIBIT INTERRUPTS
	TAD I	REL6
	CLL RAL
	SNA
	JMP	REL4
	SPA
	STL
	RAR
	DCA I	REL6
	JMP	REL9

REL11,	SMA CLA			/IS IT A KEYBOARD OR THE PTR?
	JMP	REL12		/NO
	TAD	REL6
	CIF 00
	JMS I	RELTBL		/FLUSH OUT THE BUFFER
REL12,	TAD	REL6
	JMS I	RETBK1		/RELEASE THE DDB
	CLA
	DATFLD
	DCA I	REL5		/REMOVE FROM DEVTBL
	TAD	DEVEND
	CIA
	TAD	REL5
	SMA CLA
	JMP	REL9
	ISZ	REL5
	JMP	REL8

REL13,	CDF
	TAD I	JOB
	AND	C0200
	CFLD
	SZA CLA			/CALLED BY SI??
	JMP I	LGI201		/YES, INDICATE ERROR WITH AC=-1
	JMP I	REL00		/NO, UUO CALL
RELREG,	OUTREG+NULINE+3
RELCDR,	-DEVTBE-4
DVT01,	DVT0
REL2,	0
REL3,	0
RELCK1,	CLK1
RELCK2,	CLK2
RELCON,	3227			/FUDGE FOR MIDNIGHT OVERFLOW
RELTBL,	SICLR
P0100,	100
FIXSCH,	0
	IAC
	DCA	REL5
	TAD I	REL5
	AND	P0100
	SNA CLA
	JMP I	FIXSCH
	TAD	DEVOVR
	CIA
	TAD	INDEX
FIXOUT,	CIF CDF
	DCA I	FIPJOB
	WAIT

EXCEED,	215;212;"[;" ;" ;" ;" ;" ;" ;" ;"E;"X;"C;"E;"E;"D;"I;"N;"G
	" ;"D;"I;"S;"K;" ;"Q;"U;"O;"T;"A;"];215;212;0
/COMPLETION OF LOGOUT ROUTINE
/REMOVES JOB FROM PERMANENT MONITOR TABLES
/MUST BE DONE LAST, SINCE WE NEED THE JOB STATUS BLOCKS
/TO INDICATE ANY ERRORS IN THE FIP I/O

LGO4,	TAD	LGO500		/RESTORE THE FIP EXIT
	CFLD
	DCA I	LGOFIX
	TAD	FIJOB		/SEE IF HE OWNS ANY CORE FIELDS
	CIF
	CORE			/SEARCH CORE TABLE FOR HIM/HER
	FIP SI CJOB
	JMP	LGO5		/NO; NOTHING TO RELEASE
	AND	P0007		/YES; RELEASE THE FIELD
	TAD	CORTBA
	DCA	CFH		/POINTS TO ENTRY IN CORTBL
	CDF
	DCA I	CFH		/ZERO THE ENTRY
LGO5,	TAD	FIJOB		/RETURN STATUS BLOCKS
	TAD	DEVOVR		/START OF JOB TABLE (END OF DEVTBL)
	DCA	LGO6		/POINTS TO JOB TABLE ENTRY
	DATFLD
	TAD I	LGO6		/GET ADDRESS OF JOB STATUS
	JMS I	LGOBLS		/RETURN STATUS
	DATFLD
	DCA I	JOBDAT		/CLEAR JOBDAT
	DCA I	LGO6		/CLEAR POINTER IN JOBTABLE
	CDF
	DCA I	JOB		/CLEAR JOB (SO SAVJOB WON'T SAVE US)
	JMP I	.+1		/AND NOW GO DO FIX50
LGO500,	FIX50
LGOBLS,	RETBLS
LGOFIX,	FIX500
LGO1,	TAD	FIOSTK+1	/LOGOUT WITH AC=0?
	SZA CLA
	JMP I	LGI201		/NO, SO IT'S AN ERROR
	TAD	FIJOB
	TAD	JOBTAB
	DCA	CFH		/GET HIS/HER PROJ-PROG #
	TAD I	CFH
	CIA
	DCA	FIOSTK+2	/SAVE HIS/HER #
	TAD	JOBTAB
	DCA	INDEX		/INITIALIZE TO START OF TABLES
	TAD	LGOMAX		/-JOBMAX
	DCA	FIOSTK+3	/COUNT OF JOBS TO CHECK
	DCA	FIOSTK+4	/COUNT OF MATCHES
	TAD I	INDEX
	TAD	FIOSTK+2	/COMPARE
	SNA CLA
	ISZ	FIOSTK+4	/EXACT MATCH - INDEX COUNT
	ISZ	FIOSTK+3	/DONE?
	JMP	.-5		/NO
	STA			/YES - RETURN # OF MATCHES -1
	TAD	FIOSTK+4
	DCA	FIUSAC
	JMP I	FIEXIT		/AND AWAY

LGOMAX,	-JOBMAX

OPN11,	0
	DCA	OPN13
	TAD	FIOSTK+2	/GET RETRIEVAL POINTER OF UFD BEING ACCESSED
	CIA
	TAD	RETTBL		/IS IT THE MFD?
	SNA CLA
	JMP	OPN14		/MFD OR UFD, READ OK/WRITE NEVER OK
	JMS I	ACC01		/IS HE THE SYSTEM MANAGER?
	JMP	OPN12		/YES; SKIP PROTECTION CHECK
	TAD I	OPN11		/GET PROPER TEST BITS
	AND	P0007		/JUST TEST FOR READ PROTECTION FIRST
	AND I	OPN13		/COMPARE AGAINST FILE'S PROTECTION WORD
	SZA CLA
	JMP I	OPNPRA		/PROTECTION ERROR
	TAD I	OPN11		/READ OK, GET TEST BITS FOR WRITE
	CLL RAL			/CHECK FOR WRITE PROTECTION
	AND I	OPN13
OPN12,	CMA
	DCA	LGO6		/-1 IF OK TO WRITE
	TAD I	ZDS1		/SOME MORE CONDITIONS TO TEST
	DCA	OPN13
	TAD	FIOSTK+2
	JMS I	OPN16		/IS HE THE ONLY PERSON TO OPEN THE FILE?
OPN13,	0
	JMP	OPN14		/NO
	TAD	BASSWT
	CIA
	DATFLD
	SZA
	DCA I	BASWIN		/MAKE SURE THE BASIC WINDOW GETS LOADED
	CFLD
	ISZ	LGO6		/IS HE ALLOWED TO MODIFY IT?
OPN14,	TAD	P0004		/NO, SO WRITE PROTECT BIT IS ON
	ISZ	OPN11		/SKIP ON RETURN
	JMP I	OPN11
OPN16,	ENS0
OPNPRA,	OPNPRE


LGO6,
FIX40,	0
	DCA	FLPARB+3
	TAD	FLPARB+3
	DCA	FLPARB+5
	CLA CMA
	TAD	FLPARB+5
	DCA	FLPARB+4
	JMP I	FIX40

*4600
TTYTBA,	TTYTBL
CLK1A,	CLK1
CLK2A,	CLK2
RESET,	DCA I	CFH
	FGETJT
	JOBACC
	DCA	ADDR
	DATFLD
	TAD	FIOSTK+2
	DCA I	ADDR		/PLUG HIS/HER ACCOUNT # INTO HIS JOB STATUS BLOCKS
	TAD	FIJOB		/GET JOB #
	TAD	TTYTBA
	DCA	ADDR
	TAD I	ADDR		/GET LINE #
	CLL RAL
	TAD	DEVTBA		/FIND THE DDB
	DCA	ADDR
	TAD	P0003
	TAD I	ADDR
	DCA	ADDR
	CDF
	TAD I	CLK1A
	RTL
	RTL
	AND	P0007
	DCA	CFH
	TAD I	CLK2A
	RTL
	RAL
	AND	P7770
	TAD	CFH
	DATFLD			/NOW RESET THE
	DCA I	ADDR		/ASSIGN TIME
	JMP I	.+1		/THEN EXIT
	TABOUT

BASCO0,	0
	JMS I	IFN01		/JUST RETURN INTERNAL FILE # IN FIOSTK+1
	TAD	FIOSTK+1
	JMS I	CL01		/CLOSE ANY FILE THAT IS OPEN
	TAD	FIOSTK+3	/MAY BE
	SNA			/IS IT A NULL FILE NAME?
	JMP I	OPN3A		/YES, ERROR RETURN
	TAD	OPN3A+1		/COMPARE BA
	SZA CLA
	JMP	BASSET		/NO MATCH
	TAD	FIOSTK+2	/IS ACCT # 2?
	SNA
	JMS I	JBLD0		/WHAT'S HIS/HER ACCOUNT?
	CLL RTR
	SNA CLA
	TAD	FIOSTK+4	/COMPARE SI
	TAD	OPN3A+2
	SNA CLA
	TAD	FIOSTK+5
	TAD	OPN3A+3		/COMPARE C
	SNA CLA
	CMA			/IF BASIC, BASSWT=-1
BASSET,	DCA	BASSWT		/IF NOT, BASSWT=0
	TAD	FIOSTK+1
	JMS I	EBLD0		/GET PTR TO ENTTBL WORD 1 RELATIVE PTR WORD 2 ADDRESS IN UFD
	JMP I	BASCO0		/RETURN
OPN3A,	OPN3
	-4241		/-BA
	-6351		/-SI
	-4300		/-C 

CLOBAS,	0
	JMS I	RETBK1
	DCA	BAS3
	TAD	BAS3
	CIA
	TAD	BASWIN
	SNA CLA
	JMP	CLOBA1
	TAD	BAS3
	JMS I	RETBK1
	CLA SKP
CLOBA1,	CLA CMA
	JMP I	CLOBAS

BAS0,	0
	DCA	BAS1		/SAVE BUFFER ADDRESS OF RETRIEVAL WINDOW
	TAD	BASWIN		/BASIC WINDOW ADDRESS
	DCA	ADDR		/GET BUFFER ADDRESS READY
BAS5,	TAD	BAS1		/
	DCA	BAS2
	TAD	C7771
	DCA	BAS3		/COUNT OF 7 SEGS PER WINDOW
BAS4,	ISZ	BAS2
	CFLD
	TAD I	BAS2		/PICK UP THE SEG #
	ISZ	ADDR
	SNA
	JMP	BAS6
	DATFLD
	DCA I	ADDR		/SAVE IT IN WINDOW
	ISZ	BAS3		/COUNT
	JMP	BAS4		/STILL IN SAME BLOCK
	CFLD
	TAD I	BAS1		/CHANGE THE BLOCK
	SNA
	JMP	BAS6		/NO MORE SEGMENTS
	DCA	BAS1
	TAD	FIOSTK+2	/GET THIS BLOCK OF UFD IN BUFFER
	JMS I	GE01
BAS1,	0
	DCA	BAS1		/SAVE THE BUFFER ADDRESS CONTAINING THE NEEDED BLOCK
	JMP	BAS5		/CONTINUE
BAS6,	SNA
	TAD I	BAS1
	SZA CLA
	JMP I	BAS123		/BASIC MUST BE 39 SEGMENTS OR LESS TO USE SPECIAL WINDOW
	TAD	ADDR
	SMA CLA
	JMP	.+5
	DATFLD
	DCA I	ADDR
	ISZ	ADDR
	JMP	.-2
	DATFLD
	CLA CMA
	DCA I	BASWIN		/-1 IN FIRST WORD TO MARK BASIC WINDOW
	JMP I	BAS0
ADDR,	0
BAS2,	0
BAS3,	0
BAS123,	OPN123

/ROUTINE TO LET SYSTEM MANAGER CHANGE PASSWORDS AND DISK QUOTAS

UFDNAM,	RTABLE
	0

PASQU0,	DCA	UFDNAM+1	/SAVE ACCOUNT NUMBER TO SEARCH FOR
	CMA
	JMS I	DS01		/SEARCH MFD FOR THIS ACCOUNT
	UFDNAM
	JMP	PASNOT		/ACCOUNT NOT FOUND IN MFD
	DCA	INDEX		/SAVE POINTER TO OLD PASSWORD
	TAD	FIOSTK+2	/FIRST TWO CHARACTERS OF NEW PASSWORD
	DCA I	INDEX		/SAVE IN MFD NAME BLOCK
	TAD	FIOSTK+3	/SECOND TWO CHARACTERS OF NEW PASSWORD
	DCA I	INDEX		/SAVE IN MFD
	ISZ	INDEX		/SKIP PAST LINK TO NEXT UFD
	TAD	FIOSTK+4	/GET NEW DISK QUOTA
	DCA I	INDEX		/SAVE NEW QUOTA
	DCA	BUFMOD		/REMEMBER TO WRITE OUT THE MFD SEGMENT
	TAD	FIOSTK+1	/SEE IF THIS ACCOUNT IS CURRENTLY IN THE UFDTBL
	JMS I	UTS01
	JMP I	FIEXIT		/NOT THERE
	ISZ	UTPRNU		/POINTS TO -QUOTA ENTRY
	STA
	TAD	FIOSTK+1	/IS IT THE QUOTA FOR THE "GRACE SPACE"?
	SNA CLA
	JMP	PASQU1		/YES
	TAD	FIOSTK+4	/TRIM OFF THE LOGOUT PORTION OF THE QUOTA
	AND	P0077
	DCA	FIOSTK+4
	TAD	FIOSTK+4
	CLL RAL			/MULTIPLY BY TWO
	TAD	FIOSTK+4	/THREE
	RAL			/SIX
	RTL			/TWENTY FOUR
PASQU1,	TAD	FIOSTK+4	/TWENTY FIVE; OR ACTUAL COUNT IF FOR "GRACE SPACE"
	CIA			/NEGATE THE RESULT
	DCA I	UTPRNU		/SAVE AWAY IN THE UFDTBL
	JMP I	.+1
	TABOUT

PASNOT,	TAD	P7000		/RETURN FILE NOT FOUND
	DCA	FIUSAC
	JMP I	FIEXIT

/SUBROUTINE TO FIND AN EMPTY DIRECTORY ENTRY

/CALLING SEQUENCE:
/	TAD (POINTER TO UFD RETRIEVAL INFORMATION)
/	JMS DE0
/	BAD RETURN (COULD NOT FIND A FREE ENTRY)
/	NORMAL RETURN (POINTER TO ENTRY IN AC)

DE0,	0
	DCA	DERETP		/SAVE RETRIEVAL PTR
	DCA	DE2		/ZERO THE ADDRESS IN UFD
	TAD	BUFSTA		/IS THERE A SEGMENT IN THE BUFFER?
	SMA CLA
	JMP	DE7		/NO, SO START FROM THE BEGINNING
	TAD I	GERETA		/GET THE SEGMENT IN CORE
	CMA
	DCA	NSEGCR
	TAD	DERETP		/GET RETRIEVAL PTR FOR INCREMENT
	DCA	UFDPTR
DE5,	TAD I	UFDPTR
	SNA			/IS THERE A SEGMENT?
	JMP	DE7		/NO, START FROM 0 LOC IN UFD
	TAD	NSEGCR		/YES, DOES IT AGREE WITH THE SEGMENT IN CORE?
	SNA CLA
	JMP	DE6		/YES, START SEARCHING AT THIS POINT
	TAD	DE2		/NO, INCREMENT THE ADDR
	TAD	C0400
	DCA	DE2
	ISZ	UFDPTR		/POINT TO NEXT SEGMENT IN RETRIEVAL BLOCK
	JMP	DE5		/GO BACK
DE7,	DCA	DE2		/INDICATE THAT SEARCH IS FROM WORD 0
	STA
DE6,	DCA I	UFD01		/SAVE SECOND PASS FLAG
DE1,	TAD	DERETP
	JMS I	GE01		/GET ENTRY INTO CORE
DE2,	0
	SNA			/SKIP IF ENTRY EXISTS
	JMP	DE4		/DID NOT EXIST, EXTEND UFD
	DCA	DEBUFP
	TAD I	DEBUFP		/FIRST WORD OF ENTRY
	SZA CLA
	JMP	DE3		/NOT EMPTY, LOOK AT NEXT ENTRY
	ISZ	DEBUFP		/ZERO COULD MEAN END OF STRING OF RETRIEVAL INFORMATION BLOCKS
	TAD I	DEBUFP		/LOOK AT SECOND WORD OF ENTRY
	SZA CLA			/IF ZERO, EMPTY ENTRY
	JMP	DE3		/NOT EMPTY, KEEP LOOKING
	TAD	DE2		/PICK UP ENTRY POINTER
	SNA			/ENTRY 0 NEVER AVAILABLE
	JMP	DE3
	ISZ	DE0		/POINT TO NORMAL RETURN
	JMP I	DE0

DE3,	TAD	C0010		/INCREMENT TO NEXT ENTRY
	TAD	DE2
	DCA	DE2		/SAVE NEXT ENTRY INDEX
	JMP	DE1		/LOOK AT NEXT ONE

DE4,	ISZ I	UFD01		/HAVE WE TRIED FROM THE BEGINNING YET?
	JMP	DE7		/NO, WELL TRY IT THEN...
	TAD	DERETP
	JMS I	UFD01		/TRY EXTENDING THE UFD
	JMP I	DE0		/TOO BAD, CAN'T EXTEND UFD
	JMP	DE1		/NOW WE HAVE PLENTY OF ROOM
DEBUFP,	0
UFD01,	UFD0
DERETP,	0
UFDPTR,	0
GERETA,	RDCURR
NSEGCR,	0

/ROUTINE TO OUTPUT QUOTA EXCEEDED MESSAGE
EXTEL0,	0
	DATFLD
	TAD	FIJOB		/CURRENT JOB NUMBER
	TAD	TTYTAB		/POINTS AT POSITION IN TTYTBL
	DCA	DE0
	TAD I	DE0		/GET CONSOLE NUMBER FOR THIS JOB
	STL RAL			/TIMES 2 PLUS 1
	TAD	DEVTBA		/INDEX TO OUTPUT DDB
	CDF
	DCA I	CONDVA		/STORE FOR FIELD 0 PRINT ROUTINE
	CFLD
	TAD	EXTMES		/GET MESSAGE POINTER
	DCA	INDEX
EXTEL1,	TAD I	INDEX		/GET CHARACTER OF THE MESSAGE
	SNA			/ANY LEFT?
	JMP I	EXTEL0		/NO; SO GO EXTEND
	CIF CDF 00
	DCA I	FICHAR		/STORE FOR PRINT OUT ROUTINE
	CFLD
	PRINT			/SEND MESSAGE #[EXCEEDING DISK QUOTA]#
	JMP I	EXTEL0		/RAN OUT OF SPACE IN THE OUTPUT BUFFER (TOO BAD!)
	JMP	EXTEL1		/BACK FOR NEXT CHARACTER

TTYTAB,	TTYTBL
CONDVA,	CONDBA
EXTMES,	EXCEED-1
FICHAR,	TTCHAR

/ROUTINE TO CLEAR ALL CPU AND DEVICE TIME ACCUMULATORS IN THE MFD
/THIS IS USED BY THE #RESET# FUNCTION IN THE CUSP #CAT#
LGRES0,	CLA IAC			/SET RESET FLAG IN DIRECTORY SEARCH ROUTINE
	DCA I	RETBK1
	TAD	RETBK1
	DCA	EXQ1		/SET POINTER SO FLAG WILL CLEAR ON COMPLETION
	TAD	RETTBL
	DCA	GDRETP		/SET RETRIEVAL POINTER
	JMS	LOQUO		/GO DO THE RESET
	CMA			/SHOULD RETURN A ZERO IN AC
	JMP	EXTQU1

/ROUTINE TO COUNT TOTAL SEGMENTS OWNED BY A UFD AND
/SAVE THE RESULT IN WORD 3 OF THE UFDTBL ENTRY FOR THE RESPECTIVE UFD
/CALL:
/	EXQ1 POINTS TO WORD 3 OF CORRECT UFDTBL ENTRY
/	JMS	LOQUO
/	RETURN (ENTRY 3 LOADED, TOTAL ALSO IN AC)

EXQ3,
LOQUO,	0
	DCA	WNDREM		/FUDGE A FILE NAME BEGINNING WITH TWO SPACES
	JMS I	DS01		/SEARCH DIRECTORY TO DETERMINE SEGMENT COUNT
	GDRETP			/(HOPE NO ONE SCRAMBLES LOC. 23-26 ON PAGE 0!!)
	CLA SKP			/GOOD - COULDN'T FIND SUCH A FILE
	JMP I	DIRBAD		/FOUND IT! OOPS!
	TAD	SEGLIM		/GET THE TOTAL FROM THE DIRECTORY SEARCH
	DCA I	EXQ1		/SAVE IN UFDTBL
	TAD	FIOSTK+1	/INTERNAL FILE NUMBER?
	SMA			/IF THIS IS NOT A "RESET" WE MUST RELOAD
	JMS I	GD01		/THE CORRECT DIRECTORY SEGMENT
	DCA	REL6		/SAVE POINTER TO NAME BLOCK
	TAD	SEGLIM		/RETURN WITH CURRENT TOTAL
	JMP I	LOQUO


EXTQU8,	CLA			/WE'VE BEEN HERE BEFORE FOR THIS GUY
	CFLD
	TAD	EXQ2		/WILL THIS EXTEND CARRY
	TAD I	EXQ1		/THIS FILE ACROSS THE QUOTA BOUNDARY AGAIN?
	SMA SZA CLA		/(I.E. HAS HE REDUCED SINCE LAST EXTEND?)
	JMP	EXTQU9		/NO; HE'S STILL ABOVE QUOTA, EXTEND QUIETLY
EXTQU6,	TAD	EXFILE		/ADDRESS WITHIN MESSAGE TO STORE FILE NAME
	DCA	INDEX
	JMS	EXTNAM		/CHAR 1 & 2 OF FILE NAME
	JMS	EXTNAM		/CHAR 3 & 4 OF FILE NAME
	JMS	EXTNAM		/CHAR 5 & 6 OF FILE NAME
	JMS I	EXTELL		/NOTIFY USER THAT QUOTA IS BEING EXCEEDED
EXTQU9,	CLA
	JMP I	EXTQU0		/EXIT TO EXTEND FILE AS REQUESTED

EXTQU5,	TAD	FIOSTK+2	/NUMBER OF SEGMENTS HE WON'T GET
EXTQU1,	DCA	FIUSAC		/PASS RESULT BACK TO THE USER
	JMP I	FIEXIT

/ROUTINE TO CHECK LOGIN QUOTA BEFORE EXTENDING A FILE

EXTQU0,	0
	TAD	GDRETP		/COMPARE RETRIEVAL POINTER
	CIA
	TAD	RETTBL		/AGAINST THE MFD'S ENTRY
	SNA CLA			/IS IT FROM THE SYSTEM MANAGER?
	JMP I	VIOLAT		/GET OUT QUICK, BEFORE HE DESTROYS THE SYSTEM
	TAD	FIOSTK+2	/NUMBER OF SEGMENTS TO BE ADDED
	SPA			/IS HE BEING REASONABLE?
	JMP	EXTQU1		/NO - HE DESERVES TO FAIL!
	CLL CIA
	TAD I	SATSEG		/ARE THERE THAT MANY SEGMENTS LEFT ON THE SYSTEM?
	SNL CLA
	JMP	EXTQU5		/NO; SO DON'T GIVE ANY
	TAD	GDRETP		/RETRIEVAL POINTER
	JMS I	ENS33		/CONVERT TO RELATIVE ENTRY NUMBER
	STL RTL			/TIMES FOUR PLUS TWO
	TAD	UFDTBL		/POINTS AT -LOGIN QUOTA
	DCA	EXQ1		/SAVE POINTER
	TAD I	EXQ1		/GET NEGATIVE QUOTA
	DCA	EXQ2		/AND SAVE
	ISZ	EXQ1		/POINTS AT CURRENTLY OWNED COUNT
	TAD I	EXQ1		/GET HIS/HER PRESENT TOTAL
	SNA			/HAS THE COUNT BEEN SET UP YET?
	JMS	LOQUO		/NO; GO FIGURE IT OUT
	TAD	FIOSTK+2	/ADD THE NUMBER HE WANTS
	TAD	EXQ2		/AND SUBTRACT FROM QUOTA
	SPA SNA			/WILL THIS EXCEED THE QUOTA FOR THIS ACCOUNT?
	JMP	EXTQU9		/NO; GO EXTEND
	TAD I	GRACE		/WILL IT GO BEYOND THE #GRACE SPACE#?
	SMA SZA CLA
	JMP	EXTQU5		/YES; DON'T BOTHER EXTENDING
	TAD	FIOSTK+1	/SEE IF THIS FILE IS ALREADY IN THE GRACE AREA
	JMS I	LNK01		/GET POINTER TO FILE CONTROL BLOCK
	TAD	FILPRP		/POINT TO STATUS WORD
	DCA	EXQ3
	DATFLD
	TAD I	EXQ3		/GET CURRENT STATUS FOR THIS FILE
	RAR
	SZL			/IS THIS FILE IN THE GRACE AREA?
	JMP	EXTQU8		/MAYBE; SEE IF HE'S REENTERING
	STL RAL			/SET GRACE BIT
	DCA I	EXQ3
	CFLD
	JMP	EXTQU6		/SEND MESSAGE, THEN GO EXTEND

/ROUTINE TO PLANT FILE NAME INTO "EXCEEDING QUOTA" MESSAGE

EXTNAM,	0
	TAD I	REL6		/GET PART OF FILE NAME
	RTR
	RTR
	RTR
	AND	P0077		/SAVE LEFT BYTE
	TAD	P0240		/CONVERT TO ASCII
	DCA I	INDEX		/STORE IN THE MESSAGE AREA
	TAD I	REL6		/NOW FOR THE RIGHT BYTE
	AND	P0077
	TAD	P0240		/CONVERT TO ASCII
	DCA I	INDEX		/SAVE RIGHT BYTE
	ISZ	REL6		/POINT TO NEXT CHARACTER
	JMP I	EXTNAM

/ROUTINE TO CHECK FOR THE SAFE REDUCTION OF A UFD
/TWO CONDITIONS MUST BE MET:
/	THE ACCOUNT CANNOT BE IN USE TO ANYONE
/	THE ACCOUNT MUST HAVE AN EMPTY DIRECTORY

EXQ2,
REDUF0,	0
	TAD	GDRETP		/GET RETRIEVAL POINTER
	CIA
	TAD	RETTBL		/IS HE TRYING TO REDUCE A UFD?
	SZA CLA
	JMP I	REDUF0		/NO; LET HIM/HER REDUCE NORMAL FILES
	TAD I	REL6		/GET THE ACCOUNT NUMBER OF THE UFD IN QUESTION
	JMS I	UTS01		/LOOK IT UP IN THE UFD TABLE
	JMP	REDUF1		/NOT THERE - GOOD
	CLA
	TAD	C4400		/TELL HIM "FILE IN USE"
	JMP	EXTQU1
REDUF1,	TAD I	REL6		/GET THE ACCOUNT NUMBER OF THE UFD TO BE DELETED
	JMS I	UFO01		/LOAD ITS RETRIEVAL WINDOW INTO RTABLE
	JMP	EXTQU5		/COULDN'T; PAS HIS/HER OWN AC BACK AS AN ERROR INDICATION
	JMS I	BLDP1		/MAKE A RETRIEVAL POINTER
	DCA	GDRETP		/SAVE IT FOR THE SEARCH
	ISZ	EXQ1		/POSITION UFDTBL POINTER FOR THIS ACCOUNT
	ISZ	EXQ1		/TO POINT TO THE SEGMENT ACCUMULATOR
	JMS	LOQUO		/SEE IF THIS UFD STILL CONTAINS FILES
	CLL STA RTL		/AC=-3
	TAD	EXQ1		/POSITION WE'VE BEEN ASSIGNED ON UFDTBL
	JMS I	TF01		/FREE THE POSITION
	TAD I	EXQ1		/DID HE OWN ANY SEGMENTS?
	SZA CLA
	JMP I	VIOLAT		/STILL SOME FILES IN THERE!
	STA
	DCA	FIOSTK+2	/FORCE HIM/HER TO COMPLETELY DELETE THIS UFD
	JMP I	REDUF0


VIOLAT,	PRT1+1
ENS33,	ENS3
SATSEG,	-SATSIZ+1
EXFILE,	EXCEED+2
EXTELL,	EXTEL0
P0240,	240
GRACE,	UTABLE+2

$%&$%&$%&$%&$%&$%&$%&$%&$%&$%&$%&$%&$%&$%&$%&$%&$%&$