TITLE DPACK
	EXTERN JOBTPC, JOBAPR
	D=0
	LIMIT=^D45000
	PROT=157
	OPDEF TTCALL [51B8]
	DEFINE TTYOUT (ADR) <TTCALL 3, ADR>
	DEFINE TTYIN (ADR) <TTCALL 4, ADR>
START:	TTYOUT CRLF
	INIT D, 17
	SIXBIT/DSK/
	0
	JRST NOTAVL
	TTYOUT [ASCIZ"PACK NAME:  "]
	MOVE 1, [POINT 6,UFD-1,35]
	MOVEI 2, 5
GETNAM:	TTYIN 0
	SUBI 40
	JUMPE GETNAM
	JUMPL .+3
	IDPB 0, 1
	SOJG 2, GETNAM
	LOOKUP D, UFD
	JRST NEW
	TTYOUT [ASCIZ "PACK ALREADY DEFINED."]
	CALLI 12
	CLOSE	D,
NEW:	CLEARM UFD+2
	CLEARM UFD+3
	ENTER D, UFD
	0
	MOVEI 1, 177
	CLEARM BUF(1)
	SOJGE 1, .-1
GETSEC:	TTYOUT [ASCIZ "NO. OF SECTORS:  "]
	TTCALL 11,
	CLEAR 1,
SECIN:	TTYIN 0
	CAIN " "
	JRST SECIN
	CAIN 015
	JRST BIG
	SUBI 60
	JUMPL WHAT
	CAIL 12
	JRST WHAT
	IMULI 1, 12
	ADD 1, 0
	JRST SECIN
BIG:	CAILE 1, LIMIT
	JRST EXCEED
	MOVEM 1, BUF+177
	IDIVI 1, 14
	SKIPE 2
	AOJ 1,
	MOVEI 2, 1
OUT:	MOVEM 2, BUF+176
	OUT D, LIST
	SKIPA
	JRST OUTERR
	CAMGE 2, 1
	AOJA 2, OUT
CLOSE:	CLOSE D,
	MOVE [EXP<PROT>B8]
	MOVEM UFD + 2
	RENAME D, UFD
	0
	CLOSE D,
	CALLI 12
NOTAVL:	TTYOUT [ASCIZ "DEVICE  NOT  AVAILABLE."]
	CALLI 12
EXCEED:	TTYOUT [ASCIZ"PACK MAY NOT EXCEED 45000 SECTORS."]
	TTYOUT CRLF
	TTYOUT CRLF
	JRST GETSEC
OUTERR:	TTYOUT CRLF
	STATZ D, 700000
	JRST DELETE
	TTYOUT [ASCIZ "NOT ENOUGH ROOM."]
	TTYOUT CRLF
	SOJ 2,
	IMULI 2, 14
	MOVEI 200000
	CALLI 16
	MOVEI POP+4
	MOVEM JOBAPR
	MOVEI PLIST-1
	IDIVI 2, 12
	PUSH 3
	JUMPN 2, .-2
POP:	POP 3
	ADDI 3, 60
	TTCALL 1, 3
	JRST POP
	TTYOUT [ASCIZ " SECTORS WRITTEN."]
	JRST CLOSE
DELETE:	TTYOUT [ASCIZ "OUTPUT ERROR--PACK NOT SAVED."]
	CALL [SIXBIT/RESET/]
	CALLI 12
WHAT:	TTYOUT [ASCIZ"IS THAT A NUMBER?"]
	TTYOUT CRLF
	TTYOUT CRLF
	JRST GETSEC
CRLF:	BYTE(7) 015, 012
LIST:	IOWD 200, BUF
	0
UFD:	EXP 0, SIXBIT/PAK/, 0, 0
PLIST:	BLOCK 5
BUF:	BLOCK 200
	END  START