ARK
  14
.IOERR006
.PCK@@002
.SIXPK001
ARCHIV002
ARK@@@JOB
DEARCH007
DRK@@@JOB
GNAMES006
NOFPP@PRM
ORDER@007
SAVE@@011
TF1@@@SRC
TF2@@@SRC
UN.PCK002
[\].
.IOERR006
	.TITLE	.IOERR
/
/   1 AUG 78 (006; PDH) MUST USE SIGNED SHIFT
/   1 AUG 78 (005; PDH) REVAMP TO USE '.PCK' AND TO ANNOUNCE 6-DIGIT
/			VALUE WHEN EV .GT. 777
/  25 OCT 77 (004; PDH) CHANGE FROM 'MCR=3' TO 'TTY=4' FOR MULTIACCESS
/  14 JUL 77 (003; PDH) ANNOUNCE CALLING ADDRESS ALSO
/  21 APR 77 - PAUL HENDERSON
/
/  THIS ROUTINE, CALLABLE ONLY FROM ASSEMBLY LANGUAGE PROGRAMS, IS
/  USED TO OUTPUT THE NAME OF THE  TASK  AND THE OCTAL VALUE OF AN
/  I/O ERROR, AND THE ADDRESS FROM WHICH IT IS CALLED.   THIS IS A
/  FATAL ERROR ANNOUNCEMENT,  AS THE ROUTINE EXITS AFTER THE ERROR
/  ANNOUNCEMENT.
/
/  CALLING SEQUENCE:
/
/	LAC	EV
/	JMS*	.IOERR		/ NECESSARY TO ESTABLISH CALLING ADDRESS
/
ECLA=641000		/ EAE CLEAR AC INSTRUCTION
	.DEC
TTY=4			/ LUN ON WHICH ERROR MESSAGE IS ISSUED
	.OCT
/
	.GLOBL	.IOERR
	.GLOBL	PCK.IN,.PCK					/(005)
