Directory of image this file is from
This file as a plain text file

/PDP-11 TO -8 DECTAPE CONVERTER
/THIS IS A PROGRAM FOR CONVERTING BASIC PLUS DECTAPES TO EITHER
/TSS/8 BASIC TAPES OR OS/8 FORMAT FILES,
/AND FOR CONVERTING OS/8 FILES TO BASIC + FILES.
/SPECIFICATION OF ONE OF THE FOLLOWING OPTIONS MEANS BASIC+/TSS/8 BASIC
/CONVERSION IS DESIRED.	OUTPUT DEVICE MUST BE DECTAPE IN SUCH A CASE.
/NO FILES SHOULD BE INDICATED FOR OUTPUT.
/	/S	CONVERT TO STRINGS REGUARDLESS OF WHETHER OR NOT
/		DATA CONTAINS VALID NUMERIC INFO.
/	/N	ALLOW ONLY NUMBERS (GENERATE ERROR MESSAGE IF NON-NUMERIC
/		DATA IS USED)
/	/R	REGULAR MODE -- IF AN ERROR OCCURS WHEN CONVERTING
/		TO A NUMBER, THEN CONVERT TO A STRING
/	/T	SIMULATE AN INPUT LINE WHEN ENTERING DATA FROM THE BASIC+
/		DECTAPE. SPACES ARE NOT IGNORED AND COMMAS DO NOT
/		TERMINATE DATA ENTRIES WHEN THIS OPTION IS USED.
/		THIS OPTION CAN BE USED WITH ANY OF THE ABOVE.
/DURING STRING CONVERSION, ALL ILLEGAL CHARACTERS 
/(BACKSPACE, CONTROL CHARS, TAB, ...)
/ARE IGNORED.  OPTIONS INVOLVING OS/8 FILES ARE:
/	/L	GIVE DIRECTORY LISTING OF BASIC+ DECTAPE
/	/I	INPUT FILE IS A BASIC+ FILE, OUTPUT FILE IS IN OS/8 FORMAT
/	/O	OUTPUT FILE IS A BASIC+ DECTAPE FILE,
/INPUT FILE IS IN OS/8 FORMAT.
/THE DEFAULT OPTION IS /I.  THE DEFAULT OUTPUT DEVICE IS TTY:.
/
/
/
/EDITED BY FERNE HALLEY FOR NON-EAE
/
/EDITED BY STEVE POULSEN OF OMSI 8-JAN-73
/	CHANGED SO THAT CHECKING FOR DECTAPE INPUT/OUTPUT
/	IS DONE CORRECTLY...
/	ALSO, DECTAPE TURN-AROUND PROBLEM WAS CORRECTED
/	IN CASE YOUR DECTAPE DRIVES ARE SLOPPY.
/
/EDITED BY BOB ANKENEY OF OMSI 30-JUL-74
/	CHANGED SO THAT DECTAPE DRIVE NUMBERS ARE
/	CALCULATED CORRECTLY.  ALSO GIVES
/	DIRECTORY LISTINGS OF BASIC+ TAPES AND
/	ALLOWS EXTENSIONS TO BE SPECIFIED.
/	IF NO OUTPUT DEVICE IS SPECIFIED WITH
/	EITHER THE /L OR /I OPTIONS, TTY: IS
/	ASSUMED.
/
/
/EDITED BY R.L.COLE  SOFTWARE ENGINEERING, ANN ARBOR, MICHIGAN
/	ALSO BY DAVE HARTSIG    ---DITTO---
/	DECTAPE ROUTINE MODIFIED FOR FASTER EXECUTION ON PDP-5F
/	VARIOUS BUGS ELIMINATED,  TO WIT:
/	BAD CHOICE OF LOCATION TO READ IN (11 TAPE) DIRECTORY LISTING
/	DEVICE HANDLER
/	BAD CHOICE OF STARTING POINT FOR COMMAND LINE SCANNING
/	(BLEW ON *A:FIL.ASC<   ETC  )
/	CORRECTED MISSING LINE IN ERROR PRINT SECTION
/
/
/SAVE PIP11 AS FOLLOWS:
/SAVE SYS:PIP11;12000=4002

/COMMAND DEFINITIONS
DTLA=6766
DTXA=6764
DTSF=6771
DTRA=6761
DTRB=6772
DTLB=6774
CDF=6201
CIF=6202
L0002=CLL CLA CML RTL
L7776=STA CLL RAL
L7775=CLL STA RTL
FIXTAB

/SUBROUTINE OPTION DEFINITIONS
DECODE=5
ENTER=3
CLOSE=4
FETCH=1
LOOKUP=2
INQUIRE=12
READ=20
WRITE=40

/BUFFERS
END=6400
PBMBL=END
PBM=PBMBL+10	/THERE ARE AFEW NON-PBM WORDS AT THE BEGINNING OF THE PBM
FBM=PBM+110	/THE PBM IS 110 BYTES LONG
INPUTS=FBM+110	/THE FBM IS ALSO 110 BYTES LONG
INBUF=200
OUTBUF=INBUF+600
BUFFER=OUTBUF
DIRLOC=END
CDBUF=1200	/COMMAND DECODER'S BUFFER STORED HERE IN FIELD 0

/IMPORTANT WORDS
MONITR=7600
JBSTAT=7746
ALTM=7642
OPT2=7644
INPUT=7605
OUTPUT=7600
DATEP=7666

/THESE ARE THE MONTHS FOR DATE CONVERSION
DECIMAL
JAN=0
FEB=JAN+31
MAR=FEB+28
APR=MAR+31
MAY=APR+30
JUN=MAY+31
JUL=JUN+30
AUG=JUL+31
SEP=AUG+31
OCT=SEP+30
NOV=OCT+31
DEC=NOV+30
OCTAL
/PAGE 0 FIELD 1
FIELD 1

/INDEX REGISTERS
*10
X1,	0
X2,	0
X3,	0
X4,	0

*20
CHRCTR,	0
CTR,	0
CHAR,	0
CHRAD,	0
MULT,	0
ENTC=.
TOPR50,	0
ENTE=.
BOTR50,	0
NAMPT,	0
INCT,	0
OUTCT,	0
BLCTRI,	0
SW,	0
TEMP1,	0	/USED WHEN CODEING INTO OR DECODING FROM OS/8 FORMAT
TEMP2,	0
TEMPG1,	0	/USED WHEN DECODING 11 DECTAPE
TEMPG2,	0
GETW,	0	/THESE 6 LINES MUST BE IN THIS ORDER!!
TEMPB1,	0	/USED WHEN GETTING COMPLEMENT OBVERSE
TEMPB2,	0	/ALSO USED AS TEMPORARY STORAGE FOR DIRECTORY LISTINGS
TEMPB3,	0
TEMPB4,	0
TEMBP1,	0	/USED WHEN CODEING 11 DECTAPE
TEMBP2,	0
TEMBP3,	0
LITCTR,	0
LITPTR,	0
LITCT,	0
DECIMAL
R50A,	1600
	40
	1
OCTAL
NAMEI,	0	/NAME IN RADIX-50
	0
	0
	0
	0	/EXTENSION IN RADIX-50
	0
DATEB,	0	/THIS IS THE DATE
	0
	0	/THIS IS THE MODE (ALWAYS 0)
	0
STRTBL,	0	/THIS IS THE FIRST BLOCK OF THE FILE
	0	/IT WILL ALWAYS BE +
NUMBL,	0	/THIS IS THE LENGTH OF THE FILE
	0
ENDBL,	0	/THIS IS THE LAST BLOCK OF THE FILE (MAY BE -)
	0
	233	/THIS IS THE PROTECTION (ALWAYS 233)
	0