/
.IOERR	NOP
	DAC	VALUE		/ SAVE BAD EVENT VARIABLE	/(005)
	CAL	TSKNAM		/ GET NAME OF CALLING TASK	/(005)
	LAW	-6						/(005)
	DAC	COUNT		/ ASSUME NON-STANDARD VALUE	/(005)
	LAC	(ERRB						/(005)
	JMS*	PCK.IN		/ SET UP PACKING ROUTINE	/(005)
	LAC	VALUE		/ RETRIEVE EVENT VARIABLE	/(005)
	SMA!TCA			/ PROBABLY NEGATIVE ON ENTRY,
	TCA			/ BUT MAY NOT BE.  MAKE POSITIVE.
	CLQ!LRSS 11		/ SHIFT BAD EV TO UPPER HALF OF CLEARED MQ /(006)
	SZA							/(005)
	JMP	STRANGE		/ EV .GT. 777 - STRANGE THINGS	/(005)
	LAW	-3		/ NORMALLY, BAD EV'S ARE 3 DIGITS /(005)
	DAC	COUNT						/(005)
	LACQ			/ GET 3-DIGIT VALUE FROM MQ	/(005)
	DAC	VALUE		/ AND PLACE IT IN CORRECT PLACE	/(005)
 
	.EJECT
STRANGE	JMS	OCT2AS		/ CONVERT OCTAL 'VALUE' TO ASCII /(005)
	LAW	40
	JMS*	.PCK		/ FOLLOW EV WITH SPACE		/(005)
 
	LAC	.IOERR		/ GET CALLING ADDRESS
	SAD	(NOP		/ IF ENTERED BY 'JMS',
	JMP	ENDADR		/ CALLING ADDRESS IS UNAVAILABLE /(005)
	ALS	3						/(005)
	DAC	VALUE		/ SAVE 15-BIT ADDRESS		/(005)
	LAW	-5						/(005)
	DAC	COUNT		/ 5 DIGITS			/(005)
	JMS	OCT2AS		/ PACK THEM UP			/(005)
ENDADR	LAW	15		/ FINISH WITH CARRIAGE RETURN	/(005)
	JMS*	.PCK						/(005)
 
	.EJECT
/  WE HAVE NOW PACKED UP THE EVENT VARIABLE AND CALLING ADDRESS.  GET
/  THE TASK NAME AND PREPARE IT FOR OUTPUT.
 
	LAC	(TASKNM						/(005)
	JMS*	PCK.IN		/ SET UP PACKING ROUTINE AGAIN	/(005)
	LAC	TSKNAM+2					/(005)
	LMQ			/ PUT 1ST CHARACTER IN MQ	/(005)
	JMS	SIXTO7		/ CONVERT TO 7-BITS AND STORE	/(005)
	LAC	TSKNAM+2					/(005)
	LRS	14		/ 2ND CHARACTER			/(005)
	JMS	SIXTO7						/(005)
	LAC	TSKNAM+2					/(005)
	LRS	6		/ 3RD CHARACTER			/(005)
	JMS	SIXTO7						/(005)
	LAC	TSKNAM+3					/(005)
	LMQ			/ 4TH CHARACTER			/(005)
	JMS	SIXTO7						/(005)
	LAC	TSKNAM+3					/(005)
	LRS	14		/ 5TH CHARACTER			/(005)
	JMS	SIXTO7						/(005)
	LAC	TSKNAM+3					/(005)
	LRS	6		/ 6TH CHARACTER			/(005)
	JMS	SIXTO7						/(005)
 
/  MESSAGE BUFFER HAS BEEN PREPARED.  ANNOUNCE IT ON TTY.
 
ENDNAME	CAL	WRERR		/ ANNOUNCE ERROR		/(005)
	CAL	WAITFR		/ WAIT FOR IT
	CAL	(10		/ THEN EXIT
 
	.EJECT
/  SUBROUTINE TO CONVERT 'COUNT' DIGITS FROM 'VALUE' TO ASCII AND
/  PACK THEM, USING ROUTINE '.PCK'.
/    BEFORE CALLING, THE NUMBER OF DIGITS MUST BE SPECIFIED (2'S COMP)
/  IN 'COUNT', AND THE '.PCK' ROUTINE MUST HAVE BEEN SET UP.
 
OCT2AS	XX							/(005)
OCT2.1	LAC	VALUE						/(005)
	LMQ			/ PUT NEW VALUE IN MQ		/(005)
	ECLA!LLS 3		/ SHIFT IN NEXT OCTAL DIGIT	/(005)
	DAC	EV		/ SAVE TEMPORARILY		/(005)
	LACQ							/(005)
	DAC	VALUE		/ SAVE NEW VALUE		/(005)
	LAC	EV		/ RETRIEVE DIGIT		/(005)
	XOR	(60						/(005)
	JMS*	.PCK		/ PACK ASCII CHARACTER		/(005)
	ISZ	COUNT						/(005)
	JMP	OCT2.1		/ PACK ANOTHER IF NOT DONE	/(005)
	JMP*	OCT2AS						/(005)
 
 
/  SUBROUTINE TO EXTRACT A 6-BIT CHARACTER FROM THE MQ AND CONVERT IT
/  TO A 7-BIT IMAGE ASCII CHARACTER IN THE AC.
 
SIXTO7	XX
	ECLA!LLS 1		/ SHIFT IN HIGH-ORDER BIT OF CHARACTER
	SNA
	XOR	(2		/ CONVERT FROM 6- TO 7-BIT, AS APPROPRIATE
	LLS	5		/ SHIFT IN REST OF CHARACTER
	SAD	(100		/ '@' MEANS END OF TASK NAME
	JMP	ENDNAME
	JMS*	.PCK		/ PACK THE CHARACTER		/(005)
	JMP*	SIXTO7
 
	.EJECT
ERRL	EL-.*400+2;EV
	.ASCII	'***'
TASKNM	0; 0
	.ASCII	<0><0><0>': I/O ERROR '
ERRB	.BLOCK	6;EL=.;VALUE					/(006)
TSKNAM	25;COUNT 0;	.BLOCK 2
WRERR	2700;	EV;	TTY; 2; ERRL
WAITFR	20;	EV
	.END
[\].
.PCK@@002
	.TITLE	.PCK
/
/  26 JUN 78 (002; PDH) DEBUG
/  26 JUN 78 - PAUL HENDERSON
/
/  ROUTINE TO PACK CHARACTERS, AS THEY ARE SUPPLIED, INTO 5/7
/  ASCII.  IF A LINE TERMINATOR (CR OR ALT MODE) IS ENCOUNTERED
/  THIS FACT IS NOTED IN THE INFORMATION RETURNED.
/
/  *** NOTE ***  THE ROUTINE MUST BE SET UP BY THE APPROPRIATE
/		CALL TO 'PCK.IN', OR DISASTER MAY BE PERPETRATED!
/
/  CALLING SEQUENCES:
/
/  1) TO INITIALIZE -
/
/	LAC	(ADDRESS OF BUFFER TO RECEIVE PACKED CHARACTERS
/	JMS*	PCK.IN
/	(RETURN)
/
/  2) TO PACK A CHARACTER -
/
/	LAC	CHARACTER
/	JMS*	.PCK
/	(RETURN)		/ LINK = 1 IF TERMINATOR SINCE LAST SETUP
/				/ AC = NUMBER OF WORDS PACKED
/				/ MQ = NUMBER OF CHARACTERS PACKED
 
INC=ISZ			/ INCREMENT A POSITIVE COUNTER
IDX=ISZ			/ INDEX A POINTER
SET=ISZ			/ SET A FLAG NON-ZERO
 
	.GLOBL	PCK.IN
 
PCK.IN	XX
	DAC	WPNT		/ SAVE LINE BUFFER ADDRESS IN WORKING POINTER
	LAC	(..1
	DAC	SWING		/ SET UP PACKING ROUTINE
	DZM	TERMIN		/ CLEAR 'LINE TERMINATOR PACKED' FLAG
	DZM	CCOUNT		/ ZERO CHARACTER COUNTER
	DZM	WCOUNT		/ AND WORD COUNTER
	JMP*	PCK.IN
 
WPNT;TERMIN;CCOUNT;WCOUNT
	.EJECT
	.GLOBL	.PCK
 
.PCK	XX
	AND	(177		/ ENSURE 7 BITS ONLY
	SAD	(15
	SKP
	SAD	(175
	SET	TERMIN		/ SET FLAG IF CR OR ALT MODE
	JMP*	SWING		/ PACK THE CHARACTER
 
SWING	..1
	INC	CCOUNT		/ INCREMENT CHARACTER COUNTER
	LAC	TERMIN		/ IF WE HAVE PACKED A LINE TERMINATOR
	SZA!CLL		/ SET LINK
	STL
	LAC	CCOUNT		/ EXIT WITH CHARACTER COUNT IN MQ
	LMQ
	LAC	WCOUNT		/ WORD COUNT IN AC, AND
	JMP*	.PCK		/ LINE TERMINATOR FLAG IN LINK.
 
..1	INC	WCOUNT		/ INCREMENT WORD COUNTER
	ALSS	13
	DAC*	WPNT
	JMS	SWING
 
..2	ALSS	4
	XOR*	WPNT
	DAC*	WPNT
	JMS	SWING
 
..3	CLQ!LRSS 3
	XOR*	WPNT
	DAC*	WPNT
	IDX	WPNT		/ INDEXTO NEXT WORD
	INC	WCOUNT		/ COUNT THE WORD
	LACQ			/ RETRIEVE FINAL 3 BITS OF 3RD CHARACTER
	DAC*	WPNT
	JMS	SWING
 
..4	ALSS	10
	XOR*	WPNT
	DAC*	WPNT
	JMS	SWING
 
..5	CLL!RAL
	XOR*	WPNT
	DAC*	WPNT
	IDX	WPNT		/ INDEX POINTER FOR NEXT PAIR, BUT
	JMS	SWING		/ WORD COUNTER WILL BE INCREMENTED ONLY
	JMP	..1		/ IF ANOTHER CHARACTER IS PACKED.
 
	.END
[\].
.SIXPK001
	.TITLE	.SIXPK
/
/  23 JUN 78 - PAUL HENDERSON
/
/  THIS ROUTINE CONSTRUCTS A .SIXBT FILE NAME AND EXTENSION AS
/  CHARACTERS ARE SUPPLIED, ONE CHARACTER PER CALL.  THE CONVENTION
/  USED IS THAT CHARACTERS ARE PACKED, THREE PER WORD, IN THE
/  FILE NAME AND EXTENSION.  ALL NON-SPACE CHARACTERS AFTER A
/  SPACE GO IN THE EXTENSION, EVEN IF THE FILE NAME IS NOT
/  COMPLETELY FILLED, OR IF THERE HAVE BEEN MORE THAN SIX
/  CHARACTERS.  ALL CHARACTERS AFTER THE NINTH (IF NO SPACE)
/  OR AFTER THE THIRD EXTENSION CHARACTER ARE IGNORED, AS ARE
/  ALL CHARACTERS INCLUDING AND AFTER A LINE TERMINATOR.
/     THE ROUTINE MUST BE INITIALIZED BY A CALL TO 'SIX.IN',
/  WHICH ALSO ZEROS THE 3-WORD FILE NAME BUFFER.
/
/  CALLING SEQUENCES:
/
/ 1) TO INITIALIZE -
/
/	LAC	(ADDRESS OF 3-WORD FILE NAME BUFFER
/	JMS*	SIX.IN
/	(RETURN)
/
/ 2) TO PACK CHARACTERS -
/
/	LAC	CHARACTER
/	JMS*	.SIXPK
/	(RETURN)
/
X10=10
SET=ISZ			/ SET A FLAG NON-ZERO
	.GLOBL	SIX.IN
/
SIX.IN	XX
	DAC	KPNT		/ KEEP ORIGINAL POINTER
	DAC	WPNT		/ WORKING POINTER GETS ALTERED
	DAC*	(X10
	DZM*	WPNT
	DZM*	X10		/ ZERO THE 3-WORD BLOCK
	DZM*	X10
	LAC	(FIRSTC
	DAC	SWING		/ SET UP THE BRANCH ADDRESSES
	LAC	(FNAME2
	DAC	SELECT
	DZM	TERMIN		/ CLEAR 'LINE TERMINATOR FOUND'
	JMP*	SIX.IN
/
KPNT;WPNT;TERMIN 1
	.EJECT
	.GLOBL	.SIXPK
/
.SIXPK	XX
	AND	(177		/ ENSURE WE HAVE ONLY 7 BITS
	SAD	(15		/ IF (CARRIAGE RETURN
	SKP
	SAD	(175		/ 	OR ALT MODE)
	JMP	CRALT		/    IGNORE ALL CHARACTERS UNTIL
				/    AFTER NEXT 'SIX.IN';
	SAD	(40		/ ELSEIF (SPACE)
	JMP	EXT		/    CHARACTERS GO IN EXTENSION
	AAC	-140
	SMA			/ IF (LOWER CASE)
	AAC	-40		/    CONVERT TO UPPER CASE
	AAC	140
	AND	(77		/ CHOP TO 6 BITS
	JMP*	SWING		/ THEN PROCESS CHARACTERS IN TURN
/\
SWING	OVRFLOW			/ IGNORE CHARACTERS UNLESS SET UP
	JMP*	.SIXPK
/
CRALT	SET	TERMIN		/ SET 'LINE TERMINATOR FOUND' FLAG
	JMP	OVRFLOW		/ THEN IGNORE CHARACTERS
/
NXT	JMS	SWING		/ ESTABLISH CORRECT BRANCH ADDRESS
/
FIRSTC	ALSS	14
	DAC*	WPNT		/ STORE FIRST CHARACTER
	JMS	SWING
/
	ALSS	6
	XOR*	WPNT		/ INCLUDE WITH 1ST CHAR
	DAC*	WPNT		/ AND STORE FIRST 2 CHARACTERS
	JMS	SWING
/
	XOR*	WPNT
	DAC*	WPNT		/ WORD NOW FULL.
	JMP*	SELECT		/ SELECT NEXT STAGE IN PROCESSING
/
	.EJECT
SELECT	OVRFLOW			/ IGNORE IF NOT SET UP
	JMP	NXT		/ SET UP WORD PACKER FOR
				/ ANOTHER 3 CHARACTERS
FNAME2	LAC	KPNT
	IAC			/ POINT TO SECOND WORD OF BLOCK
	DAC	WPNT
	JMS	SELECT
/
EXT	LAC	TERMIN		/ MUST CHECK BECAUSE A SPACE AFTER
	SZA			/ A LINE TERMINATOR COULD WREAK HAVOC
	JMP	OVRFLOW
	LAC	KPNT
	AAC	2
	DAC	WPNT		/ SELECT 3RD WORD (EXTENSION)
	JMS	SELECT
/
OVRFLOW	JMS	SWING		/ RETURN WITHOUT PROCESSING
	JMP	OVRFLOW		/ OVERFLOW CHARACTERS
	.END
[\].
ARCHIV002
	.TITLE	ARCHIVE
/
/   8 SEP 78 (002; PDH) ADD SOME INSTRUCTIONS FOR ASSEMBLY PARAMETERS
/  15 AUG 77 - PAUL HENDERSON
/
/  MAINLINE TO INVOKE THE PROGRAM SEGMENTS TO PERFORM THE ARCHIVING OF
/  ALL OF THE ASCII FILES (150 MAX) IN A PARTICULAR UFD, THEN DELETE
/  THESE FILES FROM THE UFD.
/
/  DEFAULT ASSEMBLY (NO PARAMETERS) PRODUCES PROGRAM SEGMENTS FOR A
/  TASK TO RUN UNDER MULTIACCESS (XVM/RSX V1B), USING THE FP15
/  FLOATING POINT PROCESSOR.  TO ASSEMBLE FOR XVM/RSX V1A, THE SYMBOL
/NOMAC=1	MUST BE DEFINED.  TO ASSEMBLE FOR USE WITHOUT FP15,
/NOFPP=1	MUST BE DEFINED.
/
	.GLOBL	GNAMES,ORDER,SAVE
/
ARCHIVE	JMS*	GNAMES		/ GET NAMES OF ASCII FILES
	JMS*	ORDER		/ ARRANGE THEM IN ALPHABETIC ORDER
	JMS*	SAVE		/ SAVE THEM IN THE 'ARCHIVE' FILE,
				/ THEN DELETE THEM.
	CAL	(10		/ THEN EXIT
	.END	ARCHIVE
[\].
ARK@@@JOB
$JOB 73 T=5 UFD=RK1<ARK>
$MSG 'ARK' JOB TO ASSEMBLE AND TASK BUILD 'ARK...'
$MAC ERB_.IOERR 006,.PCK 002
$MAC ERB_ARCHIV 002
$MAC ERB_GNAMES 006
$MAC BERP_NOFPP PRM,ORDER 007
$MAC BERP_NOFPP PRM,SAVE 011
$TKB
NRM
 }
ARK...
 }
350
 }
TDV(10000)
 }
ARCHIV,.IOERR,.PCK
 }
GNAMES:ORDER:SAVE
 }
 }
 
$END
[\].
DEARCH007
	.TITLE	DEARCH
/
/  12 SEP 78 (007; PDH) OOPS!  WE FORGOT 1ST CHARACTER OF NAME.
/  12 SEP 78 (006; PDH) CONVERT TO NEW SYSTEM ROUTINES 'UN.PCK' & '.SIXPK'
/  20 OCT 77 (005; PDH) CONVERT TO TDV FUNCION FOR MULTIACCESS
/   1 SEP 77 (004; PDH) CREATE 'NAMES ...' FILE ON INPUT
/  26 AUG 77 - PAUL HENDERSON
/
/  PROGRAM TO DE-ARCHIVE AN ARCHIVED FILE -- IE. READ IT AND PRODUCE
/  SEPARATE DISK FILES.  IT WILL ALSO PRODUCE FILE 'NAMES ...' WHICH IS
/  A LIST OF ALL FILES DE-ARCHIVED.
 
	.DEC
TTO=13			/ ERROR MESSAGE OUTPUT
DK=15			/ DISK LUN (OUTPUT FILES)
DT=19			/ DECTAPE INPUT ARCHIVED FILE
	.OCT
X10=10
IDX=ISZ
 
	.GLOBL	.IOERR
	.GLOBL	UNP.IN,UN.PCK,SIX.IN,.SIXPK			/(006)
 
DEARCH	CAL	XFRCMD		/ GET TDV COMMAND LINE
	JMS	WTFOR
	LAC	(LINE+2
	JMS*	UNP.IN		/ INITIALIZE THE UNPACK		/(006)
	LAC	(DTNAME						/(006)
	JMS*	SIX.IN		/ AND FILE NAME PACK ROUTINES	/(006)
	LAC	(IMAGE+1					/(006)
	DAC*	(X10		/ POINTER FOR START OF FILE NAME
	LAC	EOFCODE+1
	DAC	LINE+21		/ ENSURE THAT THERE IS A CARRIAGE RETURN
 
CK4SP	JMS*	UN.PCK		/ UNPACK A CHARACTER		/(006)
	JMP	ERR1		/ LINE TERMINATOR; NO FILE NAME	/(006)
	SAD	(40		/ IS IT A SPACE?
	JMP	SPFND
	JMP	CK4SP
 
SPFND	JMS*	UN.PCK						/(006)
	JMP	ERR1		/ LINE TERMINATOR TOO EARLY	/(006)
	SAD	(40
	JMP	SPFND		/ FLUSH OUT ALL SPACES
	JMP	SVCHR		/ 1ST NON-SPACE CHAR IN AC	/(007)
 
	.EJECT
GETCHR	JMS*	UN.PCK		/ UNPACK FILE NAME CHARACTER	/(006)
	JMP	OPENIF		/ STOP AT END OF LINE		/(006)
SVCHR	DAC*	X10		/ SAVE IN CASE NEEDED LATER	/(007)
	JMS*	.SIXPK		/ PACK UP IN .SIXBT		/(006)
	JMP	GETCHR						/(006)
 
OPENIF	CAL	SEEK		/ OPEN INPUT FILE ON DECTAPE	/(006)
	CAL	WAITFR
	LAC	EV
	SMA
	JMP	FOUND		/ FILE FOUND.  PROCEED HAPPILY
	SAD	(-13
	JMP	ERR2		/ FILE NOT FOUND ERROR
	JMS*	.IOERR		/ OTHER FATAL ERROR
 
ERR1	CAL	WRER1		/ 'NO INPUT FILE NAME SUPPLIED'
	JMP	EXIT
 
ERR2	DZM*	X10		/ ENSURE EVEN COUNT & NO GARBAGE /(006)
	LAC	(IMAGE-1					/(006)
	TCA							/(006)
	TAD*	(X10		/ CALCULATE CORRECT HEADER	/(006)
	ALSS	10						/(006)
	XOR	(3		/ IMAGE ASCII MODE		/(006)
	DAC	IMAGE		/ STORE HEADER			/(006)
	CAL	WRER2A		/ 'FILE '			/(006)
	CAL	WRER2B		/ (FILE NAME AND EXTENSION)
	CAL	WRER2C		/ ' NOT FOUND'
EXIT	JMS	WTFOR		/ WAIT FOR MESSAGE TO BE PRINTED
	CAL	(10		/ THEN EXIT
 
	.EJECT
FOUND	CAL	ENTERN		/ OPEN OUTPUT FILE 'NAMES ...'
	JMS	WTFOR
	JMP	RDLOOP		/ THEN DUMP FIRST PART OF INPUT INTO IT
 
GETNAM	JMS	READ		/ READ FILE NAME
	JMP	.-1		/ IGNORE '[\].' IF FOUND HERE!
	LAC	(LINE+2						/(006)
	JMS*	UNP.IN		/ INITIALIZE UNPACK		/(006)
	LAC	(NAME		/ AND FILE NAME ROUTINES	/(006)
	JMS*	SIX.IN						/(006)
 
PCKNAM	JMS*	UN.PCK		/ UNPACK A CHARACTER		/(006)
	JMP	OPENOF		/ OPEN OUTPUT FILE WHEN READY	/(006)
	JMS*	.SIXPK		/ PACK THE CHARACTER		/(006)
	JMP	PCKNAM
 
OPENOF	CAL	ENTER		/ OPEN OUTPUT FILE ON DISK	/(006)
	JMS	WTFOR
 
RDLOOP	JMS	READ		/ READ LINE OF INPUT FILE
	JMP	ENDFIL		/ '[\].' SIGNIFIES INTERNAL END-OF-FILE
	CAL	WRITE
	JMS	WTFOR
	JMP	RDLOOP
 
ENDFIL	CAL	CLOSDK		/ CLOSE DISK FILE
	JMS	WTFOR
	JMP	GETNAM		/ GO PROCESS NEXT NAME (OR EOF)
 
	.EJECT
/  SUBROUTINE TO READ A RECORD FROM THE DECTAPE INPUT FILE, CHECKING
/  FOR END OF FILE DATA MODE AND INTERNAL END-OF-FILE '[\].'
 
/  CALLING SEQUENCE:
 
/	JMS	READ		/ READ RECORD INTO 'LINE'
/	(RETURN IF '[\].')
/	(NORMAL RETURN)
 
/  WHEN PHYSICAL END OF FILE IS DETECTED, THE PROGRAM ANNOUNCES
/  ITS COMPLETION AND EXITS.
 
READ	XX
	CAL	RDTAPE		/ READ RECORD FROM DECTAPE LUN
	JMS	WTFOR
	LAC	LINE
	AND	(7
	SAD	(5		/ CHECK FOR PHYSICAL END-OF-FILE
	JMP	FINIS
	LAC	LINE+2
	SAD	EOFCODE		/ CHECK FOR '[\].', THE INTERNAL
	SKP			/ END-OF-FILE CODE
	JMP	NOTEOF
	LAC	LINE+3
	SAD	EOFCODE+1
	SKP			/ '[\].' FOUND.  DON'T INDEX RETURN POINTER
NOTEOF	IDX	READ		/ NOT EOF.  INDEX TO NORMAL RETURN.
	JMP*	READ
 
/  PHYSICAL END-OF-FILE HAS BEEN DETECTED ON DECTAPE.
 
FINIS	CAL	CLOSDT		/ CLOSE DECTAPE FILE JUST TO BE TIDY
	JMS	WTFOR
	CAL	WRFINI		/ 'DE-ARCHIVING COMPLETE'
	JMS	WTFOR
	CAL	(10
 
/  SUBROUTINE TO WAIT FOR EVENT VARIABLE
 
WTFOR	XX
	LAC	EV		/ PERFORM QUICK CHECK SO WE
	SNA
	CAL	WAITFR		/ ONLY WAIT WHEN NECESSARY
	LAC	EV
	SPA
	JMS*	.IOERR		/ COMPLAIN ABOUT BAD EV
	JMP*	WTFOR
 
	.EJECT
/  CAL PARAMETER BLOCKS , CONSTANTS, AND VARIABLES
 
WAITFR	20;	EV
XFRCMD	37;	EV;	LINE; 22
WRER1	2700;	EV;	TTO; 2; E1MSG
WRER2A	2700;	0; 	TTO; 2; E2AMSG
WRER2B	2700;	0;	TTO; 3; IMAGE
WRER2C	2700;	EV;	TTO; 2; E2CMSG
SEEK	3200;	EV;	DT;DTNAME .BLOCK 3
ENTERN	3300;	EV;	DK; .SIXBT 'NAMES@...'
ENTER	3300;	EV;	DK;NAME   .BLOCK 3
WRITE	2700;	EV;	DK; 2; LINE
	.EJECT
CLOSDK	3400;	EV;	DK
CLOSDT	3400;	EV;	DT
RDTAPE	2600;	EV;	DT; 2; LINE; 100
WRFINI	2700;	EV;	TTO; 2; FINI
E1MSG	E1-.*400+2;EV; .ASCII 'NO FILE NAME SUPPLIED'<15> ;E1=.
E2AMSG	E2A-.*400+2; 0; .ASCII 'FILE '<175> ;E2A=.
TENS=DT/12	/ GAME TO ALLOW ASSEMBLER GENERATION OF DT LUN
UNITS=TENS*12*777777+DT
 
E2CMSG	E2C-.*400+2; 0; .ASCII ' NOT FOUND ON L'
	.ASCII	'UN ' ; .LOC .-1
	60+TENS*200+60+UNITS*2
	.ASCII	<15> ;E2C=.
FINI	FI-.*400+2; 0; .ASCII 'DE-ARCHIVING COMPLETE'<15> ;FI=.
EOFCODE	.ASCII	'[\].'<15>
LINE	.BLOCK	100
IMAGE=LINE+22
	.END	DEARCH
[\].
DRK@@@JOB
$JOB 73 T=5 UFD=RK1<ARK>
$MSG 'DRK' JOB TO ASSEMBLE AND TASK BUILD 'DRK...'
$MAC ERB_.IOERR 006,.PCK 002,UN.PCK 002,.SIXPK 001
$MAC ERB_DEARCH 007
$TKB
NRM
 }
DRK...
 }
350
 }
TDV(10000)
 }
DEARCH,.PCK,.IOERR,UN.PCK,.SIXPK
 }
 }
 
$END
[\].
GNAMES006
	.TITLE	GNAMES
/
/  20 OCT 77 (005; PDH) CONVERT TO MULTIACCESS TDV FUNCTION
/   1 SEP 77 (004; PDH) DELETE 'NAMES ...' BEFORE WE START
/  15 AUG 77 - PAUL HENDERSON
/
/  PROGRAM SEGMENT TO GET THE NAMES OF ALL ASCII FILES IN THE UFD
/  ASSOCIATED WITH LUN 15, AND STORE THE NAMES IN 5/7 ASCII IN
/  FILE 'NAMES ...' ON LUN 17.  THIS FILE WILL BE PROCESSED BY
/  LATER STEPS IN THE TASK.
/
/  IF THE TASK IS TO RUN ON A NON-MULTIACCESS SYSTEM, THE PARAMETER
/NOMAC=1	/ MUST BE DEFINED.
/
	.DEC
TTY=13
ILUN=15
OLUN=17
	.OCT
MA.LOF=222	/ .SCOM LOCATION CONTAINING CURRENT MULTIACCESS LUN OFFSET
LUFD1=304	/ .SCOM LOCATION CONTAINING POINTER TO LUN-UFD TABLE
ECLA=641000
/
	.GLOBL	GNAMES,.IOERR
/
	.EJECT
GNAMES	XX
	CAL	XFRCMD		/ NEEDED ONLY TO MAKE SYSTEM HAPPY
	CAL	WAITFR
	.IFUND	NOMAC
	LAC	(MA.LOF
	DAC	SPYADR
	CAL	SPY
	LAC	SPYCON		/ ADDING CURRENT MULTIACCESS LUN OFFSET
	TAD	(ILUN		/ TO VIRTUAL LUN
	DAC	ABSLUN		/ GIVES ABSOLUTE (REAL) LUN VALUE
	.ENDC
	LAC	(LUFD1
	DAC	SPYADR
	CAL	SPY		/ GET POINTER TO LUN-UFD TABLE
	LAW	-1
	TAD	SPYCON
	TAD	ABSLUN		/ CALCULATE POINTER TO CORRECT UFD ENTRY
	DAC	SPYADR
	CAL	SPY		/ GET UIC ASSOCIATED WITH LUN 'ILUN'
/
CKOLUN	LAC	(OLUN		/ MAKE SURE WE HAVE FILE-ORIENTED
	DAC	HINF+2		/ SECONDARY DEVICE
	CAL	HINF
	JMS	WTFOR
	AND	(040000		/ SELECT 'DIRECTORY-ORIENTED' BIT
	SZA
	JMP	CKILUN
	CAL	WRNODR		/ 'LUN "OLUN" NOT FILE-ORIENTED'
ABEND	JMS	WTFOR		/ WAIT UNTIL MESSAGE IS FINISHED
	CAL	(10		/ THEN EXIT
/
	.EJECT
CKILUN	LAC	(ILUN
	DAC	HINF+2		/ MUST HINF CORRECT LUN
	CAL	HINF
	JMS	WTFOR
	LAC	EV
	ALSS	11		/ FROM THE INFORMATION RETURNED BY HINF,
	AND	(700000		/ EXTRACT THE PHYSICAL UNIT NUMBER
	DAC	UNIT
	LAC	EV
	AND	(77		/ EXTRACT DEVICE TYPE
	DAC	DKTYPE		/ PUT IT IN 'GET' CPB
	SAD	(2
	JMP	RK		/ RF
	SAD	(3
	JMP	RP		/ RP
	SAD	(24
	JMP	RK		/ RK
/
	CAL	WRNODK		/ 'DEVICE ON LUN "ILUN" IS NOT A DISK'
	JMP	ABEND
/
RP	LAC	(47040		/ START BLOCK OF MFD ON RP DISK
	SKP
RK	LAC	(1777		/ START BLOCK ON RF & RK
GETMFD	JMS	BLK2PL		/ CONVERT BLOCK NUMBERS TO PLATTER, ETC
	LAC	(374		/ AND FETCH IT INTO CORE
	PAL			/ DON'T SEARCH PAST END OF BLOCK
	CLX
MFD1	LAC	BUFFER,X	/ SEARCH MFD FOR DESIRED UFD ENTRY
	SAD	UIC
	JMP	UICFND
	AXS	4		/ INDEX TO NEXT MFD ENTRY
	JMP	MFD1
	LAC	ENDBLK		/ END OF MFD BLOCK - UIC NOT FOUND
	SMA			/ IS THERE ANOTHER MFD BLOCK?
	JMP	GETMFD		/ YES.  FETCH IT AND CONTINUE SEARCH
/
NOUFD	LAW	-33		/ ILLEGAL UIC
	JMS*	.IOERR
/
	.EJECT
UICFND	LAC	BUFFER+1,X	/ POINT TO UFD START BLOCK
	SPA
	JMP	NOUFD		/ NO UFD, ALTHOUGH ENTRY IS IN MFD
	DAC	UFD
	CAL	DELETE		/ DELETE 'NAMES ...' BEFORE WE START
	CAL	WAITFR		/ DON'T BE UPSET IF IT IS ABSENT.
	CAL	ENTER		/ OPEN OUTPUT FILE 'NAMES ...'
	JMS	WTFOR
/
	LAC	UIC		/ BEGIN THE 'NAMES ...' FILE WITH THE UIC
	JMS	THREEC
	XOR	(15*2		/ END WITH CARRIAGE RETURN
	DAC	OLINE+3
	CAL	WRNAME
	JMS	WTFOR
/
	LAC	UFD
/
GETUFD	JMS	BLK2PL		/ FETCH FIRST BLOCK OF UFD
	LAC	(400
	PAL
	CLX
MOVE	LAC	BUFFER,X	/ BECAUSE WE NEED TO USE SUBROUTINE 'BLK2PL'
	DAC	UFD,X		/ LATER, WE MUST EMPTY 'BUFFER'
	AXS	1
	JMP	MOVE
	DZM	XR		/ BEGIN WITH ZERO INDEX REGISTER
	CLX
/
	.EJECT
UFD1	LAC	UFD,X		/ IS THERE A FILE NAME?
	SNA
	JMP	NXTFIL
	LAC	UFD+4,X		/ IS IT SEQUENTIAL OR RANDOM ACCESS?
	SPA
	JMP	NXTFIL		/ RANDOM ACCESS NOT PROCESSED
	LAC	UFD+3,X		/ GET NUMBER OF FIRST BLOCK OF FILE
	SPA
	JMP	NXTFIL		/ TRUNCATED FILES ARE NOT PROCESSED
	JMS	BLK2PL		/ GET FIRST BLOCK
	LAC	BUFFER
	SPA
	JMP	NXTFIL		/ ILLEGAL WORD PAIR COUNT!!
	AND	(777		/ INCLUDE DATA VALIDITY BITS WITH MODE
	SAD	(2
	SKP
	JMP	NXTFIL		/ NOT PURE ASCII
	LAC	XR		/ RESTORE XR LOST DURING 'GET'
	PAX
	LAC	UFD,X		/ GET FIRST 3 CHARACTERS OF FILE NAME
	JMS	THREEC		/ PACK INTO ASCII IN OUTPUT BUFFER
	LAC	UFD+1,X		/ GET CHARACTERS 4-6 OF FILE NAME
	LMQ
	JMS	SIXTO7
	ALSS	10
	XOR	OLINE+3
	DAC	OLINE+3		/ 4TH CHARACTER
	JMS	SIXTO7
	RCL
	XOR	OLINE+3
	DAC	OLINE+3		/ 5TH CHARACTER
	JMS	SIXTO7
	ALSS	13
	DAC	OLINE+4		/ 6TH CHARACTER
/
	.EJECT
	LAC	UFD+2,X		/ GET EXTENSION (CHARACTERS 7-9)
	LMQ
	JMS	SIXTO7
	ALSS	4
	XOR	OLINE+4
	DAC	OLINE+4		/ 7TH CHARACTER
	JMS	SIXTO7
	LRSS	3		/ 8TH CHARACTER STRADDLES 2 WORDS
	XOR	OLINE+4
	DAC	OLINE+4
	ECLA!LLSS 3
	ALSS	17
	DAC	OLINE+5		/ SECOND HALF OF 8TH CHARACTER
	JMS	SIXTO7
	ALSS	10
	XOR	OLINE+5		/ 9TH CHARACTER
	XOR	(15*2		/ CARRIAGE RETURN IS 10TH CHARACTER
	DAC	OLINE+5
	CAL	WRNAME		/ WRITE OUT THE FILE NAME
	JMS	WTFOR
/
NXTFIL	LAC	(370
	PAL
	LAC	XR
	PAX			/ RESTORE XR LOST DURING I/O
	AAC	10
	DAC	XR		/ UPDATE VALUE FOR NEXT TIME
	AXS	10
	JMP	UFD1		/ PROCESS NEXT NAME IN THIS UFD BLOCK
	LAC	UFD+377
	SMA			/ END OF CURRENT UFD BLOCK.  IS THERE ANOTHER?
	JMP	GETUFD		/ YES.  FETCH AND PROCESS IT.
/
	CAL	CLOSE		/ CLOSE SECONDARY OUTPUT FILE
	JMS	WTFOR
	JMP*	GNAMES		/ THEN RETURN TO MAINLINE.
/
	.EJECT
THREEC	XX
	LMQ			/ PREPARE TO PACK 3 CHARACTERS
	JMS	SIXTO7		/ FETCH A CHARACTER CONVERTED TO 7-BITS
	ALSS	13
	DAC	OLINE+2		/ STORE FIRST CHARACTER
	JMS	SIXTO7
	ALSS	4
	XOR	OLINE+2		/ BLEND IN 2ND CHARACTER
	DAC	OLINE+2
	JMS	SIXTO7
	CLQ!LRSS 3		/ 3RD CHARACTER STRADDLES 2 WORDS
	XOR	OLINE+2
	DAC	OLINE+2
	LACQ
	DAC	OLINE+3
	JMP*	THREEC
/
/  SUBROUTINE TO EXTRACT A 6-BIT CHARACTER FROM THE MQ AND
/  CONVERT IT TO A 7-BIT CHARACTER IN THE AC.
/
SIXTO7	XX
	ECLA!LLS 1		/ SHIFT IN HIGH-ORDER BIT OF CHARACTER
	SNA
	XOR	(2		/ CONVERT FROM 6- TO 7-BIT, AS APPROPRIATE
	LLS	5		/ SHIFT IN REST OF CHARACTER
	JMP*	SIXTO7		/ RETURN WITH CHARACTER IN AC
/
/  SUBROUTINE TO CONVERT BLOCK NUMBERS TO PLATTER NUMBERS AND
/  READ THE BLOCK INTO CORE
/
BLK2PL	XX
	LMQ
	ECLA!LLSS 10
	XOR	UNIT		/ MUST INCLUDE PHYSICAL UNIT NUMBER
	DAC	CTRLTB		/ PUT UNIT & PLATTER # IN CONTROL TABLE
	LACQ
	DAC	DKADDR		/ PUT DISK ADDRESS IN CONTROL TABLE
	CAL	GETDK		/ FETCH THE BLOCK
	JMS	WTFOR
	JMP*	BLK2PL
/
WTFOR	XX
	CAL	WAITFR
	LAC	EV
	SPA
	JMS*	.IOERR
	JMP*	WTFOR
/
	.EJECT
ABSLUN	ILUN		/ CHANGED TO REAL LUN FOR LUN MAPPING
XR;SPY	31;	0;SPYADR;SPYCON;UIC=SPYCON
XFRCMD	37;	EV;	BUFFER; 100
WAITFR	20;	EV
BUFFER	.BLOCK	377;ENDBLK
UFD	.BLOCK	400
HINF	3600;	EV;	XX
GETDK	13000;	EV;	1; CTRLTB;DKTYPE
CTRLTB;DKADDR;	BUFFER;	400
DELETE	3500;	EV;	ILUN; .SIXBT 'NAMES@...'
ENTER	3300;	EV;	OLUN; .SIXBT 'NAMES@...'
WRNAME	2700;	EV;	OLUN; 2; OLINE
CLOSE	3400;	EV;	OLUN
OLINE	3002;	0;	.BLOCK 4
WRNODK	2700;	EV;	TTY; 2; MSG6
WRNODR	2700;	EV;	TTY; 2; MSG3
TENS=OLUN/12
UNITS=TENS*12*777777+OLUN
/
MSG3	M3-.*400+2;EV; .ASCII 'LUN '
	60+TENS*200+60+UNITS*20; 0
	.ASCII	' NOT FILE-ORIENTED'<15> ;M3=.
TENS=ILUN/12
UNITS=TENS*12*777777+ILUN
/
MSG6	M6-.*400+2;UNIT; .ASCII 'DEVICE ON LUN '
	60+TENS*200+60+UNITS*20; 0
	.ASCII	' IS NOT A DISK'<15> ;M6=.
	.END
[\].
NOFPP@PRM
	.TITLE	NOFPP
/
/  11 SEP 78 - PAUL HENDERSON
/
/  PARAMETER FILE FOR ASSEMBLY OF THE 'ARK' PROGRAM MODULES WHEN
/  ASSEMBLING FOR NO FLOATING POINT PROCESSOR.
/
NOFPP=1
	.EOT
[\].
ORDER@007
	.TITLE	ORDER
/
/   8 SEP 78 (007; PDH) CONDITIONALIZE FOR NON-FP15 USE
/  20 OCT 77 (006; PDH) CHANGE TTY TO LUN 13
/  22 AUG 77 (005; PDH) CHANGE TO 150 FILES
/  17 AUG 77 (004; PDH) FIX BIG IN SORTING ALGORITHM (COMPARE)
/  17 AUG 77 (003; PDH) TRY TO PROGRAM AROUND FPP INVALID REMAINDER PROBLEM
/  16 AUG 77 - PAUL HENDERSON
/
/  PROGRAM SEGMENT TO READ THE 'NAMES ...' FILE, RE-ORDER IT IN
/  ALPHABETIC ORDER, AND RE-WRITE IT, PRECEEDED BY THE UIC AND
/  COUNT OF THE NUMBER OF FILES.
/
/  TO ASSEMBLE FOR NON-FLOATING POINT USE, THE SYMBOL		/(007)
/NOFPP=1	MUST BE DEFINED.				/(007)
 
	.IFUND	NOFPP						/(007)
FPP=1;	.ENDC							/(007)
	.DEC
TTY=13
DK=17
NFILES=150			/ NUMBER OF FILES WE CAN PROCESS.
	.OCT
I=400000			/ FPP INDIRECT ADDRESSING
ESB=710500
IRS=711000
IMP=711400
IDV=712000
ILD=713000
ELD=713100
IST=713600
UNSWQ=715270
BZA=716601
BMA=716602
BPA=716604
IDX=ISZ
INC=ISZ
 
	.EJECT
	.GLOBL	ORDER,.IOERR
/
ORDER	XX
	CAL	SEEK		/ OPEN FILE 'NAMES ...' FOR INPUT
	JMS	WTFOR
	CAL	READ		/ READ THE 'UIC' RECORD
	JMS	WTFOR
	LAC	LINE+2
	DAC	UIC		/ SAVE IT FOR LATER OUTPUT
	LAC	LINE+3
	DAC	UIC+1
	DZM	INDEX		/ INITIALIZE FILE COUNTER,
	LAC	(BUF
	DAC	BUFPT		/ BUFFER POINTER,
	LAW	-NFILES
	DAC	COUNT		/ AND BUFFER OVERFLOW COUNTER
/
	.EJECT
RDNAME	CAL	READ		/ READ A FILE NAME RECORD
	JMS	WTFOR
	LAC	LINE
	AND	(7
	SAD	(5
	JMP	SORT		/ SORT THE NAMES WHEN ALL HAVE BEEN READ
/
	LAC	(4		/ EACH FILE NAME IS STORED IN ASCII (4 WDS)
	PAL
	CLX
/
MOVE	LAC	LINE+2,X	/ MOVE THE ASCII LINE FROM THE INPUT BUFFER
	DAC*	BUFPT		/ TO THE SORTING BUFFER
	IDX	BUFPT
	AXS	1
	JMP	MOVE
	INC	INDEX		/ COUNT THE FILE NAME
	ISZ	COUNT		/ MAKE SURE THE BUFFER DOES NOT OVERFLOW
	JMP	RDNAME
/
	.EJECT
SORT	CAL	CLOSE		/ CLOSE INPUT FILE
	JMS	WTFOR
	LAC	INDEX
	SNA
	JMP	NOFILES		/ THERE MUST BE AT LEAST ONE FILE
/
AGN	LAC	INDEX
	TCA
	DAC	COUNT
	DAC	SORTED		/ SET SORTED = .TRUE.
	CLX
	ISZ	COUNT
	SKP
	JMP	DONE		/ A SINGLE ITEM CANNOT BE SORTED
/
LOOP	JMS	COMPARE		/ COMPARE FIRST WORDS OF ASCII FILE NAME
	LAC	BUF+0,X
	LAC	BUF+4,X
/
	JMS	COMPARE		/ COMPARE SECOND WORDS
	LAC	BUF+1,X
	LAC	BUF+5,X
/
	JMS	COMPARE		/ COMPARE THIRD WORDS
	LAC	BUF+2,X
	LAC	BUF+6,X
/
	JMS	COMPARE		/ COMPARE FOURTH WORDS
	LAC	BUF+3,X
	LAC	BUF+7,X
	JMP	NEXT		/ THESE FILE NAMES ARE IN ORDER. CHECK NEXT ONES
/
	.EJECT
/  SUBROUTINE TO COMPARE THE VALUES INDICATED BY THE ARGUMENTS.  IF THE
/  SECOND ARGUMENT IS LOWER IN ALPHABETIC SEQUENCE THAN THE FIRST ONE,
/  THE TWO SETS OF VALUES WILL BE SWAPPED.  IF THE SECOND IS HIGHER,
/  THEN THE NEXT TWO SETS WILL BE COMPARED.  THE SUBROUTINE RETURNS
/  ONLY IF THE TWO VALUES ARE EQUAL.
/
/  CALLING SEQUENCE:
/
/	JMS	COMPARE
/	LAC	FIRST ARG
/	LAC	SECOND ARG	/ (RETURNS HERE IF EQUAL)
/
COMPARE	XX
	XCT*	COMPARE		/ GET FIRST ARGUMENT
	IDX	COMPARE
	.IFDEF	NOFPP						/(007)
	CLL!RAR			/ TO SIMPLIFY THE COMPARISON,	/(007)
	DAC	F1		/ ENSURE THAT BOTH QUANTITIES	/(007)
	CLA!RAL			/ ARE POSITIVE.  SAVE OVERFLOW	/(007)
	.ENDC			/ BIT IN NEXT LOCATION		/(007)
	DAC	F1+1		/ AND STORE IT FOR FPP USE
	XCT*	COMPARE		/ GET SECOND ONE
	.IFDEF	NOFPP						/(007)
	CLL!RAR			/ SAME PROCESS HERE AS ABOVE	/(007)
	DAC	F2						/(007)
	CLA!RAL							/(007)
	.ENDC							/(007)
	DAC	F2+1
	.IFDEF	FPP						/(007)
	ELD;	F1
	ESB;	F2
	BZA;	RETURN
	BPA;	SWAP		/ IF 2ND 'LESS' THAN FIRST, SWAP THEM.
	JMP	NEXT		/ 2ND 'GREATER' THAN FIRST.  OK.
	.ENDC							/(007)
	.EJECT
	.IFDEF	NOFPP						/(007)
	LAC	F2						/(007)
	TCA							/(007)
	TAD	F1		/ 'F1 - F2'			/(007)
	SNA							/(007)
	JMP	CBIT17		/ EQUAL.  CHECK BIT 17		/(007)
	SMA							/(007)
	JMP	SWAP		/ F2 .LT. F1; SWAP THEM		/(007)
	JMP	NEXT		/ F2 .GT. F1; ORDER IS OK	/(007)
 
CBIT17	LAC	F2+1		/ CHECK BIT 17 OF ARGUMENTS	/(007)
	TCA							/(007)
	TAD	F1+1						/(007)
	SPA			/ SAME CHECKS, DIFFERENT ORDER	/(007)
	JMP	NEXT		/ F2 .GT. F1; ORDER IS OK	/(007)
	SZA							/(007)
	JMP	SWAP		/ F2 .LT. F1; SWAP THEM		/(007)
	.ENDC							/(007)
RETURN	JMP*	COMPARE		/ RETURN IF EQUAL
/
F1	0; 0
F2	0; 0
TEMP=COMPARE
/
	.EJECT
SWAP	DZM	SORTED		/ INDICATE BUFFER NOT SORTED
/
	LAC	BUF,X
	DAC	TEMP
	LAC	BUF+4,X		/ THE FILE NAME IN THE NTH BUFFER POSITION
	DAC	BUF,X		/ HAS A HIGHER ALPHABETIC SEQUENCE THAN
	LAC	TEMP		/ THAN THE NAME IN THE (N+1)TH BUFFER
	DAC	BUF+4,X		/ POSITION.  EXCHANGE THEM.
/
	LAC	BUF+1,X		/ THIS IS KNOWN AS A BUBBLE SORT.
	DAC	TEMP
	LAC	BUF+5,X
	DAC	BUF+1,X
	LAC	TEMP
	DAC	BUF+5,X
/
	LAC	BUF+2,X
	DAC	TEMP
	LAC	BUF+6,X
	DAC	BUF+2,X
	LAC	TEMP
	DAC	BUF+6,X
/
	LAC	BUF+3,X
	DAC	TEMP
	LAC	BUF+7,X
	DAC	BUF+3,X
	LAC	TEMP
	DAC	BUF+7,X
/
NEXT	AXR	4
	ISZ	COUNT
	JMP	LOOP
	LAC	SORTED		/ END OF LOOP.  ARE THE NAMES SORTED?
	SNA
	JMP	AGN		/ NO.  DO THE LOOP AGAIN.
/
	.EJECT
/  FILE NAMES HAVE BEEN ARRANGED IN ALPHABETIC ORDER.  CONVERT THE VALUE
/  IN 'INDEX' TO DECIMAL, AND WRITE OUT THE ORDERED FILE NAMES, PRECEEDED
/  BY THE UIC AND FILE NAME COUNT.
/
DONE	CAL	ENTER		/ OPEN OUTPUT FILE
	LAC	UIC
	DAC	LINE+2		/ MOVE SAVED UIC TO OUTPUT LINE BUFFER
	LAC	UIC+1
	DAC	LINE+3
	LAC	(2002		/ HEADER FOR UIC AND FILE COUNT
	DAC	LINE
	JMS	WTFOR
	CAL	WRITE
	JMS	WTFOR
/
	LAW	-4
	DAC	COUNT		/ CONVERT 4 DIGITS TO DECIMAL
	LAC	(20
	DAC	LEAD0		/ SET LEADING ZERO FLAG
	LAC	(DIVISR
	DAC	FPADR1
	LAC	(ANS		/ INITIALIZE ADDRESSES FOR FPP
	DAC	FPADR2
	.IFDEF	FPP						/(007)
	ILD;	INDEX		/ BEGIN WITH THE 'INDEX' VALUE
	IST;	TEMP		/*** SAVE FOR LATER COMPARISON
/
CONVRT	IDV;FPADR1
	IST;FPADR2		/ QUOTIENT IS NEXT CONVERTED DIGIT
/***	UNSWQ;	0		/ REMAINDER IS NEXT DIVIDEND
	IMP;	I+FPADR1	/*** PROGRAM AROUND INVALID REMAINDER
	IRS;	TEMP
	IST;	TEMP		/*** END OF THIS FUDGE
	.ENDC							/(007)
	.EJECT
	.IFDEF	NOFPP						/(007)
	LAC	INDEX		/ MOVE VALUE TO			/(007)
	DAC	TEMP		/ TEMPORARY LOCATION		/(007)
CONVRT	LAC*	FPADR1		/ GET NEXT DIVISOR		/(007)
	DAC	DVISOR						/(007)
	LAC	TEMP		/ DO A DIVISION		/(007)
	CLL							/(007)
	IDIV							/(007)
DVISOR	XX							/(007)
	DAC	TEMP		/ SAVE REMAINDER		/(007)
	LACQ							/(007)
	DAC*	FPADR2		/ STORE ANOTHER ANSWER DIGIT	/(007)
	.ENDC							/(007)
	IDX	FPADR1		/ POINT TO NEXT DIVISOR
	IDX	FPADR2
	ISZ	COUNT
	JMP	CONVRT
/
	.EJECT
	LAC	ANS		/ NOW PACK UP THE CONVERTED ASCII
	JMS	CVRT
	CLQ!LRSS 7
	LAC	ANS+1
	JMS	CVRT
	ALSS	4
	EAE	2000		/ MQ <= AC!MQ
	LAC	ANS+2
	JMS	CVRT
	RCR; RCR; RCR		/ SHIFT OUT NUMERICAL PART
	OMQ
	DAC	LINE+2		/ STORE 2-1/2 CHARACTERS IN LINE BUFFER
	LAC	ANS+2
	CLQ!LRSS 3		/ PLACE NUMERICAL PART IN MQ
	LAC	ANS+3
	XOR	(60		/ LAST DIGIT NEVER LEADING ZERO
	ALSS	10
	OMQ
	XOR	(15*2		/ END WITH CARRIAGE RETURN
	DAC	LINE+3
	CAL	WRITE		/ WRITE OUT FILES COUNT
	JMS	WTFOR
/
	.EJECT
	LAC	(3002		/ CORRECT HEADER FOR FILE NAMES
	DAC	LINE
	LAC	INDEX
	TCA
	DAC	COUNT
	LAC	(BUF
	DAC	BUFPT
/
NEXTL	LAC	(4		/ 4 ASCII WORDS PER FILE NAME
	PAL
	CLX
MOVE2	LAC*	BUFPT		/ MOVE 4 WORDS FROM SORTING BUFFER
	IDX	BUFPT
	DAC	LINE+2,X	/ TO LINE BUFFER
	AXS	1
	JMP	MOVE2
	CAL	WRITE		/ THEN OUTPUT THE FILE NAME
	JMS	WTFOR
	ISZ	COUNT
	JMP	NEXTL
	CAL	CLOSE		/ CLOSE OUTPUT FILE WHEN COMPLETE
	JMS	WTFOR
	JMP*	ORDER
/
/  SUBROUTINE TO CONVERT A BINARY VALUE TO A SINGLE IMAGE ASCII
/  CHARACTER, CONVERTING LEADING ZEROS TO SPACES.
/
CVRT	XX
	SZA
	DZM	LEAD0		/ CLEAR LEADING ZERO FLAG IF NON-ZERO VALUE
	SNA
	XOR	LEAD0		/ THIS WILL CONVERT '0' TO ' '
	XOR	(60		/ CONVERT TO ASCII
	JMP*	CVRT
/
NOFILES	CAL	WRNOFL		/ 'NO FILE NAMES TO PROCESS'
	JMS	WTFOR
	CAL	(10
/
/  SUBROUTINE TO WAIT FOR AN EVENT VARIABLE
/
WTFOR	XX
	LAC	EV
	SNA
	CAL	WAITFR		/ WAIT ONLY IF EV=0
	LAC	EV
	SPA
	JMS*	.IOERR		/ COMPLAIN ABOUT BAD EVENT VARIABLE
	JMP*	WTFOR
/
	.EJECT
/  CAL PARAMETER BLOCKS AND VARIABLES
/
WAITFR	20;	EV
SEEK	3200;	EV;	DK; .SIXBT 'NAMES@...'
READ	2600;	EV;	DK; 2; LINE; 6
CLOSE	3400;	EV;	DK
ENTER	3300;	EV;	DK; .SIXBT 'NAMES@...'
WRITE	2700;	EV;	DK; 2; LINE
WRNOFL	2700;	EV;	TTY; 2; NFLNMS
NFLNMS	NF-.*400+2;EV; .ASCII 'NO FILE NAMES TO PROCESS'<15> ;NF=.
	.EJECT
UIC	.BLOCK	2
LINE	.BLOCK	6
BUF	.BLOCK	NFILES*4
BUFPT;INDEX;COUNT;SORTED;LEAD0
	.IFDEF	NOFPP						/(007)
FPADR1;FPADR2;	.ENDC						/(007)
	.DEC
DIVISR	1000;	100;	10;	1; .OCT
ANS	.BLOCK	4
	.END
[\].
SAVE@@011
	.TITLE	SAVE
/
/  11 SEP 78 (011; PDH) CONDITIONALIZE FOR NON-FP15 USE
/   2 AUG 78 (010; PDH) WAIT 5 SECONDS IF NODE COUNT IS LOW (<8)
/   2 AUG 78 (009; PDH) IT RUNS OUT OF NODES ANYWAY.  FIND OUT WHY.
/   1 AUG 78 (008; PDH) TRY TO PREVENT POOL OF EMPTY NODES FROM EXHAUSTING
/  20 OCT 77 (007; PDH) DON'T DELETE FILES IF 'DT' DEVICE NOT FILE-ORIENTED
/   8 SEP 77 (006; PDH) GENERATE CORRECT 8'S & 9'S IN 'OCTDEC'
/   1 SEP 77 (005; PDH) IGNORE 'FILE ALREADY OPEN' ERRORS
/  22 AUG 77 (004; PDH) DELETE THE SPECIFIED FILES AFTER ARCHIVING
/  22 AUG 77 (003; PDH) CONVERT OCTAL DATE TO DECIMAL; INCLUDE FILE NAME
/			WITH INDIVIDUAL FILES
/  22 AUG 77 (002; PDH) EXORCISE SOME BUGS
/  17 AUG 77 - PAUL HENDERSON
/
/  PROGRAM SEGMENT TO READ THE 'NAMES ...' FILE, PRODUCE THE
/  ARCHIVE FILE ON DECTAPE, THEN DELETE THE FILES FROM DISK.
 
/  TO ASSEMBLE FOR NON-FLOATING POINT USE, THE SYMBOL		/(011)
/NOFPP=1	/ MUST BE DEFINED.				/(011)
 
	.IFUND	NOFPP						/(011)
FPP=1;	.ENDC							/(011)
	.DEC
TTY=13
DKF=15				/ DISK LUN CONTAINING FILES
DKN=17				/ DISK LUN CONTAINING 'NAMES ...' FILE
DT=19				/ DECTAPE LUN RECEIVES ARCHIVE FILE
	.OCT
POOL=240		/ LISTHEAD OF POOL OF EMPTY NODES	/(008)
I=400000
IDX=ISZ
ECLA=641000
IRS=711000
IMP=711400
IDV=712000
ILD=713000
IST=713600
UNSWQ=715270
 
	.EJECT
	.GLOBL	SAVE,.IOERR
 
SAVE	XX
	LAC	(SKP		/ 'SKP' WHEN SAVING FILES
	DAC	SVTEST		/ 'NOP' WHEN DELETING
	LAC	(3200
	DAC	SEEKFL		/ ENSURE 'SEEK' CPB
	CAL	SEEKNM		/ OPEN 'NAMES ...' FILE FOR INPUT
	LAC	(DKN
	DAC	READFL+2	/ READ 'NAMES' FILE VIA 'FILES' CPB
	JMS	WTFOR
	CAL	READFL		/ READ UIC
	JMS	WTFOR
	LAC	FLINE+2
	DAC	NLINE+2		/ MOVE UIC TO PLACE EXPECTED BY 'SEVTO6'
	LAC	FLINE+3
	DAC	NLINE+3
	JMS	SEVTO6		/ CONVERT FROM 5/7 ASCII IN 'NLINE'
	LAC	NAME.1		/ TO 6-BIT IN 'NAME.1'
	DAC	DT.EXT		/ HAVE EXTENSION FOR ARCHIVED FILE
/
	.EJECT
	CAL	DATE
	LAC	DATE+3		/ GET DAY OF MONTH
	JMS	OCTDEC		/ CONVERT TO .SIXBT DECIMAL
	LLSS	11		/ SHIFT TO CORRECT PLACE
	DAC	DT.NM1
/
	LAC	DATE+4		/ GET YEAR
	JMS	OCTDEC		/ CONVERT TO .SIXBT DECIMAL
	LRSS	11		/ YEAR NOW LEFT JUSTIFIED IN MQ
/
	LAC	DATE+2		/ GET MONTH
	PAX
	LAC	MONTHS-1,X	/ GET 2-CHARACTER MONTH DESIGNATOR
	LRSS	6		/ INCLUDE 1 CHARACTER WITH OTHERS IN MQ
	XOR	DT.NM1		/ AND OTHER WITH PREVIOUS EFFORT
	DAC	DT.NM1
	LACQ
	DAC	DT.NM2		/ OUTPUT FILE NAME NOW COMPLETELY READY
/
	CAL	ENTER		/ OPEN OUTPUT FILE ON DECTAPE
	JMS	WTFOR
	CAL	WRITE		/ WRITE OUT THE 'UIC' LINE
	JMS	WTFOR
/
	JMS	TRANSF		/ MOVE THE REST OF THE 'NAMES' FILE
	CAL	CLOSEN		/ THEN CLOSE THE 'NAMES' FILE
	JMS	WTFOR
/
	LAC	(DKF		/ NOW POINT CPB AT 'FILES' LUN
	DAC	READFL+2
DLE1	CAL	SEEKNM		/ OPEN 'NAMES' FILE AGAIN
	JMS	WTFOR
	CAL	READNM		/ READ 'UIC' TO BYPASS IT
	JMS	WTFOR
	CAL	READNM		/ BYPASS FILE COUNT
	JMS	WTFOR
/
	.EJECT
TLOOP	CAL	READNM		/ READ NEXT FILE NAME
	JMS	WTFOR
	LAC	NLINE
	AND	(7
	SAD	(5
	JMP	FINISH
	XCT	SVTEST
	SKP
	CAL	WRNAME		/ INCLUDE FILE NAME IN ARCHIVE FILE
	JMS	SEVTO6		/ CONVERT FROM .ASCII TO .SIXBT
 
/  NOW WE MUST ENSURE THAT THE SYSTEM HAS ENOUGH SMALL NODES TO
/  CARRY ON, IN CASE 'DELETE' TENDS TO EXHAUST THE SUPPLY.  WE
/  MAKE THE ASSUMPTION THAT 8 NODES ARE ENOUGH.  THIS ROUTINE
/  REMAINS IN A LOOP UNTIL THERE ARE MORE THAN 8 NODES IN THE POOL.
 
	JMP	LM8		/ REQUEST 'NODCNT' IF		/(008)
 
NONODE	CAL	RQNDCT		/ NOT ENOUGH SMALL NODES	/(009)
WT5SEC	CAL	MK5S		/ THEN DELAY FOR 5 SECONDS	/(010)
	CAL	WAITFR						/(010)
	LAC	EV		/ MUST HAVE GOOD EV BEFORE	/(010)
	SPA			/ WE ATTEMPT TO PROCEED		/(010)
	JMP	WT5SEC						/(010)
 
LM8	LAW	-10		/ MUST BE AT LEAST 8 NODES IN	/(009)
	DAC	COUNT		/ POOL OF EMPTY NODES		/(008)
	LAC	(POOL		/ BEFORE WE PROCEED		/(008)
 
CNTNODE	DAC	SPYADR						/(008)
	CAL	SPY		/ FOLLOW LISTHEADS, COUNTING NODES /(008)
	LAC	SPYCON		/ GET FORWARD POINTER		/(008)
	SAD	(POOL		/ END OF POOL ALREADY?		/(008)
	JMP	NONODE		/ YES.  ATTEMPT TO COMPLAIN	/(008)
	ISZ	COUNT						/(008)
	JMP	CNTNODE						/(008)
 
	CAL	SEEKFL		/ OPEN THE FILE TO BE TRANSFERRED
	JMS	WTFOR		/	(OR DELETE IT)
	XCT	SVTEST
	JMP	TLOOP		/ NO TRANSFER OR CLOSE WHEN DELETING
	JMS	TRANSF		/ MOVE IT
	CAL	CLOSEF		/ CLOSE THE INPUT FILE
	JMS	WTFOR
	JMP	TLOOP		/ PROCESS THE NEXT FILE
 
	.EJECT
FINISH	CAL	CLOSEN		/ CLOSE 'NAMES' FILE
	JMS	WTFOR
	XCT	SVTEST
	JMP	EXIT		/ DELETION OF FILES COMPLETE
	CAL	CLOSDT		/ CLOSE DECTAPE FILE
	JMS	WTFOR
	CAL	WRMSG1		/ ANNOUNCE ARCHIVING COMPLETE
	CAL	HINF
	JMS	WTFOR		/ DON'T DELETE FILES
	AND	(040000		/ IF OUTPUT (DT) DEVICE IS
	SNA
	JMP	NODLET		/ NOT FILE-ORIENTED
/
	DZM	NOT		/ ERASE 'NOT' PART OF
	DZM	NOT+1		/ 'FILES NOT DELETED' MESSAGE
	LAC	(NOP
	DAC	SVTEST		/ CLEAR 'SAVE' TEST
	LAC	(3500		/ CHANGE THE 'SEEK' TO 'DELETE'
	DAC	SEEKFL
	JMP	DLE1		/ THEN DELETE ALL OF THE SPECIFIED FILES
/
NODLET	CAL	WRNODR		/ 'DEVICE ON LUN "DT" IS NOT FILE-ORIENTED'
/
EXIT	CAL	DLENAM		/ DELETE THE 'NAMES ...' FILE
	JMS	WTFOR
	CAL	WRMSG2		/ 'FILES (NOT) DELETED'
	JMS	WTFOR
	JMP*	SAVE		/ THEN RETURN TO CALLING PROGRAM
/
	.EJECT
/  SUBROUTINE TO CONVERT FROM .ASCII IN 'NLINE' TO .SIXBT IN THE
/  CPB USED FOR SEEKING THE FILE TO BE ARCHIVED
/
SEVTO6	XX
	LAC	NLINE+2		/ GET FIRST WORD OF .ASCII
	LMQ
	ECLA!LLSS 10		/ SHIFT IN FIRST CHARACTER + 1 BIT OF 2ND
	RAR			/ THROW 7TH BIT AWAY
	LLSS	7		/ 2ND + 1 BIT OF 3RD
	RAR			/ THROW AWAY THE BIT
	LLSS	3		/ MSB OF 1ST CHAR NOW LOST; 1/2 OF 3RD FETCHED
	DAC	NAME.1
/
	LAC	NLINE+3
	LMQ
	LAC	NAME.1
	LLSS	3		/ OTHER 1/2 OF 3RD
	DAC	NAME.1		/ FIRST 3 CHARACTERS NOW READY
	LLSS	10		/ 4TH CHARACTER
	RAR
	LLSS	6		/ 5TH
	DAC	NAME.2
	LAC	NLINE+4
	LMQ
	ECLA!LLSS 1
	LAC	NAME.2
	LLSS	6		/ 6TH
	DAC	NAME.2
/
	ECLA!LLSS 10		/ 7TH
	RAR
	LLSS	3		/ 1/2 OF 8TH
	DAC	EXT
	LAC	NLINE+5
	LMQ
	LAC	EXT
	LLSS	4		/ 2ND 1/2 OF 8TH
	RAR
	LLSS	6		/ 9TH
	DAC	EXT		/ EXTENSION NOW READY
	JMP*	SEVTO6
/
	.EJECT
/  SUBROUTINE TO CONVERT AN OCTAL (BINARY) NUMBER TO DECIMAL, SELECT THE
/  TWO LEAST SIGNIFICANT DIGITS, AND PLACE THEM IN THE AC & MQ
/  SO THAT SHIFTING LEFT BY 3 PLACES THEM IN THE AC (.SIXBT CODE).
/
/  CALLING SEQUENCE:
/
/	LAC	BINVAL
/	JMS	OCTDEC
/	(RETURN)		/ .SIXBT VALUES IN AC, MQ
/
OCTDEC	XX
	DAC	TRANSF
	LAW	-4
	DAC	WTFOR		/ CONVERT 4 DIGITS
	LAC	(DIVISR
	DAC	FPADR1
	LAC	(ANS
	DAC	FPADR2
	.IFDEF	FPP						/(011)
	ILD;	TRANSF
CONVRT	IDV;FPADR1
	IST;FPADR2		/ QUOTIENT IS NEXT CONVERTED DIGIT
/***	UNSWQ;	0		/ REMAINDER IS NEXT DIVIDEND
	IMP;	I+FPADR1	/*** PROGRAM AROUND HARDWARE FAULT
	IRS;	TRANSF		/***
	IST;	TRANSF		/*** END OF FUDGE
	.ENDC							/(011)
	.IFDEF	NOFPP						/(011)
CONVRT	LAC*	FPADR1						/(011)
	DAC	DVISOR		/ GET NEXT DIVISOR		/(011)
	LAC	TRANSF						/(011)
	CLL							/(011)
	IDIV							/(011)
DVISOR	XX							/(011)
	DAC	TRANSF		/ SAVE REMAINDER		/(011)
	LACQ							/(011)
	DAC*	FPADR2		/ SAVE PRODUCT (ANSWER DIGIT)	/(011)
	.ENDC							/(011)
	IDX	FPADR1		/ POINT TO NEXT DIVISOR
	IDX	FPADR2
	ISZ	WTFOR
	JMP	CONVRT
 
	.EJECT
	LAC	ANS+3		/ GET LEAST SIGNIFICANT ANSWER DIGIT
	XOR	(60		/ CONVERT TO .SIXBT ASCII
	CLQ!LRSS 6		/ SHIFT INTO MQ
	LAC	ANS+2		/ GET OTHER DESIRED DIGIT
	XOR	(60		/ CONVERT IT TO .SIXBT ASCII
	LLSS	3
	JMP*	OCTDEC		/ LEAVE WITH ANSWER IN AC, MQ
 
	.IFDEF	NOFPP						/(011)
FPADR1;FPADR2;	.ENDC						/(011)
	.DEC
DIVISR	1000;	100;	10;	1
ANS	.BLOCK	4;	.OCT
	.EJECT
/  SUBROUTINE TO TRANSFER A FILE FROM 'DKF' TO 'DT'
/
TRANSF	XX
TR1	CAL	READFL		/ READ A RECORD
	JMS	WTFOR
	LAC	FLINE
	AND	(7
	SAD	(5		/ CHECK FOR END OF FILE
	JMP	ENDFILE
	CAL	WRITE		/ WRITE IT TO DECTAPE
	JMS	WTFOR
	JMP	TR1
/
ENDFILE	CAL	WREOF		/ '[\].'
	JMS	WTFOR
	JMP*	TRANSF
/
/  SUBROUTINE TO WAIT FOR EVENT VARIABLE, AND COMPLAIN IF NOT OK.
/
WTFOR	XX
	LAC	EV		/ PERFORM QUICK CHECK
	SNA
	CAL	WAITFR		/ ONLY WAIT WHEN NECESSARY
	LAC	EV
	SPA
	SAD	(-54		/ OPEN FILE IS PROBABLY A BATCH JOB
	JMP*	WTFOR
	SAD	(-6
	JMP*	WTFOR		/ IGNORE UNIMPLEMENTED FUNCTIONS
	JMS*	.IOERR		/ COMPLAIN ABOUT BAD EV
/
	.EJECT
/  CAL PARAMETER BLOCKS AND BUFFER SPACE
/
SPY	31;	0;SPYADR;SPYCON					/(008)
RQNDCT	01;	0; .SIXBT 'NODCNT' ; 0				/(008)
MK5S	13;	EV; 5; 2	/ MARK TIME FOR 5 SECONDS	/(010)
WAITFR	20;	EV
DATE	24;	0; .BLOCK 6
HINF	3600;	EV;	DT
SEEKNM	3200;	EV;	DKN; .SIXBT 'NAMES@...'
SEEKFL	3200;	EV;	DKF;NAME.1;NAME.2;EXT
READNM	2600;	EV;	DKN; 2; NLINE; 6
READFL	2600;	EV;	DKF; 2; FLINE; 70
CLOSEN	3400;	EV;	DKN
CLOSEF	3400;	EV;	DKF
CLOSDT	3400;	EV;	DT
ENTER	3300;	EV;	DT;DT.NM1;DT.NM2;DT.EXT
WRNAME	2700;	0;	DT; 2; NLINE
WRITE	2700;	EV;	DT; 2; FLINE
WREOF	2700;	EV;	DT; 2; EOF
WRMSG1	2700;	0;	TTY; 2; MSG1
WRMSG2	2700;	EV;	TTY; 2; MSG2
WRNODR	2700;	0;	TTY; 2; NODIR
DLENAM	3500;	EV;	DKN; .SIXBT 'NAMES@...'
EOF	2002; 0; .ASCII '[\].'<15>
MSG1	M1-.*400+2;EV; .ASCII '*** ARCHIVING FINISHED ***'<15> ;M1=.
MSG2	M2-.*400+2;RQFLAG
	.ASCII	'***   FILES '
NOT	.ASCII	'NOT'		/ THIS IS USUALLY ZEROED BEFORE OUTPUT
	.ASCII	' DELETED   ***'<15> ;M2=.
TENS=DT/12
UNITS=TENS*12*777777+DT
/
NODIR	ND-.*400+2;COUNT					/(008)
	.ASCII	'LUN '
	60+TENS*200+60+UNITS*20; 0
	.ASCII	' NOT FILE-ORIENTED'<15> ;ND=.
SVTEST	NOP
NLINE	.BLOCK	6
FLINE	.BLOCK	70
MONTHS	.SIXBT	'@JA'
	.SIXBT	'@FE'
	.SIXBT	'@MR'
	.SIXBT	'@AP'
	.SIXBT	'@MY'
	.SIXBT	'@JN'
	.SIXBT	'@JL'
	.SIXBT	'@AU'
	.SIXBT	'@SE'
	.SIXBT	'@OC'
	.SIXBT	'@NV'
	.SIXBT	'@DC'
/
	.END
[\].
TF1@@@SRC
C     .TITLE TF1
C
C   1 AUG 78 - PAUL HENDERSON, UNIVERSITY OF WATERLOO
C
C  WATRAN PROGRAM TO CREATE 150 SOURCE FILES TO DEBUG THE 'ARK'
C  TASK WHEN IT IS SUPPOSED TO BE COUNTING SMALL NODES.
C
      INTEGER DK/27/,TT/4/
      INTEGER INDEX/1/
      CHARACTER*9 FNAME
C
   1  WRITE (TT,*) ' *** TDV>ASS 27 RK1<SCR>'
      PAUSE 1
      WRITE (TT,*) ' PROGRAM IS NOW EXECUTING'
C
      DO 3 INDEX=1,150
      WRITE (FNAME,99) INDEX
      CALL OPEN (DK,FNAME)
      DO 2 K=1,40
      WRITE (DK,98)
   2  CONTINUE
      CALL CLOSE (DK)
   3  CONTINUE
      STOP 1
  99  FORMAT ('A000  DAT',T1,I4)
  98  FORMAT (' 1',T80,'XX')
      END
[\].
TF2@@@SRC
C     .TITLE TF2
C
C  12 SEP 78 (002; PDH) CONVERT FROM WATRAN TO DEC FORTRAN
C   1 AUG 78 - PAUL HENDERSON, UNIVERSITY OF WATERLOO
C
C  FORTRAN PROGRAM TO CREATE 150 SOURCE FILES TO DEBUG THE 'ARK'
C  TASK WHEN IT IS SUPPOSED TO BE COUNTING SMALL NODES.
C
      INTEGER DK,TT
      INTEGER INDEX
      INTEGER HUNDS, TENS, ONES
      REAL FNAME(1)
      DATA DK/27/,TT/4/
C
   1  WRITE (TT,299)
      PAUSE 1
      WRITE (TT,298)
C
      DO 3 INDEX=1,150
      HUNDS = INDEX/100
      TENS  = (INDEX - HUNDS*100)/10
      ONES  = INDEX - HUNDS*100 - TENS*10
      ENCODE (5,FNAME,99) HUNDS, TENS, ONES
      CALL ENTER (DK,FNAME(1),'DAT')
      DO 2 K=1,40
      WRITE (DK,98)
   2  CONTINUE
      CALL CLOSE (DK)
   3  CONTINUE
      STOP 1
  99  FORMAT ('A',3I1,' ')
  98  FORMAT (' 1',T80,'XX')
 299  FORMAT (' *** TDV>ASS 27 RK1<SCR>')
 298  FORMAT (' PROGRAM IS NOW EXECUTING')
      END
[\].
UN.PCK002
	.TITLE	UN.PCK
/
/   4 JUL 78 (002; PDH) ADD ENTRIES 'UNP.SV' & 'UNP.RS'
/  23 JUN 78 - PAUL HENDERSON
/
/  ROUTINE TO UNPACK CHARACTERS, ONE AT A TIME.  NO CHECK IS MADE
/  TO DETERMINE IF A LINE TERMINATOR HAS ALREADY BEEN PROCESSED
/  SINCE THE LAST INITIALIZATION CALL.
/
/  CALLING SEQUENCES:
/
/  1) TO INITIALIZE -
/
/	LAC	(ADDRESS OF CHARACTERS TO BE UNPACKED
/	JMS*	UNP.IN
/	(RETURN)
/
/  2) TO UNPACK A CHARACTER -
/
/	JMS*	UN.PCK		/ RETURNS WITH CHARACTER IN AC
/	(RETURN IF LINE TERMINATOR)
/	(NORMAL RETURN)
/
/  3) TO SAVE CURRENT STATUS -
/
/	JMS*	UNP.SV
/	ADDRESS OF 2-WORD SAVE-RESTORE BUFFER
/	(RETURN)
/
/  4) TO RESTORE A PREVIOUS STATUS -
/
/	JMS*	UNP.RS
/	ADDRESS OF 2-WORD SAVE-RESTORE BUFFER
/	(RETURN)
 
IDX=ISZ			/ INDEX A POINTER (NEVER SKIPS)
 
	.EJECT
	.GLOBL	UNP.IN
 
UNP.IN	XX
	DAC	BUFADR		/ SAVE POINTER TO INPUT BUFFER ADDRESS
	LAC	(FIRSTC
	DAC	SWING		/ SET UP BRANCH ADDRESS
	JMP*	UNP.IN
 
BUFADR
 
	.GLOBL	UNP.SV						/(002)
 
UNP.SV	XX							/(002)
	LAC*	UNP.SV		/ FETCH SAVE AREA ADDRESS	/(002)
	IDX	UNP.SV		/ INDEX TO RETURN ADDRESS	/(002)
	DAC	UNP.IN		/ HANDY LOCATION FOR POINTER	/(002)
	LAC	BUFADR						/(002)
	DAC*	UNP.IN		/ SAVE LINE BUFFER ADDRESS	/(002)
	IDX	UNP.IN						/(002)
	LAC	SWING						/(002)
	DAC*	UNP.IN		/ SAVE 'SWING' ADDRESS		/(002)
	JMP*	UNP.SV						/(002)
 
 
	.GLOBL	UNP.RS						/(002)
 
UNP.RS	XX							/(002)
	LAC*	UNP.RS		/ GET SAVE AREA ADDRESS		/(002)
	IDX	UNP.RS						/(002)
	DAC	UNP.IN		/ HANDY LOCATION FOR POINTER	/(002)
	LAC*	UNP.IN						/(002)
	IDX	UNP.IN						/(002)
	DAC	BUFADR		/ RESTORE LINE BUFFER ADDRESS	/(002)
	LAC*	UNP.IN						/(002)
	DAC	SWING						/(002)
	JMP*	UNP.RS						/(002)
 
	.EJECT
	.GLOBL	UN.PCK
 
UN.PCK	XX
	LAC*	BUFADR		/ GET WORD TO BE PROCESSED
	JMP*	SWING		/ GO PROCESS IT
 
SWING	FIRSTC
	AND	(177		/ CHOP TO 7 BIT CHARACTER
	SAD	(15		/ CHECK FOR CARRIAGE RETURN
	SKP
	SAD	(175		/ AND FOR ALT MODE
	JMP*	UN.PCK		/ LINE TERMINATOR EXIT
	IDX	UN.PCK		/ INDEX TO NORMAL EXIT
	JMP*	UN.PCK
 
FIRSTC	LRS	13
	JMS	SWING
 
..2	LRS	4
	JMS	SWING
 
..3	DAC	SWING		/ HANDY PLACE FOR TEMPORARY STORAGE
	IDX	BUFADR		/ INDEX TO 2ND WORD OF PAIR
	LAC*	BUFADR
	LMQ
	LAC	SWING		/ RETRIEVE FRONT OF SPLIT CHARACTER
	LLS	3		/ UNSPLIT IT
	JMS	SWING
 
..4	LRS	10
	JMS	SWING
 
..5	IDX	BUFADR		/ INDEX TO NEXT WORD PAIR
	RAR
	JMS	SWING
	JMP	FIRSTC
	.END
[\].