THEBLK,	0
MIN,	0
SM,	0
UNPAK,	0
PAKLOC,	0
UNPAKL,	0
UNPAKN,	0
TEMP,	0
EMPTY,	0
USR,	7700
HANDLR,	0
HNDLOC,	0		/LOCATION OF DIRECTORY OUTPUT BUFFER
OUTPT=.
BE,	0
MCHAR=.
DE,	0
BLKS=.
PE,	0
BLCTS=.
PL,	0
NUMBLK=.
PN,	0
CATBL=.
SE,	0
CATEN=.
SN,	0
ENTFZ=.
T1,	0
ENTZ=.
ID,	0
PBMPT=.
ID1,	0
WDPT=.
ID2,	0
BITCTG=.
SRH,	0
BITCTS=.
SRM,	0
DIRECT=.
SRL,	0
CURBLK=.
TS,	0
IOWD=.
TS1,	0
CHKEBL=.
TS2,	0
CURDIR=.
BITCTR,	0
GETSUB,	0
BMOFF,	0
IOSW,	0
BITCT,	0
CHKEEN,	0
LSRPTR,	SUBLSR
SHLPTR,	SUBSHL
MQAPTR,	SUBMQA
MQLPTR,	SUBMQL
MULXX,	MQMULT
DVIXX,	MQDIV
SHLMQP,	MQSHFT
LSR=	JMS I LSRPTR
SHL=	JMS I SHLPTR
MQA=	JMS I MQAPTR
MQL=	JMS I MQLPTR
MQLMUY=	JMS I MULXX
MQLDVI=	JMS I DVIXX
MQLSHL=	JMS I SHLMQP
*2000
/THIS BEGINS THE MAIN ROUTINE
START,	CDF	/SET UP JOB STATUS
	TAD [4002
	DCA JBSTAT
	CDF CIF 10	/BACK TO THIS FIELD
DECAGN,	JMS I USR	/GO GET THE COMMAND STRING
	DECODE
	5200		/USE SPECIAL MODE
	7700		/NO TENTATIVE FILES
	TLS		/CLEAR FLAG?
	TAD INPUT	/SEE IF ANYTHING IS THERE
	TAD OUTPUT
	SNA CLA
	JMP FIN
	TAD OPT2	/SEE IF INPUT OR OUTPUT IS 11 DECTAPE
	AND [1000
	DCA IOSW	/THIS IS NON-0 IF OUTPUT IS 11 TAPE
	TAD IOSW
	SNA CLA
	TAD (INPUT-OUTPUT	/SAVE POINTER TO THE 11 FILE SPECIFICATION
	TAD (OUTPUT
	DCA IOWD
	JMS GETDN	/GO GET DECTAPE DRIVE NUMBER
	TAD OPT2-1
	RAR
	SZL CLA CLL
	JMP DIR

GETEXT,	TAD	(CDBUF	/EXAMINE CD BUFFER FOR OUTPUT EXTENSION   [SE]
	DCA TEMP	/AROUND HERE
	TAD IOSW	/INPUT OR OUTPUT?
	SZA CLA
	JMP EXTSN	/OUTPUT
	TAD (CDBUF	/INPUT, SEARCH FOR '<'
	DCA TEMP
	JMS GTCHAR	/GET CHAR FROM C.D. BUFFER
	SNA
	JMP XTNSHN	/END OF BUFFER
	TAD (-"<
	SZA CLA
	JMP .-5
	TAD (6		/FOUND IT!
	TAD TEMP	/BUMP POINTER FOR SEARCH
	DCA TEMP	/FOR EXTENSION
EXTSN,	L7775
	DCA CTR		/3 CHARS TO EXT.
	JMS GTCHAR
	SNA
	JMP GOTIT	/NO EXTENSION SPECIFIED
	TAD (-".
	SZA CLA
	JMP .-5
EXTGET,	JMS GTCHAR	/EXTENSION FOLLOWS!!
	DCA TEMP2
	TAD TEMP2
	TAD (-"0	/<0?
	SPA
	JMP OPTCHK	/YES, CHECK FOR OPTION
	TAD (-12	/<=9?
	SPA
	JMP GOTCHR	/NUMBER.
	TAD [-7		/<A?
	SPA
	JMP GOTIT
	TAD (-32	/>Z?
	SMA
	JMP GOTIT
GOTCHR,	CLA
	TAD TEMP2
	DCA EXT3
	ISZ CTR
	JMP EXTGET
	TAD EXT3
	AND (77
	CLL RTL
	RTL
	RTL
	DCA EXT3
	JMP CONVRT
GOTIT,	CLA CLL		/EXT NOT 3 CHARS LONG.
	DCA EXT3
	JMP CONVRT
XTNSHN,	TAD (CDBUF+6	/NO OUTPUT DEVICE SPECIFIED
	DCA TEMP	/ON /I -- MAKE IT TTY: LATER
	JMP EXTSN
OPTCHK,	IAC		/IS IT A "/"?
	SNA
	JMP SLASH
	TAD [7		/NO, IS IT A "("
	SZA CLA
	JMP GOTIT	/NO, END OF EXT.
	JMS GTCHAR
	TAD (-")
	SZA CLA
	JMP .-3
	JMP EXTGET
SLASH,	JMS GTCHAR	/IGNORE OPTION
	CLA CLL
	JMP EXTGET

EXT3,	0

	PAGE
GTCHAR,	0		/GET A CHARACTER FROM
	CDF		/COMMAND DECODER'S BUFFER
	TAD I TEMP
	CDF 10
	ISZ TEMP
	TAD (-240	/IGNORE SPACES
	SNA
	JMP GTCHAR+1
	TAD (240
	JMP I GTCHAR

CONVRT,	TAD (-11	/CONVERT THE NAME AND EXT TO RAD 50
	DCA CHRCTR
	TAD IOWD
	IAC
	DCA CHRAD	/NAME STARTS HERE
	DCA SW
	TAD (NAMEI
	DCA NAMPT	/PUT RAD 50 OF NAME IN NAMEI
NXTWD,	L7775
	DCA CTR		/THREE CHARS TO A 16 BIT WORD
	DCA TOPR50
	DCA BOTR50
	TAD (R50A	/FOR CONVERTING TO R50
	DCA MULT
NXTC,	CLL IAC		/LAST CHAR OF EXT?
	TAD CHRCTR
	SZA CLA
	JMP .+3
	TAD (EXT3	/YES, GET FROM EXT3
	DCA CHRAD
	TAD I MULT
	DCA MULTI
	ISZ MULT	/GET NEXT MULTIPLIER
	JMS UNPAC	/GET THE NEXT CHARACTER
	JMP BLOOK	/DO LOOK UP WHEN DONE
	AND [77		/CUT OFF BOTTOM 6
	TAD [-60	/CONVERT TO R50 CODE
	SMA
	TAD [36-60
	TAD [60
	MQLMUY		/MULTIPLY BY CURRENT MULTIPLIER
MULTI,	0
	DCA MULTI	/SAVE HIGH ORDER
	CLL
	MQA		/DO A DOUBLE PRECISION ADD
	TAD BOTR50
	DCA BOTR50
	RAL
	TAD TOPR50
	TAD MULTI
	DCA TOPR50
	ISZ CTR
	JMP NXTC
	TAD BOTR50	/NOW STORE IN TWO BYTES
	AND [377
	DCA I NAMPT
	ISZ NAMPT
	TAD BOTR50
	MQL
	TAD TOPR50
	SHL;3
	DCA I NAMPT
	ISZ NAMPT
	JMP NXTWD	/BACK FOR MORE.

/NOW DO A LOOK UP OF THE INPUT/OUTPUT FILE ON THE 11 DECTAPE.
/THE CATALOG IS ON BLOCKS 102 AND 103.
/ALSO CHECKS FOR A "HOLE" FOR THE OUTPUT FILE NAME TO GO IN
BLOOK,	TAD (102	/INIT THE GETBYT ROUTINE
	DCA GBL
	DCA CHKEBL	/CLEAR CATALOG BLOCK NUMBER
	DCA ENTFZ	/NO BLANK SPACES TO START
	CLA IAC		/IGNORE PHYSICAL END OF FILE FOR LOOK UP
	DCA BLCTRI
	DCA ENTC	/CHECKS TO SEE IF FILE EXISTS
	TAD (GETWRD
	DCA GETW
	JMS CHKENT
	JMS CHKENT	/CATALOG IS TWO BLOCKS LONG
	TAD IOSW	/IF OUTPUT IS TO THE 11 DECTAPE THEN GO DO IT
	SZA CLA
	JMP OS8IN
	STA
	TAD ENTC	/SEE IF FILE EXISTS
	SZA CLA
	JMP COUFF	/COULDN'T FIND THE FILE
	STA
	DCA INCT	/INIT GETBYT FOR WHO EVER USES IT
	STA
	DCA LITCTR	/IN CASE OF A REVERSE, WELL BE READY
	TAD BLCTS
	DCA BLCTRI
	TAD BLKS
	DCA GBL
	JMP BLOOK2	/GO TO NEXT PAGE
	PAGE///////////////////////
BLOOK2,	TAD [GETA
	DCA GETNXT
	TAD OPT2	/WAS THERE ABASIC 4 OPTION?
	AND (2160
	SZA CLA
	JMP B4OUT	/YES SO BASIC FOUR FORMAT

	JMS GTHDLR	/GET DEVICE HANDLER
	TAD BLCTRO
	SNA
	IAC
	DCA BLCTRO	/MAYBE NOP THE OUTPUT COUNT
	DCA BLKCL
	TAD C7400	/INIT PUTWRD SUBROUTINE
	DCA OUTCT
	TAD [OUTBUF-1
	DCA X2
	TAD (PUTA
	DCA NXTCHR
CHRAGN,	JMS GETBYT	/GET NEXT CHAR
	AND [177	/SET BIT 5
	TAD [200
	JMS PUTBYT
	JMP CHRAGN

/SUBROUTINES:
/ROUTINE TO OUTPUT A BYTE IN OS8 FORMAT
PUTBYT,	0
	DCA CHAR
	TAD CHAR
	JMP I .+1
NXTCHR,	0
	TAD CHAR
	TAD (-232
	SZA CLA
	JMP I PUTBYT
	JMS PUTBYT	/COMES HERE WHEN DONE
	JMS PUTBYT	/MAKE SURE LAST GETS OUTPUT
	TAD OUTCT
	TAD (400
	SZA CLA
	JMS PUTALL	/PUT OUT LAST BLOCK IF NECESSARY
	TAD (OUTPUT+1
	DCA CLOSE1
	TAD OUTPUT
	JMS I USR	/CLOSE FILE
	CLOSE
CLOSE1,	0
BLKCL,	0
	JMP CLERR	/ERROR CLOSING FILE
FIN,	TAD ALTM	/END WITH ALT MODE?
	SMA CLA
	JMP DECAGN
	JMS CRLF
	CDF CIF
	JMP MONITR	/YES SO GO TO MONITR

RESET,	JMS NXTCHR
PUTA,	DCA TEMP1
	JMS NXTCHR
	DCA TEMP2
	JMS NXTCHR
	RTL;RTL
	AND C7400
	TAD TEMP1
	JMS PUTWRD
	TAD CHAR
	RTR;RTR;RAR
	AND C7400
	TAD TEMP2
	JMS PUTWRD
	JMP RESET	/THE ABOVE IS FOR PACKING INTO THE OS8 3CHARS/2 WORDS FORMAT

/PUT A WORD INTO OS8 OUTPUT BUFFER
PUTWRD,	0
	DCA I X2
	ISZ OUTCT
	JMP I PUTWRD		/NO PROBLEMS
	JMS PUTALL		/PUTO OUT THE BUFFER ON THE DEVICE
	TAD C7400		/AND REINIT
	DCA OUTCT
	TAD [OUTBUF-1
	DCA X2
	JMP I PUTWRD

/PUT THE BUFFER OUT ON THE DEVICE
PUTALL,	0
	TAD BLCTRO
	SNA CLA
	JMP NROD		/NO ROOM ON THE DEVICE
	TAD BLOCKO
	DCA BLKO
	CIF
	JMS I HANDLR		/CALL DEVICE HANDLER
	4210			/FUNCTION WORD
	OUTBUF
BLKO,	0
	SMA CLA
	ISZ BLKCL
	ISZ BLOCKO
	ISZ BLCTRO
C7400,	7400
	JMP I PUTALL

INQR,	0
	JMS I USR
	INQUIRE		/GET A DEVICE NUMBER
DEV,	0
	0
	0
	JMP I INQR	/OOPS!!
	TAD .-3		/RETURN WITH DEVICE #
	ISZ INQR
	JMP I INQR	/GET OUT OF HERE

	PAGE/////////////////////////////
B4OUT,	ISZ IOSW	/SET UP TO SAY "OUTPUT MUST BE DECTAPE"
	TAD GDR		/GET THE DRIVE NUMBER
	DCA PDR
	TAD OUTPUT+1
	SZA CLA
	JMP F4NF	/NO FILES ALLOWED?!
	DCA PBL		/FIRST BLOCK IS ALWAYS BLOCK 0
	TAD (-53	/INIT THE INPUT ROUTINE
	DCA CHRCTR	/THERE ARE 53(8) 3-WORD FLOATING POINT NUMBERS PER BLOCK
	TAD [OUTBUF-1	/OUTPUT BUFFER
	DCA X2

ININIT,	TAD (INPUTS-1	/SAVE ALL BYTES OF INPUT INCASE THIS ISN'T A NUMBER
	DCA X1
	DCA ID
	DCA ID1
	DCA ID2
	TAD OPT2	/ALWAYS CONVERT TO STRINGS?
	AND (40
	SZA CLA
	JMP INN16	/YES
	DCA PE
	DCA DE
	DCA PN
	STA
	DCA SE
	STA
	DCA SN
	DCA PL
	DCA T1
	DCA SM	/RESET SKIP FLAG
INN10,	JMS GETBYT	/GET A CHAR
	SNA		/TOTALLY IGNORE NULLS
	JMP INN10
	AND [177
	TAD [200	/MAKE SURE THIS BIT IS SET!
	DCA CHAR
	TAD CHAR
	DCA I X1	/SAVE (JUST IN CASE)
	TAD CHAR
	TAD (-232	/^Z?
	SNA
	JMP CLOSB	/IF SO THEN DONE
	TAD (-272+232
	CLL
	TAD (-260+272
	SZL		/#0-9?
	JMP INN2
	IAC
	IAC
	SNA		/.?
	JMP INN4
	IAC
	SNA
	JMP INN3	/-?
	IAC
	SNA
	JMP INN5	/,?
	IAC
	SNA		/+?
	JMP INN6
	TAD (253-240
	SNA		/SPACE
	JMP INN10
	TAD (240-212
	SNA
	JMP INN5	/LF?
	TAD (212-305
	SNA 
	JMP INN1	/E?
	TAD (305-215
	SNA CLA
	JMP INN10	/CR
	JMP INN14	/UN IDENTIFIED CHAR

INN1,	TAD PE		/PREVIOUS E INPUT OR
	CLL RAR		/NO PREVIOUS NUMERAL INPUT
	TAD PN
	SNA SZL CLA
	JMP INN14
	ISZ PE		/INDICATE E WAS INPUT
	DCA PN		/CLEAR PREVIOUS NUMBER FLAG
	JMP INN10

INN3,	TAD PE		/- WAS INPUT
	SZA CLA
	JMP INN3A	/THIS IS SIGN OF EXPONENT
	ISZ SN		/IS THIS SECOND MINUS?
	JMP INN14	/YES, ERROR
INN6,	TAD PN		/+ OR - IS VALID ONLY IF NO DIGITS INPUT SO FAR
	SZA CLA
	JMP INN14
	JMP INN10	/GET NEXT CHAR

INN3A,	ISZ SE		/IS THIS SECOND MINUS?
	JMP INN14		/YES, ERROR
	JMP INN6		/NO, GO MAKE SURE THIS IS NOT EMBEDDED MINUS
	PAGE///////////////////////////
INN2,	DCA SRL
	DCA SRM
	DCA SRH		/SAVE DIGIT TO USE ADSRAC
	ISZ PN		/SET PREVIOUS NUMBER FLAG
	TAD PE
	SZA CLA		/EXPONENT OR NUMBER?
	JMP INN7	/EXPONENT
	TAD SM		/SKIP ID*10?
	SZA CLA
	JMP INN15	/YES, CHECK DF
	TAD ID		/CAN WE MULTIPLY BY 10 (DECIMAL)
	TAD (-314		/AND STILL GET A NUMBER THAT FITS IN THE FRACTION
	SNA
	JMP INN2A		/CHECK OUT MIDDLE
INN2B,	SMA CLA
	JMP INN13		/NO
	CLL			/XPY NEEDS LINK CLEAR
	JMS XPY		/MULTIPLY BY 10
	JMS ADSRAC	/ADD IN DIGIT

INN11,	TAD DE
	TAD PL
	DCA DE
	JMP INN10

INN2A,	TAD ID1
	TAD (-6314
	JMP INN2B

INN13,	ISZ SM		/DON'T GO THROUGH THE CHECK FOR BIG FRACTION ANY MORE
INN15,	CLA IAC	/ADD 1+PL TO DE
	JMP INN11

INN7,	TAD T1
	RTL CLL		/ACCUMULATE THE EXPONENT
	TAD T1
	RAL CLL		/T1=T1*10
	TAD SRL
	DCA T1
	JMP INN10

INN5,	CLL CLA
	TAD T1		/CHECK SIZE OF EXPONENT
	TAD (-70
	SMA CLA		/EXPONENT TOO LARGE?
	JMP INN14	/YES, ERROR
	TAD T1
	ISZ SE		/DE=DE+EXPONENT
	CIA
	TAD DE
	DCA DE

/FLT - FLOAT A NUMBER INTO INTERNAL FORM
/FLT TAKES THE NO IN ID AREA AND ACCORDING TO THE DE
/SCALES IT. FLT DIVIDES BY 10 FOR A - NO. AND MULT'S BY 10
/FOR A + NO.	IT NORMALIZES THE NO. AND FORMATS IT ACCORDING TO BE
/AND SN. IF THE NUMBER ID = 0 ALONE IT IS LEFT.
	TAD P243	/ASSUMED EXPONENT (BINARY)
	DCA BE
	TAD ID
	SNA
	TAD ID1
	SNA
	TAD ID2
	SNA CLA		/TEST ID FOR ZERO
	JMP INXR	/ALL DONE IF 0

FLT1,	JMS NRM		/NORMALIZE NUMBER
	TAD DE
	SNA
	JMP FLT3	/DECIMAL EXP IS ZERO
	SMA CLA
	JMP FLT2	/IS PLUS, MAKE NO LARGER
	JMS DIV
	ISZ DE		/DECREASE SIZE
P243,	243
	JMP FLT1	/MORE
FLT2,	CLL
	JMS ARS		/ROTATE SO AS NOT TO LOSE THE TOP FEW BITS
	JMS ARS
	JMS ARS
	JMS ARS
	TAD BE
	TAD (4
	DCA BE		/ACCOUNT FOR THE SHIFTS
	JMS XPY	/MULTIPLY BY 10
	CLA CMA
	TAD DE
	DCA DE		/SET UP NEW DE
	JMP FLT1
FLT3,	TAD BE
	AND (7400	/ALL DONE, CHECK
	SZA CLA
	JMP INN14	/ERROR, TOO BIG!
	TAD (-10
	DCA CTR	/EXEC COUNTER
	CLL		/LINK MUST BE CLEARED FOR SHR
	JMS ARS
	ISZ CTR
	JMP .-2
	ISZ SN		/PUT NUMBER TOGETHER
	TAD (5400
	TAD BE		/GET EXP IN BITS 4-11
	RAL CLL
	RTL CLL
	TAD ID
	DCA ID
INXR,	JMS PUTID	/PUT ID INTO THE BUFFER
	JMP ININIT	/GO BACK AND DO THE NEXT NUMBER
PAGE
/SUBROUTINES USED BY B4OUT
PUTID,	0	/PUT ID INTO THE OUTPUT BUFFER
	TAD ID
	DCA I X2
	TAD ID1
	DCA I X2
	TAD ID2
	DCA I X2
	ISZ CHRCTR	/DONE WITH BUFFER?
	JMP I PUTID
	TAD PBL
	TAD (-2702
	SNA CLA
	JMP DTFUL	/DECTAPE IS FULL
	JMS PALLB	/YES, SEND IT TO THE DECTAPE
	TAD OBUF
	DCA X2
	TAD (-53
	DCA CHRCTR
	ISZ PBL
	JMP I PUTID

CLOSB,	TAD CHRCTR
	TAD (53
	SZA CLA
	JMS PALLB	/OUT LAST BUT PARTIAL BLOCK
	JMP FIN	/THEN YOU'RE DONE

PALLB,	0		/OUTPUT THE OUTPUT BUFFER TO DECTAPE
	JMS DECTAPE
PBL,	0
PDR,	0
	-201		/TSS/8 TAPE HAS THIS MANY WORDS PER BLOCK
OBUF,	OUTBUF-1
	WRITE		/THE FUNCTION IS WRITE
	JMP I PALLB

ARS,	0		/SHIFT RIGHT
	TAD ID
	RAR
	DCA ID
	TAD ID1
	RAR
	DCA ID1
	TAD ID2
	RAR
	DCA ID2
	CLL		/MAKE SURE LINK IS CLEAR AFTER THE ROTATES.
	JMP I ARS

ALS,	0		/SHIFT LEFT
	TAD ID2
	RAL
	DCA ID2
	TAD ID1
	RAL
	DCA ID1
	TAD ID
	RAL
	DCA ID
	JMP I ALS

NRM,	0
NRM1,	CLL CLA CML RTR	/NORMALIZE ID
	AND ID
	SZA CLA
	JMP I NRM
	JMS ALS
	CLA CMA
	TAD BE
	DCA BE
	JMP NRM1

XPY,	0		/MULTIPLY ID BY 10.
	JMS ALS
	TAD ID
	DCA TS
	TAD ID1
	DCA TS1
	TAD ID2
	DCA TS2
	JMS ALS
	JMS ALS
	TAD ID2
	TAD TS2
	DCA ID2
	GLK
	TAD ID1
	TAD TS1
	DCA ID1
	GLK
	TAD ID
	TAD TS
	DCA ID
	JMP I XPY

ADSRAC,	0		/ADD THE SR TO THE AC
	CLA CLL
	TAD ID2
	TAD SRL
	DCA ID2
	RAL
	TAD ID1
	TAD SRM
	DCA ID1
	RAL
	TAD ID
	TAD SRH
	DCA ID
	JMP I ADSRAC
/
/
/ LOGICAL SHIFT RIGHT ROUTINE
/
/
SUBLSR,	0
	DCA ZROAC	/ SAVE AC
	TAD I SUBLSR	/ GET SHIFT COUNT
	CMA		/ COMPLEMENT IT
	DCA CNTROT	/ STORE COUNT
	ISZ SUBLSR	/ INCREMENT TO RETURN ADDRESS
ROTMOR,	TAD ZROAC	/ GET AC CONTENTS
	CLL RAR		/ ROTATE RIGHT 1 BIT
	DCA ZROAC	/ STORE SHIFTED AC
	TAD ZROMQ	/ GET MQ CONTENTS
	RAR		/ ROTATE RIGHT 1 BIT, SHIFTING LINK
			/ FROM AC ROTATE
	DCA ZROMQ	/ SAVE SHIFTED MQ
	ISZ CNTROT	/ DONE SHIFTING?
	JMP ROTMOR	/ NO, SHIFT AGAIN
	CLL		/ YES, CLEAR LINK
	TAD ZROAC	/ EXIT WITH AC AND MQ SET
	JMP I SUBLSR	/ RETURN TO CALLING PROGRAM
CNTROT,	0
PAGE
/MORE SUBROUTINES FOR B4OUT
DTSW=.			/TEMP STORAGE FOR DECTAPE ROUTINE
DIV,	0		/DIVIDE BY 10.
	CLA CLL
	TAD (7740
	DCA TS
DIV1,	TAD ID
	TAD (5400
	SMA
	DCA ID
	CLA
	JMS ALS
	ISZ TS
	JMP DIV1
	TAD ID
	AND [377
	DCA ID
	JMP I DIV

/THIS IS THE BIG DECTAPE ROUTINE
/CALL AS FOLLOWS
/	JMS DECTAP
/	BLOCK NUMBER	(NEG TO DO OPERATION IN REVERSE)
/	DRIVE NUMBER (BITS 0-2)
/	NEGATIVE OF WORD COUNT
/	ADDRESS -1 OF BUFFER
/	20 FOR READ OR 40 FOR WRITE
/	NORMAL RETURN
DECTAP,	0
	DCA MIN		/ASSUME FORWARD
	TAD I DECTAP	/GET BLOCK NUMBER
	ISZ DECTAP	/INCREMENT
	SMA
	JMP GOTBLK	/POSITIVE
	ISZ MIN		/SET REVERSE FLAG
	CIA		/MAKE BLOCK +
GOTBLK,	DCA THEBLK
	TAD I DECTAP	/GET DRIVE
	DCA	UNIT	/PRESERVE UNIT NUMBER
	ISZ DECTAP
	TAD I DECTAP
	ISZ DECTAP
	DCA WC
	TAD I DECTAP
	ISZ DECTAP
	DCA CA
	TAD I DECTAP
	ISZ DECTAP
	TAD (110
	DCA RWC		/READ OR WRITE CONTROL
	TAD	UNIT	/GET UNIT NUMBER INTO REGISTER
	TAD [10		/SEARCH
	DTLA
	TAD [10		/FROM FIELD 1
	DTLB
	TAD (DTSW	/SET UP CA FOR SEARCH
	CDF 0
	6753		/PDP-5 LOAD CA REGISTER
	CDF 10
	TAD MIN
	SZA CLA
	TAD [1000	/SET REVERSE DIRECTION FOR INITIAL SEARCH

SERR,	RTL;RAL		/REVERSE DIRECTION IN CASE OF ERROR
	CLA CML
	TAD [200	/SET GO BIT
CONT,	SNL		/COMPLEMENT THE DIRECTION BIT IF LINK IS 0
	TAD (400
	DTXA
	DTSF DTRB
	JMP .-1
	SPA
	JMP SERR
	DTRA
	RTL;RTL		/GET DIRECTION BIT BACK IN THE LINK
	SZL CLA		/WAS IT REVERSE
	JMP REVSRC	/YES
	TAD MIN		/NOPE,	SHOULD WE SEARCH FORWARD PAST THE BLOCK FOR A TURN
	SZA CLA
	L7775		/YES CAUSE WE READ BACKWARDS
	TAD DTSW
	CMA CLL
	TAD THEBLK
	CMA
	SZA CLA
	JMP CONT	/CONTINUE SEARCH
	TAD MIN		/SHOULD TAPE BE GOING IN REVERSE DIRECTION?
	SZA CLA
	JMP CONT+1

TAPRED,	TAD WC
	6743		/PDP-5 LOAD WC REGISTER
	TAD CA
	6753		/PDP-5 LOAD CA REGISTER
	TAD RWC
	DTXA
	DTSF
	JMP .-1
	TAD (202	/STOP, PRESERVE ERROR
	DTRA		/CLEAR FUNCTION SELECT     [SE ]
	AND	(272	/CLOBBER THESE BITS ONLY    [SE]
	DTXA
	DTRB
	SPA CLA
	JMP SELER
	JMP I DECTAP
WC,	0
CA,	0
RWC,	0
UNIT,	0

REVSRC,	TAD MIN
	SNA CLA
	TAD (3
	TAD DTSW
	CMA STL
	TAD THEBLK
	CMA
	SZA CLA
	JMP CONT
	CLL
	TAD MIN
	SNA CLA
	JMP CONT+1
	JMP TAPRED
	PAGE////////////////
/MORE SUBROUTINES
/CHECK ENTRIES ON A BASIC + CATALOG BLOCK
CHKENT,	0
	STA
	DCA INCT	/INITIALIZE FOR GETBYT
	TAD [GETA
	DCA GETNXT
	TAD (-34
	DCA CTR		/34 ENTRIES PER BLOCK
	DCA CHKEEN	/CLEAR ENTRY NUMBER
NXTENT,	STA
	DCA ENTE	/ASSUME FILE FOUND
	DCA ENTZ	/ASSUME FILE IS BLANK
	TAD (NAMEI
	DCA NAMPT
	TAD [-6		/6 BYTES PER NAME AND EXT
	DCA CHRCTR
CHEAGN,	JMS GETBYT
	SZA
	ISZ ENTZ	/THERE WAS SOMETHING IN THE NAME
	CIA
	TAD I NAMPT
	ISZ NAMPT
	SZA CLA
	DCA ENTE
	ISZ CHRCTR
	JMP CHEAGN
	TAD [-4
	JMS MOVPT
	ISZ ENTE
	JMP CHKBCK
	JMS BOT12	/GET THE BOTTOM 12 BITS OF THE NEXT WORD
	DCA BLKS		/THATS THE BLOCK#
	JMS BOT12
	CIA
	DCA BLCTS	/THATS THE COUNTER
	ISZ ENTC
	L0004
CHKBCK,	TAD (-10
	JMS MOVPT
	TAD ENTZ
	SZA CLA		/WAS FILE NAME BLANK?
	JMP CHKBAK	/NOPE
	TAD CHKEBL	/YES, SAVE CATALOG BLOCK NUMBER (0 OR 1)
	DCA CATBL
	TAD CHKEEN	/AND ENTRY NUMBER (0-33)
	DCA CATEN
	ISZ ENTFZ	/SHOW THAT WE FOUND A BLANK
CHKBAK,	ISZ CHKEEN	/INCREMENT ENTRY NUMBER
	ISZ CTR		/DONE WITH BLOCK?
	JMP NXTENT	/NOPE
	ISZ CHKEBL	/INCREMENT BLOCK NUMBER
	JMP I CHKENT

/ROUTINE TO MOVE THE POINTER IN THE INPUT BUFFER
/ENTER WITH NEG OF THE NUMBER OF	BYTES TO MOVE
MOVPT,	0
	DCA CHRCTR
	JMS GETBYT
	ISZ CHRCTR
	JMP .-2
	CLA
	JMP I MOVPT

/GET 2 BYTES, MASK OFF THE BOTTOM 12 BITS AND RETURN THEM IN THE AC
BOT12,	0
	JMS GETBYT
	DCA TEMP1
	JMS GETBYT
	AND [17
	CLL RTR;RTR;RAR
	TAD TEMP1
	JMP I BOT12

/PRINT	A CR LF COMBO
CRLF,	0
	TAD (215
	JMS TTYOUT
	TAD (212
	JMS TTYOUT
	JMP I CRLF

/PRINT THE AC
CHRTMP=.		/TEMP STORAGE FOR UNPACK
TTYOUT,	0
	TSF
	JMP .-1
	TLS
	CLA
	JMP I TTYOUT

/UNPAC SLASHED 6-BIT
/GO TO PC IF CHCTR=0 OR CHARACTER UNPACKED IS A @
UNPAC,	0
	TAD CHRCTR
	SNA CLA
	JMP I UNPAC
	TAD I CHRAD	/CHRAD POINTS TO THE CHARACTER
	ISZ SW		/USUALLY ENTER WITH THIS =0 TO START
	JMP FSTPT
	ISZ CHRAD
	JMP UNPBCK
FSTPT,	RTR;RTR;RTR
	DCA CHRTMP
	STA		/RESET SWITCH
	DCA SW
	TAD CHRTMP
UNPBCK,	AND [77
	TAD (-40
	SPA
	TAD (100
	TAD (240
	ISZ CHRCTR
	NOP		/SORRY ABOUT THIS
	ISZ UNPAC
	JMP I UNPAC

ATOUT,	0		/REMOVE @ SIGNS FOR PRINTING
	TAD (-300
	SNA
	JMP I ATOUT
	TAD (300
	JMS TTYOUT
	JMP I ATOUT
	PAGE///////////////
//THIS IS THE ALL IMPORTANT GETBYT ROUTINE.
/IT GETS ONE BYTE FROM THE INPUT FILE
/IF AN END OF FILE IS DETECTED, A ^Z IS RETURNED
/BYTES ARE STORED AS FOLLOWS
/	XX2 222 222 211
/	111 111 XX4 444
/	444 433 333 333
/WHERE X INDICATES WASTED BIT, NUMBER INDICATES BIT OF THAT BYTE
GETBYT,	0
	CLA
	JMP I .+1
GETNXT,	0
	AND [377	/ONLY 1 BYTE
	JMP I GETBYT

GETRES,	JMS GETNXT
GETA,	JMS I GETW		/FIRST OF FOUR
	DCA TEMPG1
	JMS I GETW
	MQL
	TAD TEMPG1
	SHL;5
	JMS GETNXT	/MQA IS USED FOR TEMP STORAGE (DON'T TOUCH IT)
	TAD TEMPG1	/2
	RTR
	JMS GETNXT
GWDNB,	JMS I GETW	/3
	DCA TEMPG1
	TAD TEMPG1
	JMS GETNXT
	LSR;5		/4
	MQA
	DCA TEMPG2
	TAD TEMPG1
	MQL
	TAD TEMPG2
	SHL;3
	JMP GETRES	/RESET GETNXT

GETWRD,	0
	TAD I X3	/GET A WORD FROM THE INPUT BUFFER
	ISZ INCT	/DONE?
	JMP I GETWRD	/NO
	CLA		/FORGET THAT WORD, ITS GARBAGE
	TAD BLCTRI	/TEST FOR PHYSICAL END OF FILE
	SNA CLA
	JMP GETEND
	ISZ BLCTRI
P232,	232
	JMS BGTAP
	TAD MIN		/SET UP THE CORRECT ROUTINE TO GET A WORD
	SZA CLA
	TAD (BGETWD-GETWRD
	TAD (GETWRD
	DCA GETW
	STA
	DCA LITCTR	/LITCTR =-1 TO FORCE A NEW 3-WORD BUFFER
	TAD IBUF	/REINIT X3
	DCA X3
	TAD GETBYT	/SET UP THE "RECURSIVE CALL"
	DCA ENDR
	TAD [-601	/BECAUSE ISZ IS DONE BEFORE WE LEAVE
	DCA INCT
	JMS BOT12	/NOTE THAT THIS CALLS GETBYT
	DCA GBL		/SAVE NEW BLOCK NUMBER
	TAD ENDR	/RESTORE RETURN ADDRESS
	DCA GETBYT
	JMP GWDNB	/IF WE'RE NOT DONE YET
GETEND,	TAD P232
	JMP I GETBYT	/PHYSICAL END OF FILE
ENDR,	0		/SAVE RETURN

BGETWD,	0		/THIS ROUTINE CALL GETWRD INDERECTLY FOR REVERSE READ
	TAD I X4
	ISZ LITCTR
	JMP I BGETWD	/NOT DONE WITH OUR LITTLE 3-WORD BUFFER
	JMS COMOBV
	GETWRD		/USE GETWRD TO GET THE 4-BYTE FOR COMOBV
	TAD (TEMPB1-1	/INIT FOR THE NEXT 4-BYT
	DCA X4
	TAD [-4
	DCA LITCTR
	JMP BGETWD+1

BGTAP,	0
	JMS DECTAP
GBL,	0		/BLOCK NUMBER
GDR,	0		/BITS 0-2 ARE DRIVE NUMBER
	-600		/600 WORDS PER BLOCK
IBUF,	INBUF-1		/INPUT BUFFER
	READ		/FUNCTION IS READ
	JMP I BGTAP

GETTMP,	0		/SILLY LITTLE SUBROUTINE TO BE CALLED BY COMOBV
	TAD I X3
	JMP I GETTMP
/
/
/ ROUTINE TO LOAD MQ AND SHIFT LEFT
/
/
MQSHFT,	0
	MQL		/ LOAD MQ FROM AC
	TAD I MQSHFT	/ GET SHIFT COUNT
	DCA .+2		/ STORE IT
	SHL		/ SHIFT LEFT
	0		/ SHIFT COUNT
	ISZ MQSHFT	/ INCREMENT TO RETURN ADDRESS
	JMP I MQSHFT	/ RETURN TO CALLING PROGRAM
PAGE
INN4,	ISZ PL		/IS THIS THE FIRST .

INN14,	CLL CLA
	TAD OPT2
	RTL
	SZL CLA
	JMP BADNUM	/ALLOW NUMBERS ONLY
	JMP INN17	/USE LAST CHAR FOR FIRST CHAR
INN16,	JMS GETBYT	/GET A CHAR
	AND [177
	TAD [200
	DCA CHAR
	TAD CHAR
	DCA I X1
INN17,	TAD OPT2	/CHECK TO SEE IF TERM IS A ,
	AND (20
	SZA CLA
	JMP INN21	/ONLY ALLOW LF'S TO BE TERMINATORS
	TAD (-254
	TAD CHAR
	SNA CLA
	JMP INN18	/YES , WAS TERMINATOR
INN21,	TAD (-212
	TAD CHAR
	SZA CLA
	JMP INN16	/NOT A TERMINATOR, GET NEXT CHAR
INN18,	TAD CHAR	/GET NEG OF TERMINATOR SO WE KNOW WHEN WE'RE DONE
	CIA
	DCA MCHAR
	TAD (INPUTS-1	/INITIALIZE LOTS OF SHIT
	DCA X1
NXTGRP,	TAD [-6
	DCA BITCTR
	DCA ID
	DCA ID1
	DCA ID2
	DCA SW
	TAD (ID
	DCA OUTPT
NXTCH,	CLA
	TAD MCHAR
	TAD I X1
	SNA
	JMP DONSTR	/HIT THE END OF THE STRING
	TAD CHAR	/RESTORE CHAR
	DCA T1		/SAVE CHAR
	TAD OPT2	/SAVE SPACES?
	AND (20
	SZA CLA
	JMP INN25	/YES
	TAD T1		/NO, IGNORE THEM
	TAD (-240
	SNA CLA
	JMP NXTCH
INN25,	TAD T1		/GET CHAR BACK
	TAD (-232	/CHECK FOR ^Z
	SNA
	JMP CLOSB
	TAD (232-337
	SMA
	JMP NXTCH	/CHAR NOT IN CORRECT RANGE!
	TAD (337-237
	SPA SNA
	JMP NXTCH	/CHAR NOT IN RANGE
	ISZ SW		/PACK THE CHAR IN -237 6-BIT CODE
	JMP FSTPRT
	TAD I OUTPT
	DCA I OUTPT
	ISZ OUTPT
	JMP DONCHR
FSTPRT,	CLL RTL;RTL;RTL
	DCA I OUTPT
	STA
	DCA SW
DONCHR,	ISZ BITCTR
	JMP NXTCH
	JMS PUTID	/PUT THE STRING IN THE BUFFER
	JMP NXTGRP
DONSTR,	L0006
	TAD BITCTR
	SZA CLA
	JMS PUTID
	JMP ININIT

BPEXP,	0		/GET A BLOCK,TAKE IT APART, AND LEAVE IT IN INPUTS
	DCA GBL		/INIT GETBYT
	JMS BGTAP		/READ IN THE BLOCK
	TAD (INBUF-1	/INIT GETBYT
	DCA X3
	TAD (GETWRD
	DCA GETW
	DCA INCT		/WE KEEP COUNT - NOT GETWRD
	TAD [GETA
	DCA GETNXT
	TAD [-1000	/1000(8) BYTES PER BLOCK
	DCA CTR
BPEXPA,	JMS GETBYT
	DCA I X1
	ISZ CTR
	JMP BPEXPA
	JMP I BPEXP
	PAGE/////////////////////
BPRED,	0		/REDUCE A BLOCK (1000(8) BYTES), PUT IT BACK OUT.
	DCA BBL		/THE OPPOSITE OF BPEXPA
	TAD (BPBYTA	/INIT BPBYT
	DCA BPNXT
	DCA CURDIR
	DCA OUTCT
	TAD [OUTBUF-1
	DCA X2
	TAD (-1000
	DCA CTR
BPREDA,	TAD I X1	/LOOP TO REDUCE BLOCK
	JMS BPBYT
	ISZ CTR
	JMP BPREDA
	JMS BPTAP
	JMP I BPRED

INDEIN,	TAD (2001	/GET INPUT DEVICE HANDLER INTO CORE
	DCA INDEV
	TAD INPUT
	JMS I USR	/CALL USR
	FETCH
INDEV,	0		/THIS IS WHERE THE DEVICE HANDLER ADDRESS IS PUT
	JMP DONEX	/NO SUCH DEVICE!!
	TAD (INPUT+1	/NOW GET THE INPUT FILE STUFF
	DCA PBLCKI
	TAD INPUT
	JMS I USR	/AND CALL USR AGAIN.
	LOOKUP		/FOR A LOOKUP
PBLCKI,	0		/ENDS UP WITH STARTING BLOCK OF FILE
PBLCTI,	0		/ENDS UP WITH LINGTH OF FILE
	JMP COUFF	/UNSUCCESSFUL LOOKUP
	TAD PBLCTI	/IN CASE OF NON FILE STRUCTURED DEVICE, NOP THE EOF TEST
	SNA
	IAC
	DCA PBLCTI
	STA		/INIT BGBYT
	DCA INCT
	TAD (BGBYTA
	DCA BGNXT
	TAD (PBLOOP
	DCA BPBYT	/INIT BPBYT
	JMP BPINI

PBLOOP,	JMP I .+1	/THIS IS THE ACTUAL TRANSFER
BGNXT,	0
	AND [177	/MASK OFF THE HIGH BIT
	TAD (-32	/WAS IT A ^Z?
	SNA
	JMP BPENDL	/YES, LOGICAL END OF FILE
	TAD (32
	JMS BPBYT
	JMP PBLOOP

BGBRST,	JMS BGNXT	/RESET AFTER #3
BGBYTA,	JMS BGWORD	/FIRST OF 3 BYTES TO BE PACKED
	DCA TEMP1
	TAD TEMP1
	JMS BGNXT
	JMS BGWORD	/SECOND
	DCA TEMP2
	TAD TEMP2
	JMS BGNXT
	TAD TEMP1	/THIRD
	AND (7400	/NOTE THE LACK OF EAE HERE
	CLL RTR;RTR
	DCA TEMP1
	TAD TEMP2
	AND (7400
	CLL RTL;RTL;RAL
	TAD TEMP1
	JMP BGBRST

BGWORD,	0		/GETS A WORD FROM THE OS8 FILE
	TAD I X1
	ISZ INCT	/DONE WITH INPUT BUFFER?
	JMP I BGWORD
	CLA		/YES, KILL THE WORD
	TAD PBLCTI	/IS THIS THE END OF THE FILE?
	SNA
	JMP BPENDL	/YES
	IAC		/NO, THEN INCREMENT COUNTER
	DCA PBLCTI
	TAD PBLCKI	/PUT IN THE BLOCK WE WANT TO READ
	DCA PBLKI
	CIF		/CALL THE DEVICE HANDLER (ITS IN F0)
	JMS I INDEV
	0210		/FUNCTION WORD
	INBUF
PBLKI,	0
	JMP BGERR	/CHECK OUT THE ERROR IF WE GOT ONE
BGEOFC,	ISZ PBLCKI	/INCREMENT BLOCK #
	TAD (INBUF-1	/RESET POINTER
	DCA X1
	TAD (-401	/RESET COUNTER
	DCA INCT
	JMP BGWORD+1	/AND RETURN WITH A WORD IN THE AC
BGERR,	SPA CLA
	JMP FATONI	/FATAL ERROR ON INPUT DEVICE!!
	JMP BGEOFC	/END OF FILE DETECTED ON NON FILE STRUCTURED DEVICE

	PAGE///////////////////
/THIS ROUTINE PUTS A BYTE INTO THE OUTPUT BUFFER WHICH LATER GOES ON AN
/11 DECTAPE.  THERE ARE 776 BYTES PER BLOCK PLUS 1 2-BYTE POINTER TO THE
/NEXT BLOCK WHICH IS PUT IN LAST.
BPBYT,	0
	AND [377		/MASK OFF THE BOTTOM 8
	JMP I .+1	/DISPATCH TO PROPER PACKER
BPNXT,	0
M200,	7600	/ACTS AS A CLA
	JMP I BPBYT
BPRST,	JMS BPNXT	/RESET
BPBYTA,	MQLSHL;3	/PACK BYTE #1
	JMS BPNXT
	SHL;1		/#2
BPBYTB,	DCA TEMBP1
	MQA
	DCA TEMBP2
	JMS BPNXT
	MQLSHL;3	/#3
	JMS BPNXT
	LSR;3		/#4
	TAD TEMBP2
	DCA TEMBP2
	MQA
	DCA TEMBP3
	TAD CURDIR	/GET 4-BYT IN THE RIGHT DIRECTION
	SNA CLA
	JMP BPB4YA
	TAD [TEMBP1-1
	DCA X3
	JMS COMOBV	/GET COMPLEMENT OBVERSE
	GETTMP		/USE THAT STUPID LITTLE SUBROUTINE
	TAD [TEMPB1-TEMBP1		/THIS IS ACTUALLY A -4
BPB4YA,	TAD [TEMBP1-1
	DCA X3
	TAD I X3
	DCA I X2
	TAD I X3
	DCA I X2
	TAD I X3
	DCA I X2	/THE 3 WORDS ARE NOW IN THE BUFFER
	ISZ OUTCT	/TIME FOR A NEW BUFFER?
	JMP BPRST	/GO BACK AND RESET BPNXT
	JMS BPTAP	/OUTPUT THE BLOCK
	TAD DIRECT
	DCA CURDIR	/CURDIR_DIRECT
BPINI,	TAD DIRECT	/NOW RE-INITIALIZE THIS ROUTINE
	CLL RAR
	TAD CURBLK
	SZL
	CIA
	DCA BBL		/SET UP BLOCK FOR NEXT WRITE
	TAD (4
	SZL
	CIA
	TAD CURBLK	/START SEARCHING AFTER 4 IN THE DIRECTION WERE GOING
	JMS FINDBL
	DCA CURBLK	/CURBLK BECOMES THE NEXT BLOCK #
	TAD M200	/RESET THE COUNTER
	DCA OUTCT
	TAD [OUTBUF-1	/AND THE POINTER
	DCA X2
	TAD DIRECT
	CLL RAR		/PUT THIS NUMBER INTO THE POINTER POSITION
	TAD CURBLK	/GET THE SIGN RIGHT
	SZL
	CIA
	MQL
	SZL
	STA
	SHL;5	/ROTATE INTO POSITION
	JMP BPBYTB	/AND UNLOAD INTO THE TEMPORARY STORAGE

/THIS SUBROUTINE CONVERTS WORDS THAT ARE READ OR WRITTEN IN REVERSE TO THEIR
/CORRECT VALUES.  THE 11 DOESN'T COMPLEMENT WHEN REVERSING, ALSO IT DOES
/SOME WEIRD THINGS TO THE ORDER OF BYTES:
/A 3-WORD BLOCK READ IN REVERSE APPEARS AS FEDC BALK JIHG AND WE WANT
/ABCD EFGH IJKL.
COMOBV,	0	/RETURNS THE COMPLEMENT OBVERSE OF THE NEXT 
	L7775		/DONE SO GET ANOTHER
	DCA LITCTR
	TAD I COMOBV	/4-BYT PRETURNED BY THE SUB IN PC+1
	ISZ COMOBV
	DCA GETSUB	/THIS IS THE ADDRESS OF A SUBROUTINE TO RETURN WORDS
	TAD [TEMPB1
	DCA LITPTR	/INITIALIZE FIRST PHASE
BGET1,	DCA I LITPTR	/CLEAR OUT THE REVERSED WORD
	JMS I GETSUB
	CMA
	MQL
	TAD [-4
	DCA LITCT
BGET2,	TAD I LITPTR	/MOVE STUFF TTO THE RIGHT BY 1 OCTIT
	CLL RAR;RTR
	DCA I LITPTR
	SHL;2		/SHIFT OFF THE HIGH ORDER OCTIT
	CLL RTR;RTR		/SAVE THAT OCTIT
	TAD I LITPTR	/GET THE REVERSED WORD
	DCA I LITPTR
	ISZ LITCT
	JMP BGET2
	ISZ LITPTR
	ISZ LITCTR	/DONE WITH BUFFER?
	JMP BGET1	/NOPE, REVERSE ANOTHER WORD
	TAD TEMPB2	/DO SOME COMPLICATED FINAGELING
	DCA TEMPB4
	TAD TEMPB1
	DCA TEMPB2
	TAD TEMPB4
	DCA TEMPB1
	L7775		/INIT FOR PHASE TWO
	DCA LITCTR
	TAD [TEMPB1
	DCA X4
	TAD [TEMPB1
	DCA LITPTR
BGET3,	TAD I X4	/LOAD UP THE MQ
	MQL
	TAD I LITPTR
	SHL;5		/SHIFT EVERYTHING BY 6 BITS
	DCA I LITPTR
	ISZ LITPTR
	ISZ LITCTR	/DONE WITH LITTLE BUFFER?
	JMP BGET3
	JMP I COMOBV
	PAGE////////////////////
/	THIS IS THE CLOSING ROUTINE FOR PDP-11 DECTAPE FILES
/	IT MUST	1) PUT IN THE UFD ENTRY
/		2) PUT OUT A FILE BIT MAP
/		3) PUT OUT AN UPDATED VERSION OF THE PERMANENT BIT MAP
BPENDL,	TAD (32		/OUTPUT A ^Z FOR RSTS
	JMS BPBYT	/BY OUTPUTTING 2 ^Z'S
	TAD OUTCT	/FIGURE OUT HOW MANY SPACES LEFT IN OUPUT BUFFER
	CLL RAL
	CLL RAL
	DCA CTR
	DCA OUTCT	/NO-OP THE END OF BUFFER CHECK IN PBYT
BPEND2,	JMS BPBYT	/OUTPUT ENOUGH 0'S TO FILL THE LAST BLOCK
	ISZ CTR
	JMP BPEND2
	TAD CURDIR		/PUT A 0 POINTER INTO THE POINTER POSITION
	SZA
	STA
	DCA CURDIR	/MAY ACTUALLY BE ALL ONES BUT IT WILL BE COMPLEMENTED LATER
	TAD CURDIR
	DCA OUTBUF
	TAD CURDIR
	AND (7700
	DCA CURDIR
	TAD OUTBUF+1
	AND (77
	TAD CURDIR
	DCA OUTBUF+1
	JMS BPTAP	/OUTPUT THE BLOCK-UPDATE FILE LENGTH COUNTER
	TAD BBL		/NOW SET UP THE UFD ENTRY
	MQL
	TAD BBL		/PUT IN LAST BLOCK
	SPA CLA
	STA		/MAY BE NEGATIVE
	SHL;3
	DCA ENDBL+1	/HIGH ORDER
	TAD BBL
	DCA ENDBL	/LOW ORDER
	TAD NUMBLK	/NOW THE NUMBER OF BLOCKS
	MQLSHL;3	/CAN I DO THIS?
	DCA NUMBL+1	/HIGH ORDER
	TAD NUMBLK
	DCA NUMBL

/PUT IN THE DATE--THIS IS A MAJOR OPERATION
/THE DATE IS STORED IN OS/8 AS:
/	0-3	MONTH (1-14)
/	4-8	DAY (1-37)
/	9-11	YEAR-1970 (0-7)
/BUT ON A 11 DECTAPE IT IS STORED AS THE JULIAN DATE-70,000(10)
/(JULIAN DATE IS A DECIMAL NUMBER-THE FIRST TWO DIGITS OF WHICH ARE THE
/LAST 2 DIGITS OF THE YEAR AND THE LAST 3 DIGITS OF WHICH ARE THE DAY OF
/THE YEAR (1-365 OR 366 IN LEAP YEAR)
/THE FACT THAT THIS ROUTINE MUST TAKE LEAP YEAR INTO ACCOUNT
/MEANS THAT IT WILL HAVE TO BE UPDATED IN THE FUTURE-NOT BY ME BUT 
/BY SOME OTHER ENTERPRISING PERSON.
	TAD DATEP	/CALCULATE THE NUMBER OF DAYS
	MQLSHL;3
	TAD (MONTHS-1
	DCA DATEB
	TAD I DATEB	/PICK UP THE NUMBER OF DAYS TO THIS MONTH
	DCA DATEB
	SHL;4
	TAD DATEB
	DCA DATEB	/NOW WE HAVE THE NUMBER OF DAYS SO FAR THIS YEAR
	SHL;2		/GET YEAR
	DCA YEAR
	DCA DATEB+1
	TAD YEAR	/CHECK FOR LEAP YEAR
	L7776		/1972 IS A LEAP YEAR
	TAD YEAR
	SNA CLA
	ISZ DATEB+1	/THIS IS SLIGHTLY MORE GENERAL THEN NECESSARY
	CLL
	TAD DATEP
	TAD (-1400	/IS MONTH => MARCH?
	SNL CLA
	JMP DATE1
	TAD DATEB+1	/YES THEN ADD IN FEB 29TH IF ITS LEAP YEAR
	TAD DATEB
DECIMAL;DCA DATEB
DATE1,	TAD (1000	/GET YEAR*1000
OCTAL;	MQLMUY
YEAR,	0
	DCA DATEB+1	/SAVE HIGH
	MQA
	CLL		/DO A DOUBLE PRECISION ADD TO PUT IN # OF DAYS
	TAD DATEB
	DCA DATEB
	TAD DATEB
	MQL		/PUT LOW ORDER BACK INTO MQ
	TAD DATEB+1
	SZL		/INCREMENT HIGH ORDER IF CARRY FROM ADD
	IAC
	SHL;3		/SHIFT TO GET HIGH ORDER BYTE
	DCA DATEB+1

/UFD ENTRY IS ALL SET UP, NOW PUT IT INTO THE LAST BLANK SPACE IN THE UFD
/THIS SPACE WAS FOUND BY THE LOOK UP ROUTINE WAY AT THE BEGINNING OF
/THIS PROGRAM
	TAD (INPUTS-1	/SET UP FOR BPEXP
	DCA X1
	TAD CATBL	/THIS IS A 1 OR 0
	TAD (102	/UFD STARTS ON BLOCK 102
	JMS BPEXP
	TAD CATEN	/CONTAINS ENTRY NUMBER (0-33)
	MQLMUY
	22		/18 BYTES PER ENTRY
	MQA
	TAD (INPUTS+1	/1 FOR POINTER WORD
	DCA X1
	TAD (NAMEI-1	/LOOP TO MOVE IN THE ENTRY
	DCA X2
	TAD (-22
	DCA CTR
	JMP MOVUFD	/MOVE THE ENTRY
	PAGE/////////////////
MOVUFD,	TAD I X2	/LOOP TO MOVE THE UFD ENTRY
	DCA I X1
	ISZ CTR
	JMP MOVUFD
	TAD (INPUTS-1	/NOW PUT THE UFD BLOCK BACK
	DCA X1
	TAD CATBL
	TAD (102
	JMS BPRED

/PUT IN THE FBM. FBM BLOCKS START ON #70. EACH BLOCK CONTAINS 7 36-WORD
/FILE BIT MAPS
	TAD (INPUTS-1
	DCA X1		/SET UP FOR NEXT BPEXP
	TAD CATBL
	SZA CLA
	TAD (34
	TAD CATEN
	MQLDVI		/GET FBM BLOCK #
	7
	DCA CATEN	/THIS IS THE ENTRY NUMBER ON THIS BLOCK (0-6)
	MQA
	TAD (70		/THIS IS THE BLOCK CONTAINING OUR FBM
	DCA BBL		/SAVE IT
	TAD BBL
	JMS BPEXP	/GET THE BLOCK INTO THE BUFFER
	TAD CATEN
	MQLMUY
	110		/EACH BLOCK IS 110 BYTES (36 WORDS) LONG
	MQA
	TAD (INPUTS-1
	DCA X1		/POINTS TO BEGINNING OF FBM-1
	TAD (FBM-1
	DCA X2
	TAD (-110
	DCA CTR
MOVFBM,	TAD I X2	/LOOP TO MOVE FBM
	DCA I X1
	ISZ CTR
	JMP MOVFBM
	TAD (INPUTS-1	/PUT FBM BLOCK BACK OUT
	DCA X1
	TAD BBL
	JMS BPRED
	TAD (PBMBL-1	/PUT OUT THE PBM
	DCA X1
	TAD (104	/PBM IS ON BLOCK 104
	JMS BPRED
	JMP FIN		/ALL DONE!!!!!

/THIS PART OF PIP11 IS CALLED IF THE USER WANTS TO OUTPUT TO AN 11 DECTAPE
OS8IN,	TAD ENTC	/CHECK TO MAKE SURE THAT FILE WASN'T FOUND
	SZA CLA
	JMP FAEX	/FILE ALREADY EXISTS!
	TAD ENTFZ	/CHECK TO MAKE SURE THERE WAS ROOM IN THE UFD
	SNA CLA
	JMP DTFUL	/DECTAPE FULL!!
	TAD (PBMBL-1	/READ IN THE PBM
	DCA X1
	TAD (104	/ITS ON BLOCK 104
	JMS BPEXP	/SPECIAL READ IN AND EXPAND ROUTINE
	TAD (-110		/ZERO OUT THE FBM FOR THIS FILE
	DCA CTR
	TAD (FBM-1
	DCA X1
FBMZER,	DCA I X1
	ISZ CTR
	JMP FBMZER
	DCA DIRECT	/INIT FINDBL-- START SEARCH IN FORWARD DIRECTION
	DCA CURDIR	/FIRST BLOCK FORWARD
	DCA ENTC	/THIS IS A TOTAL DECTAPE SEARCH
	JMS FINDBL	/START SEARCHING AT BLOCK 0
	DCA CURBLK	/SAVE BLOCK NUMBER
	TAD CURBLK	/SAVE THIS FOR UFD ENTRY
	MQLSHL;3
	DCA STRTBL+1	/HIGH ORDER
	TAD CURBLK
	DCA STRTBL
	TAD GDR		/GET OUTPUT DRIVE NUMBER
	DCA BDR
	DCA NUMBLK	/FILE LENGTH IS 0 TO START
	JMP INDEIN	/GO TO INITIALIZE THE INPUT HANDLER

BPTAP,	0		/THIS ROUTINE WRITES ON BASIC 4 DECTAPE
	JMS DECTAP	/AND KEEPS TRACK OF FILE LENGTH
BBL,	0		/BLOCK #
BDR,	0		/DRIVE #
	-600		/WORDS PER BLOCK
	OUTBUF-1	/OUTPUT BUFFER
	WRITE		/FUNCTION
	ISZ NUMBLK	/INCREMINT # OF BLOCKS
	JMP I BPTAP
	PAGE/////////////
/SUBROUTINE TO FIND THE NEXT BLOCK AVAILABLE ON AN 11 DECTAPE
/ENTER WITH INITIAL BLOCK TO CHECK
/DIRECT=0 TO SEARCH FORWARD
/DIRECT=SOMETHING ELSE FOR BACKWARD SEARCH
/RETURNS WITH FIRST EMPTY BLOCK 
FINDBL,	0
	DCA PBMPT	/FIRST BLOCK TO CHECK
FNDBL1,	TAD PBMPT	/IS BLOCK # NEG?
	SPA CLA
	JMP FNDBL5	/YES, REVERSE DIRECTION
	TAD [-1100	/DID WE GO PAST THE LAST BLOCK?
	TAD PBMPT
	SPA CLA		/THIS WORKS CAUSE PBMPT IS NEVER GREATER THAN 5100
	JMP FNDBL4
	IAC
FNDBL5,	DCA DIRECT	/REVERSE DIRECTION
	TAD ENTC	/IS THIS THE END OF A FULL TAPE?
	SNA CLA
	JMP DTFUL	/YES
	DCA ENTC	/NO, CLEAR THE EMPTY TAPE INDICATOR
	TAD DIRECT	/MAKE SURE WE GET A GOOD BLOCK NEXT TIME
	SZA CLA
	TAD (1100
	DCA PBMPT
FNDBL2,	CLA
	TAD DIRECT	/ADD AND TRY AGAIN
	SZA CLA
	L7776
	IAC
	TAD PBMPT
	DCA PBMPT
	JMP FNDBL1

FNDBL4,	TAD PBMPT	/SEE IF BLOCK IS ALREADY USED
	RTR;RAR		/GET OFF SET
	AND (777
	DCA BMOFF
	TAD PBMPT	/GET BIT COUNTER
	AND [7
	CMA
	DCA BITCT
	TAD (PBM	/FIND THE BIT IN THE PBM
	JMS SETBIT	/TRY TO SET IT
	TAD (FBM
	JMS SETBIT	/SET BIT IN FBM
	IAC		/INDICATE THAT WE FOUND A BLOCK ON THIS PASS OF THE TAPE
	DCA ENTC
	TAD PBMPT	/RETURN TJTH THE BLOCK #
	JMP I FINDBL

SETBIT,	0
	TAD BMOFF	/GET ABSOLUTE ADDRESS
	DCA WDPT
	TAD BITCT
	DCA BITCTG	/COPY BITCOUNTER TWICE
	TAD BITCT
	DCA BITCTS
	TAD I WDPT
SETB1,	RAR		/GET BIT INTO LINK
	ISZ BITCTG
	JMP SETB1
	SZL
	JMP FNDBL2	/BLOCK WAS ALREADY USED
	STL		/SET BIT
SETB2,	RAL
	ISZ BITCTS	/PUT BIT BACK
	JMP SETB2
	DCA I WDPT	/PUT WORD BACK
	JMP I SETBIT

/ERROR ROUTINES (FATAL ERRORS RETURN TO COMMAND DECODER)
COUFF,	TAD [-6
	DCA CHRCTR
	TAD (INPUT+1
	DCA CHRAD
	DCA SW
COU1,	JMS UNPAC
	JMP COU2
	JMS ATOUT
	JMP COU1
COU2,	TAD (".
	JMS TTYOUT
	L7776
	DCA CHRCTR
	JMS UNPAC
	JMP .+3
	JMS ATOUT
	JMP .-3
	CMA
	DCA CHRCTR
	TAD (EXT3
	DCA CHRAD
	JMS UNPAC
	NOP
	JMS ATOUT
COU3,	TAD (COUFFM
	JMP MESOUT
IMBD,	CLA
	TAD IOSW	/PRINT OUT THE CORRECT ERROR MESSAGE
	SNA CLA
	TAD (IMBDM-F4MBM
	TAD (F4MBM
	JMP MESOUT
F4NF,	TAD (F4NFM-FATOIM
FATONI,	TAD (FATOIM-FAEXM
FAEX,	TAD (FAEXM-BADNM
BADNUM,	TAD (BADNM-DTFULM
DTFUL,	TAD (DTFULM-DONEXM
DONEX,	TAD (DONEXM-NRODM
NROD,	TAD (NRODM-CLERRM
CLERR,	TAD (CLERRM-SELERM
SELER,	TAD (SELERM
	JMP	MESOUT	/ADDED TO CORRECT   [SE]

PAGE

MESOUT,	DCA CHRAD
	TAD I CHRAD	/GET COUNTER
	ISZ CHRAD
	DCA CHRCTR
	DCA SW
	JMS UNPAC
	JMP .+3
	JMS TTYOUT
	JMP .-3
	JMS CRLF
	JMP DECAGN
/NUMBER OF DAYS IN EACH MONTH FOR DATE CONVERSION
MONTHS,	JAN;FEB;MAR;APR;MAY;JUN;JUL;AUG;SEP;OCT;NOV;DEC;700

/ERROR MESSAGES
IMBDM,	-25;TEXT 'INPUT MUST BE DECTAPE'
COUFFM,	-12;TEXT ' NOT FOUND'
F4MBM,	-26;TEXT 'OUTPUT MUST BE DECTAPE'
F4NFM,	-34;TEXT 'NO OUTPUT FILE NAMES ALLOWED'
DTFULM,	-23;TEXT 'OUTPUT TAPE IS FULL'
DONEXM,	-25;TEXT 'DEVICE DOES NOT EXIST'
NRODM,	-21;TEXT 'NO ROOM ON DEVICE'
CLERRM,	-22;TEXT 'ERROR CLOSING FILE'
PAGE
SELERM,	-24;TEXT 'DECTAPE SELECT ERROR'
BADNM,	-12;TEXT 'BAD NUMBER'
FATOIM,	-13;TEXT 'INPUT ERROR'
FAEXM,	-32;TEXT 'OUTPUT FILE ALREADY EXISTS'
/
/
/
/ SHIFT LEFT SUBROUTINE
/
/
SUBSHL,	0
	DCA ZROAC	/ SAVE AC
	TAD I SUBSHL	/ GET SHIFT COUNT
	CMA		/ COMPLEMENT IT
	DCA ROTCNT	/ STORE COUNT
	ISZ SUBSHL	/ INCREMENT TO RETURN ADDRESS
MOROT,	TAD ZROMQ	/ GET MQ WORD
	CLL RAL		/ SHIFT LEFT ONE BIT
	DCA ZROMQ	/ SAVE AS NEW MQ
	TAD ZROAC	/ GET AC WORD
	RAL		/ SHIFT LEFT ONE BIT
			/ WITH LINK FROM MQ SHIFT
	DCA ZROAC	/ STORE NEW AC
	ISZ ROTCNT	/ DONE ROTATING?
	JMP MOROT	/ NO, ROTATE AGAIN
	TAD ZROAC	/ SET UP AC FOR RETURN
	JMP I SUBSHL	/ RETURN TO CALLING PROGRAM
ROTCNT,	0
ZROMQ,	0
ZROAC,	0
/
/
/
/ MQ REGISTER LOAD ROUTINE
/
/
SUBMQL,	0
	DCA ZROMQ	/ TRANSFER AC TO MQ
	JMP I SUBMQL	/ RETURN TO CALLING PROGRAM
/
/
/ SUBROUTINE TO PERFORM "OR" OF AC AND MQ
/
/
SUBMQA,	0
	DCA ZROAC	/ STORE AC CONTENTS
	TAD ZROMQ	/ GET MQ
	CMA		/ COMPLEMENT IT
	DCA TEMP	/ STORE IT
	TAD ZROAC	/ GET AC
	CMA		/ COMPLEMENT IT
	AND TEMP	/ AND WITH COMPLEMENTED MQ
	CMA		/ COMPLEMENT RESULT
	JMP I SUBMQA	/ EXIT WITH DESIRED RESULT IN AC
/
/
/ MULTIPLY ROUTINE
/
/
MQMULT,	0
	DCA ZROMQ	/ LOAD MQ FROM AC
	DCA RESHI	/ CLEAR HIGH ORDER RESULT
	DCA RESLOW	/ CLEAR LOW ORDER RESULT
	TAD I MQMULT	/ GET MULTIPLIER
	CIA		/ NEGATE FOR COUNTER
	DCA MULADR	/ STORE COUNTER
	ISZ MQMULT	/ INCREMENT TO RETURN ADDRESS
NXTMUL,	CLL		/ CLEAR LINK
	TAD ZROMQ	/ GET MQ
	TAD RESLOW	/ ADD LOW ORDER
	DCA RESLOW	/ STORE NEW LOW ORDER
	GLK		/ GET LINK
	TAD RESHI	/ ADD HIGH ORDER
	DCA RESHI	/ STORE HIGH ORDER
	ISZ MULADR	/ INCREMENT COUNT
	JMP NXTMUL	/ LOOP IF NOT DONE
	CLL		/ DONE, CLEAR LINK
	TAD RESLOW	/ GET LOW ORDER
	DCA ZROMQ	/ STORE IN MQ
	TAD RESHI	/ PUT HIGH ORDER IN AC
	JMP I MQMULT	/ RETURN TO CALLING PROGRAM
RESLOW,	0
RESHI,	0
MULADR,	0
/
/
/ DIVIDE ROUTINE, SINGLE PRECISION ONLY
/
/
MQDIV,	0
	DCA ZROMQ	/ LOAD MQ FROM AC
	DCA QUOTNT	/ CLEAR QUOTIENT
	TAD I MQDIV	/ GET DIVISOR
	CIA		/ NEGATE IT
	DCA DIVISR	/ STORE - DIVISOR
	ISZ MQDIV	/ INCREMENT TO RETURN ADDRESS
NXTDIV,	TAD ZROMQ	/ GET MQ
	TAD DIVISR	/ SUBTRACT DIVISOR
	SPA		/ IS RESULT < 0?
	JMP DIVDON	/ YES, SET UP QUOTIENT & REMAINDER
	DCA ZROMQ	/ NO, STORE NEW MQ
	ISZ QUOTNT	/ INCREMENT QUOTIENT
	JMP NXTDIV	/ LOOP UNTIL DONE
/
/
DIVDON,	CLA CLL
	TAD ZROMQ	/ GET REMAINDER OF MQ
	DCA ZROAC	/ STORE IN AC WORD
	TAD QUOTNT	/ GET QUOTIENT
	DCA ZROMQ	/ STORE IN MQ
	TAD ZROAC	/ GET REMAINDER IN AC
	JMP I MQDIV	/ RETURN TO CALLING PROGRAM
QUOTNT,	0
DIVISR,	0
PAGE

/THIS SUBROUTINE CONTAINS THE CODE WHICH GETS
/THE DRIVE SELECT WORD FOR THE SPECIFIED DECTAPE.
/'IOWD' POINTS TO EITHER THE INPUT OR OUTPUT DEVICE
/NUMBER.  IF THE DEVICE IS A DECTAPE, ITS DRIVE NUMBER
/IS FOUND AND SHIFTED FOR DECTAPE DRIVE SELECTION THEN PUT
/INTO 'GDR'.  IF THE DEVICE IS NOT A DECTAPE, 'IMBD' IS
/CALLED TO INFORM THE USER THAT HE DOESN'T KNOW WHAT HE
/IS DOING....


GETDN,	0
	TAD (-10	/8 POSSIBLE DRIVE #'S
	DCA TEMP
	TAD DEVDT0	/DT
	DCA DEV
	TAD TEMP	/A#
	CMA
	TAD DEVDT0+1
	DCA DEV+1
	JMS INQR
	JMP NEXTDT	/DEVICE DOESN'T EXIST -- TRY ANOTHER ONE
	CIA
	TAD I IOWD	/SAME DEVICE NUMBER?
	SZA CLA
	JMP NEXTDT	/NOPE
	TAD TEMP	/YES, MOVE UP FOR DRIVE SELECT
	CMA
	CLL RTR
	RTR
	DCA GDR		/DUMP IT
	JMP I GETDN	/AND GET OUT OF HERE
NEXTDT,	ISZ TEMP
	JMP GETDN+3
	JMP IMBD	/AIN'T NO MORE DRIVE #'S -- NICE TRY.

DEVDT0,	DEVICE DTA0

RAD50,	" ;"A;"B;"C;"D;"E;"F;"G;"H;"I;"J;"K;"L;"M;"N;"O;"P;"Q;"R;"S
	"T;"U;"V;"W;"X;"Y;"Z;"$;".;"?;"0;"1;"2;"3;"4;"5;"6;"7;"8;"9

GTHDLR,	0
	TAD OUTPUT	/OUTPUT DEVICE SPECIFIED?
	SZA CLA
	JMP OPNFIL
	TAD DEVTTY	/NO, MAKE IT THE TTY:
	DCA DEV
	TAD DEVTTY+1
	DCA DEV+1
	JMS INQR
	JMP IMBD	/NO TTY?!
	DCA OUTPUT
OPNFIL,	TAD (4001	/PUT HANDLER AT 4000   [SE]
	DCA OUTDEV
	TAD OUTPUT
	JMS I USR
	FETCH		/GO GET DEVICE HANDLER
OUTDEV,	0
	JMP DONEX
	TAD (OUTPUT+1
	DCA BLOCKO
	TAD OUTPUT
	JMS I USR
	ENTER
BLOCKO,	0
BLCTRO,	0
	JMP NROD
	TAD OUTDEV
	DCA HANDLR
	JMP I GTHDLR

DEVTTY,	DEVICE TTY

DIR,	CLA		/PROTECT FOLLOWING      [SE]
	TAD (DIRLOC	/SWAP IN DIRECTORY LISTING SECTION
	DCA TEMP	/FROM FIELD 0
	TAD (-1000
	DCA TEMP1
	CDF
	TAD I TEMP
	CDF CIF 10
	DCA I TEMP
	ISZ TEMP
	ISZ TEMP1
	JMP .-6
	JMP DIRLOC

	PAGE
FIELD 0
*6400

DRCTRY,	JMS GTHDLR
	TAD (INBUF
	DCA HNDLOC
	TAD (102	/LOAD BUFFER WITH FIRST BLOCK
	DCA GBL		/OF DIRECTORY IN A PACKED FORMAT
	DCA EMPTY
	DCA CTR
	JMS BGTAP
	JMS DIRCT	/DUMP IT
	ISZ GBL		/GET NEXT BLOCK
	JMS BGTAP
	JMS DIRCT	/DUMP IT
	TAD CTR	/# FILES, # BLOCKS, # FREE
	JMS PAKNUM
	TAD (212
	DCA TEMPB2
	JMS PACK
	TAD (FILES
	DCA TEMP
TOTAL,	TAD I TEMP
	SNA
	JMP .+4
	JMS DUMP
	ISZ TEMP
	JMP TOTAL
	TAD (-20	/PUT IN NUMBERS
	JMS REPACK	/# BLOCKS USED
	TAD EMPTY	/# BLOCKS FREE
	CIA
	TAD (1062
	DCA EMPTY
	TAD (5
	JMS REPACK
	ISZ CTR
	ISZ CTR
	TAD CTR
	MQLMUY;11
	TAD ZROMQ
	MQLDVI;100
	SZA CLA
	ISZ ZROMQ
	TAD ZROMQ
	RTL
	RTL
	RTL
	TAD (4000
	DCA NUM128
	TAD BLOCKO
	DCA BLCK
	CIF
	JMS I HANDLR
NUM128,	0
	INBUF
BLCK,	0
	SMA CLA
	SKP
	DCA ZROMQ	/FATAL ERROR, ZERO RECORD COUNT
	CLA
	TAD (OUTPUT+1
	DCA CLSE
	TAD ZROMQ
	DCA REC128
	TAD OUTPUT
	JMS I USR
	CLOSE
CLSE,	0
REC128,	0
	JMP CLERR
	JMP FIN		/FINISHED

REPACK,	0
	TAD HNDLOC
	DCA HNDLOC
	TAD EMPTY
	JMS PAKNUM
	TAD (240
	DCA TEMPB1
	CMA
	JMS PACK
	TAD (6000
	TAD TEMPB4
	JMS DUMP
	JMP I REPACK

	PAGE
DIRCT,	0
	TAD (-17	/34 ENTRIES PER BLOCK +1 PHONY
	DCA UNPAK
	TAD (INBUF-14	/ENTRIES PACKED STARTING HERE, WITH
	DCA PAKLOC	/ONE PHONY ENTRY AT BEGINNING
NPAK,	TAD (BUFFER	/TWO UNPACKED ENTRIES STORED HERE
	DCA UNPAKL
	TAD (-11	/TWO ENTRIES PACKED IN 9 THREE-WORD
	DCA UNPAKN	/LOCATIONS
	JMS UNPACK
	ISZ UNPAKN
	JMP .-2

	TAD UNPAK	/FIRST TIME THROUGH?
	TAD (17
	SNA CLA
	DCA I (BUFFER	/YES, MAKE PHONY ENTRY LOOK LIKE DELETED FILE
	TAD (BUFFER	/FIRST UNPACKED ENTRY STORED HERE
	JMS ENTRY	/GO DUMP FIRST ENTRY
	TAD (BUFFER+22	/SECOND UNPACKED ENTRY STARTS HERE
	JMS ENTRY	/DUMP SECOND ENTRY
	ISZ UNPAK
	JMP NPAK	/GO GET MORE
	JMP I DIRCT

UNPACK,	0		/ROUTINE TO UNPACK CHARS PACKED BY GETBYT
	CLL IAC
	TAD PAKLOC
	DCA TEMPB1
	TAD I TEMPB1
	AND (7700
	RTR
	RTR
	RTR
	DCA TEMP
	TAD I PAKLOC
	AND (3
	RTL
	RTL
	RTL
	TAD TEMP
	DCA I UNPAKL
	ISZ UNPAKL
	TAD I PAKLOC	/GET SECOND
	ISZ PAKLOC
	ISZ PAKLOC
	AND (1774
	RTR
	DCA I UNPAKL
	ISZ UNPAKL
	TAD I PAKLOC	/GET THIRD
	AND (377
	DCA I UNPAKL
	ISZ UNPAKL
	TAD I TEMPB1	/GET LAST
	AND (17
	RTL
	RTL
	DCA TEMP
	TAD I PAKLOC
	ISZ PAKLOC
	AND (7400
	RTL
	RTL
	RAL
	TAD TEMP
	DCA I UNPAKL
	ISZ UNPAKL
	JMP I UNPACK

PACK,	0		/PACKING ROUTINE FOR DEVICE HANDLER
	TAD (TEMPB2
	DCA TEMP
	TAD I TEMP
	DCA TEMP1
	ISZ TEMP
	TAD I TEMP
	DCA TEMP2
	ISZ TEMP
	TAD I TEMP
	AND (360
	CLL RTL
	RTL
	TAD TEMP1
	JMS DUMP
	TAD I TEMP
	AND (17
	RTR
	RTR
	RAR
	TAD TEMP2
	JMS DUMP
	JMP I PACK

NUMCHK,	0
	TAD TEMPB3
	TAD (-240
	SZA CLA
	JMP I NUMCHK
	TAD (260
	DCA TEMPB3
	JMP I NUMCHK

DUMP,	0
	CDF
	DCA I HNDLOC
	CDF CIF 10
	ISZ HNDLOC
	JMP I DUMP

	PAGE

ENTRY,	0		/THIS NIFTY LITTLE ROUTINE TAKES THE
	DCA UNPAKL	/UNPACKED ENTRY, FIGURES OUT THE NAME,
	TAD I UNPAKL	/EXT, LENGTH AND CREATION DATE AND DUMPS
	SNA CLA		/IT IN A BUFFER FOR SOME DEVICE HANDLER
EXIT,	JMP I ENTRY	/NOTHING THERE
	ISZ CTR	/NUMBER OF ENTRIES PRINTED
	JMS RAD		/CONVERT FROM RADIX-50
	JMS PACK	/PACK AND STORE THEM
	JMS RAD
	JMS PACK
	TAD (".
	DCA TEMPB1
	JMS RAD		/EXTENSION
	CMA
	JMS PACK
	TAD TEMPB4
	DCA GETW
	TAD UNPAKL
	TAD (6
	DCA TEMPB1
	TAD I TEMPB1
	DCA TEMP
	ISZ TEMPB1
	TAD I TEMPB1	/LENGTH
	CLL RTR		/PERFORM BYTE SWAP
	RTR
	RAR
	TAD TEMP	
	DCA TEMP
	TAD TEMP	/FOR FIGURING # BLOCKS USED
	TAD EMPTY
	DCA EMPTY
	TAD TEMP
	JMS PAKNUM
	TAD (240
	DCA TEMPB1
	CLL CMA RAL
	JMS PACK
	TAD I UNPAKL	/CONTIGUOUS FILE?
	SMA CLA
	TAD (-43
	TAD (303	/YES, PRINT A 'C'
	DCA TEMBP1
	IAC
	JMS PACK
	DCA MONTH	/GET DATE
	TAD I UNPAKL
	DCA TEMP
	TAD TEMP
	AND (770
	CLL RTR
	RAR
	DCA TEMP1
	ISZ UNPAKL
	TAD I UNPAKL
	AND (3777
	RTL
	RTL
	RAL
	TAD TEMP1
	MQLDVI;175	/DIVIDE BY 1000[10] TO GET YEAR
	RTL
	RAL
	DCA TEMP2
	TAD TEMP
	AND (7
	TAD TEMP2	/DAY OF YEAR
	DCA I UNPAKL
	TAD ZROMQ	/YEAR
	DCA YEAR
	DCA DATEB
	STL RTL
	TAD YEAR	/LEAP YEAR?
	CLL RTR
	SMA SNL CLA
	SKP
	JMP DATCAL-2
	ISZ DATEB
	TAD I UNPAKL	/MONTH GREATER THAN FEB?
	TAD (-74
	SPA
	JMP DATCAL-4
	SZA CLA
	JMP DATCAL-2
	TAD (35		/FEB. 29 IS A SPECIAL CASE
	DCA TEMPB1
	STL RTL
	JMP DTPRNT
	CLA
	DCA DATEB
	TAD (MONTHS
	DCA TEMP
DATCAL,	TAD I UNPAKL
	CIA
	TAD I TEMP
	TAD DATEB
	SMA
	JMP .+6
	CIA
	DCA TEMPB1
	ISZ MONTH
	ISZ TEMP
	JMP DATCAL
	CLA CLL
	TAD MONTH	/DUMP MONTH
DTPRNT,	JMS PAKNUM
	JMS NUMCHK
	JMP ENTRY1

MONTH,	0

	PAGE
ENTRY1,	JMS PACK
	TAD TEMPB1
	JMS PAKNUM
	JMS NUMCHK
	TAD ("/
	DCA TEMPB2
	JMS PACK
	TAD ("7
	DCA TEMPB3
	TAD YEAR
	TAD (260
	DCA TEMPB4
	JMS PACK
	DCA TEMPB2
	TAD (215	/CRLF
	DCA TEMPB3
	TAD (212
	DCA TEMPB4
	JMS PACK
	JMP EXIT

RAD,	0		/ROUTINE TO CONVERT FROM RADIX-50
	TAD I UNPAKL	/TO 3 ASCII CHARS.
	DCA TEMBP1
	ISZ UNPAKL
	TAD I UNPAKL
	ISZ UNPAKL
	CLL RTL		/CHEAP WAY OF DIVIDING BY 1600[10] TO
	DCA TEMPB3	/GET FIRST CHAR
	TAD TEMBP1	/FIRST DIVIDE BY 100 SO THERE'S NO
	AND (300	/HASSLE WITH DOUBLE PRECISION
	RTR
	RTR
	RTR
	TAD TEMPB3
	MQLDVI;31	/NOW DIVIDE BY 31
	DCA TEMPB4	/SAVE REMAINDER
	TAD ZROMQ
	TAD (RAD50
	DCA TEMPG2
	TAD I TEMPG2	/GET RADIX-50 CHAR AND SAVE
	DCA TEMPB2
	TAD TEMBP1	/GET SECOND CHAR
	AND (77
	DCA TEMPB3
	TAD TEMPB4
	RTL
	RTL
	RTL
	TAD TEMPB3
	MQLDVI;50	/DIVIDE REMAINDER BY 40[10]
	DCA TEMPB4
	TAD (RAD50
	TAD ZROMQ
	DCA TEMPG2
	TAD I TEMPG2	/SECOND CHAR

	DCA TEMPB3
	TAD (RAD50
	TAD TEMPB4
	DCA TEMPG2
	TAD I TEMPG2	/THIRD CHAR
	DCA TEMPB4
	JMP I RAD

FILES,	6240	/FI
	4706
	6714	/LES
	1705
	6240	/ IN
	7311
	1	/ ##
	1
	1	/# B
	1240
	6314	/LOC
	1717
	5313	/KS,
	6323
	1	/ ##
	1
	1	/# F
	3240
	6322	/REE
	2705
	4615	/CR LF ^Z
	5212
	0

PAKNUM,	0		/ROUTINE TO CHANGE 3-DIGIT OCTAL #
	MQLDVI;144	/TO 3 DECIMAL ASCII DIGITS
	DCA TEMPB3
	TAD ZROMQ
	SNA
	TAD (-20	/CHANGE LEADING ZERO TO SPACE
	TAD (260
	DCA TEMPB2
	TAD TEMPB3
	MQLDVI;12
	TAD (260
	DCA TEMPB4
	TAD TEMPB2
	TAD (-240
	SNA CLA
	JMP .+3
	TAD ZROMQ
	JMP .+4
	TAD ZROMQ
	SNA
	TAD (-20	/CHANGE SECOND ZERO TO SPACE
	TAD (260
	DCA TEMPB3
	JMP I PAKNUM

$