/ BEAM COPY PROGRAM
	*100
MSG,	AMSG
NGETLN,	ANGLN
ERR,	0
DTIO,	ADTIO
SEARCH,	ASEARC
BN,	0
ID,	0
PTR,	0
CHR2,	0
CHR,	0
/
/
	IBUF=PROGEN
	OBUF=IBUF+1205
	BFR=OBUF+603
/
/
/
	*200
	TLS
	KRB
ISTART,	CLA CLL
	TAD (ISTART)	/SET ERROR
	DCA ERR
	TAD (MSG01)	/BEAM COPY__INPUT UNIT:
	JMS I MSG
	JMS I NGETLN	/GET UNIT NO
	RTR		/STORE UNIT NO
	RTR
	AND (7000)
	DCA UNIT
	TAD (MSG02)	/INPUT ID:
	JMS I MSG
	JMS I NGETLN	/GET ID NO
	DCA ID
	TAD (IBUF-1)	/SET CORE ADDRESS
	DCA LOC
	TAD (1000)	/SET BLOCK NO
	DCA BLOCK
	TAD (-1205)	/SET LENGTH OF TRANSFER
	DCA LENGTH
	JMS I DTIO
	TAD ID		/SET ID FOR SEARCH
	JMS I SEARCH
	 NOP
	JMP ERR1
	TAD BN		/SET BLOCK FOR READ
	DCA BLOCK
	TAD (-603)	/SET LENGTH OF TRANSFER
	DCA LENGTH
	TAD (OBUF-1)	/SET CORE ADDRESS
	DCA LOC
	JMS I DTIO	/READ BEAM DATA INPUT
OSTART,	TAD (OSTART)	/SET ERROR
	DCA ERR
	TAD (MSG05)	/OUTPUT UNIT:
	JMS I MSG
	JMS I NGETLN	/GET UNIT NO
	RTR		/STORE UNIT NO
	RTR
	AND (7000)
	DCA UNIT
	TAD (MSG06)	/OUTPUT ID
	JMS I MSG
	JMS I NGETLN
	DCA ID		/STORE ID NO
	TAD (IBUF-1)	/SET CORE ADDRESS
	DCA LOC
	TAD (1000)	/SET BLOCK
	DCA BLOCK
	TAD (-1205)	/SET LENGTH
	DCA LENGTH
	JMS I DTIO	/READ DIRECTORY - OUTPUT
	TAD ID
	JMS I SEARCH
	 JMP ERR2
	 JMP .+2
	 JMP ERR3
	CLA CLL CMA RAL	/SET AC=-2
	TAD 10
	DCA 10
	TAD I 10	/GET LAST BLOCK NO
	TAD (3)
	DCA BN
	TAD ID
	DCA I 10	/STORE AS NEXT BLOCK NO
	TAD BN
	DCA I 10
	DCA I 10	/CLEAR NEXT BLOCK NO
	IAC
	JMS I DTIO	/WRITE NEW DIRECTORY
	TAD BN
	DCA BLOCK
	TAD (OBUF-1)	/SET BUFFER
	DCA LOC
	TAD (-603)	/SET LENGTH
	DCA LENGTH
	JMS I DTIO	/WRITE NEW BEAM
	TAD (MSG09)
	JMS I MSG	/__DONE(Y OR N)?:
	JMS GETC
	TAD (-331)
	SNA CLA
	JMP 7600
	JMP ISTART
/
/
/
	PAGE
ASEARC,	0
	CIA	/SET SEARCH ID
	DCA SID
	TAD LOC
	DCA 10	/SET BUFFER POINTER
	TAD (-502)	/SET COUNTER
	DCA 11
SLOOP,	TAD I 10
	SNA
	JMP EXIT2	/BLOCK NO IS 0 - END DIRECTORY
	TAD SID
	SNA CLA
	JMP EXIT3	/ID FOUND - EXIT NORMAL
	ISZ 10
	ISZ 11
	JMP SLOOP
	JMP EXIT1	/END OF DIRECTORY AREA
EXIT3,	ISZ ASEARC	/NORMAL RETURN
	TAD I 10
	DCA BN
EXIT2,	ISZ ASEARC	/ERROR2 RETURN
EXIT1,	JMP I ASEARC	/ERROR1 RETURN
SID,	0
/
/
/
ADTIO,	0
	TAD UNIT
	DCA UNIT
	JMS IDTAPE
UNIT,	0
BLOCK,	0
LENGTH,	0
LOC,	0
	ERROR
	JMP I ADTIO
ERROR,	CLA CLL
	TAD (MSG03)	/DECTAPE ERROR
	JMS I MSG
	JMP I ERR
/
/
ERR1,	TAD (MSG04)	/ID NOT FOUND
	JMS I MSG
	JMP I ERR
/
ERR2,	TAD (MSG07)	/DIRECTORY FULL
	JMS I MSG
	JMP I ERR
/
ERR3,	TAD (MSG08)	/ID USED ALREADY
	JMS I MSG
	JMP I ERR
/
/
/
ANGLN,	0
	TAD (BFR-1)
	DCA 12
NXTCR,	JMS GETC	/GET CHARACTER
	DCA CHR
	TAD CHR
	TAD (-215)	/IS IT CR
	SNA
	JMP LININ	/YES
	TAD (215-377)	/RO?
	SZA CLA
	JMP STR
	CLA CMA
	TAD 12
	DCA 12
	JMP NXTCR
STR,	TAD CHR		/OK CHR - STORE IT
	TAD (-260)
	DCA I 12
	JMP NXTCR
LININ,	DCA CHR
	TAD 12
	CIA
	DCA PTR
	TAD (BFR-1)
	DCA 12
NLOOP,	TAD 12		/CHECK BUFFER POSITION
	TAD PTR
	SMA CLA
	JMP OUT
	CLL CLA
	TAD CHR		/MULTIPLY BY 10.
	RAL
	DCA CHR
	TAD CHR
	RTL
	TAD CHR
	TAD I 12	/ADD THIS DIGIT
	DCA CHR
	JMP NLOOP
OUT,	TAD CHR
	JMP I ANGLN
/
/
GETC,	0
	KSF
	JMP .-1
	KRB
	TLS
	JMP I GETC
/
/
/
/
	PAGE
AMSG,	0
	TAD (-1)
	DCA 13
NXTM,	TAD I 13
	DCA CHR2
	TAD CHR2
	RTR CLL
	RTR
	RTR
	AND (77)
	JMS PTRC
	TAD CHR2
	AND (77)
	JMS PTRC
	JMP NXTM
PTRC,	0
	DCA CHR
	TAD CHR
	SNA
	JMP I AMSG
	TAD (-37)
	SNA CLA
	JMP CRLF
	TAD CHR
	TAD (240)
	AND (277)
	TAD (40)
	JMS PRTCH
	JMP I PTRC
CRLF,	TAD (215)
	JMS PRTCH
	TAD (212)
	JMS PRTCH
	JMP I PTRC
/
PRTCH,	0
	TSF
	JMP .-1
	TLS
	CLA CLL
	JMP I PRTCH
/
/
	PAGE
MSG01,	TEXT /___BEAM COPY__INPUT UNIT: /
MSG02,	TEXT /_INPUT ID: /
MSG03,	TEXT /____DECTAPE ERROR!!!__/
MSG04,	TEXT /_ID NOT FOUND_/
MSG05,	TEXT /_OUTPUT UNIT: /
MSG06,	TEXT /_OUTPUT ID: /
MSG07,	TEXT /_DIRECTORY FULL_/
MSG08,	TEXT /_ID ALREADY USED_/
MSG09,	TEXT /__DONE(Y OR N)? : /
/
	PAGE
ID7400,	7400
IDTAPE,	0
	CLA
	TAD I IDTAPE
	DCA IDCODE
	ISZ IDTAPE
	TAD IDCODE
ID0200,	AND ID7400
	TAD ID0010
	DTCA DTXA
	DTLB
	TAD IDWC
	DCA I IDCA
IDSERR,	RTL
	RAL
	CLA CML
	TAD ID0200
IDCONT,	SNL
	TAD ID0400
	DTXA
	DTSF DTRB
	JMP .-1
	SPA
	JMP IDSERR
	DTRA
	RTL
RTL
	SZL CLA
	TAD ID0002
	TAD I IDWC
	CMA
	TAD I IDTAPE
	CMA
	SZA CLA
	JMP IDCONT
	SZL
	JMP IDCONT+1
	ISZ IDTAPE
	TAD I IDTAPE
	DCA I IDWC
	ISZ IDTAPE
	TAD I IDTAPE
	DCA I IDCA
	TAD IDCODE
	DTLB
	IAC
	AND IDCODE
	RTL CLL
	RTL
	TAD ID0130
	DTXA
	DTSF DTRB
	JMP .-1
	ISZ IDTAPE
	SMA
	ISZ IDTAPE
	SPA CLA
	TAD IDCODE
	RTR
	SNL CLA
	JMP .+3
	TAD I IDTAPE
	DCA IDTAPE
	DTRA
	AND ID0200
	TAD ID0002
	DTXA
	JMP I IDTAPE
IDWC,	7754
IDCA,	7755
ID0010,	10
ID0400,	400
ID0130,	130
ID0002,	2
IDCODE,	0

/
/
/
/
PROGEN,	0
	$$$


/	BEAM TRANSFER PROGRAM
/
	*100
MSG,	AMSG
NGETLN,	ANGETLN
ERR,	0
DTIO,	ADTIO
SEARCH,	ASEARC
BN,	0
ID,	0
CHR,	0
	IBUF=1000
	OBUF=IBUF+1205
	BFR=OBUF+603
/
/
/	MAIN PROGRAM
	*200
	TLS
	6036
ISTART,	CLA CLL
	TAD (ISTART)	/SET ERROR
	DCA ERR
	TAD (MSG01)	/"__BEAM COPY__INPUT UNIT: "
	JMS I MSG
	JMS I NGETLN	/GET UNIT NO
	RTR
	RTR
	AND (777)
	DCA UNIT	/STORE UNIT NO
	TAD (MSG02)	/"INPUT ID: "
	JMS I MSG
	JMS I NGETLN	/GET INPUT ID
	DCA ID
	TAD (IBUF-1)	/SET CORE ADDRESS
	DCA LOC
	TAD (1000)	/SET BLOCK NO
	DCA BLOCK
	TAD (-1205)
	DCA LENGTH	/SET LENGTH
	JMS I DTIO	/READ DIRECTORY
	TAD ID		/SET FOR ID SEARCH
	JMS I SEARCH
	NOP
	JMP ERR1
	TAD BN		/SET BLOCK TO READ
	DCA BLOCK
	TAD (-603)	/SET LENGTH
	DCA LENGTH
	TAD (OBUF-1)	/SET BUFFER
	DCA LOC
	JMS I DTIO	/READ IN BEAM DATA
OSTART,	TAD (OSTART)	/SET ERROR
	DCA ERR
	TAD (MSG05)	/"_OUTPUT UNIT: "
	JMS I MSG
	JMS I NGETLN	/GET OUTPUT UNIT
	RTR
	RTR
	AND (777)
	DCA UNIT	/STORE UNIT
	TAD (MSG06)	/"OUTPUT ID: "
	JMS I MSG
	JMS I NGETLN	/GET ID
	DCA ID
	TAD (IBUF-1)	/SET BUFFER
	DCA LOC
	TAD (1000)	/SET FOR OUTPUT DIRECTORY
	DCA BLOCK
	TAD (-1205)	/SET LENGTH
	DCA LENGTH
	JMS I DTIO	/READ DIRECTORY
	TAD ID
	JMS I SEARCH	/FIND ID
	JMP ERR2	/DIRECTORY FULL
	JMP .+2		/ID NOT FOUND IN DIRECTORY
	JMP ERR3	/ID ALREADY IN DIRECTORY
	CLA CLL CMA RAL	/AC=-2
	TAD 10
	DCA 10
	TAD I 10	/GET LAST BLOCK NO
	TAD (3)		/SET TO FREE AREA
	ISZ 10
	DCA BN		/STORE NEW BLOCK NO
	TAD BN
	DCA I 10
	TAD ID
	DCA I 10	/STORE NEW ID
	DCA I 10	/MARK NEW DIRECTORY END
	IAC		/SET FOR WRITE
	JMS I DTIO	/WRITE DIRECTORY
	TAD BN		/SET BLOCK NO
	DCA BLOCK
	TAD (OBUF-1)	/SET BUFFER
	DCA LOC
	TAD (-603)	/SET LENGTH
	DCA LENGTH
	IAC		/SET FOR WRITE
	JMS I DTIO	/WRITE DATA
	JMP ISTART	/GO BACK TO BEGINNING
/
/
	*400
ASEARC,	0
	CIA	/SET SEARCH ID
	DCA SID
	TAD LOC		/SET BUFFER POINTER
	DCA 10
	TAD (-502)	/SET COUNTER
	DCA 11
SLOOP,	TAD I 10	/GET BLOCK NO
	SNA
	JMP EXIT2	/END OF DIRECTORY
	DCA BN		/SAVE CURRENT BLOCK NO
	TAD I 10	/COMPARE ID WITH THIS ENTRY'S
	TAD SID
	SMA CLA
	JMP EXIT3	/FOUND ID MATCH
	ISZ 11		/NOT FOUND - CHECK POSITION
	JMP SLOOP
	JMP EXIT1	/OUT OF DIRECTORY SPACE
EXIT3,	IS
/	BEAM TRANSFER PROGRAM
/
	*100
MSG,	AMSG
NGETLN,	ANGETLN
ERR,	0
DTIO,	ADTIO
SEARCH,	ASEARC
BN,	0
ID,	0
CHR,	0
	IBUF=1000
	OBUF=IBUF+1205
	BFR=OBUF+603
/
/
/	MAIN PROGRAM
	*200
	TLS
	6036
ISTART,	CLA CLL
	TAD (ISTART)	/SET ERROR
	DCA ERR
	TAD (MSG01)	/"__BEAM COPY__INPUT UNIT: "
	JMS I MSG
	JMS I NGETLN	/GET UNIT NO
	RTR
	RTR
	AND (777)
	DCA UNIT	/STORE UNIT NO
	TAD (MSG02)	/"INPUT ID: "
	JMS I MSG
	JMS I NGETLN	/GET INPUT ID
	DCA ID
	TAD (IBUF-1)	/SET CORE ADDRWQS
	QAA LOC
	TAD (1000)	/SET BLOCK NO
	DCA BLOCK
	TAD (-1205)
	DCA LENGTH	/SET LENGTH
	JMS I DTIO	/READ DIRECTORY
	TAD ID		/SET FOR ID SEARCH
	JMS I SEARCH
	NOP
	JMP ERR1
	TAD BN		/SET BLOCK TO READ
	DCA BLOCK
	TAD (-603)	/SET LENGTH
	DCA LENGTH
	TAD (OBUF-1)	/SET BUFFER
	DCA LOC
	JMS I DTIO	/READ IN BEAM DATA
OSTART,	TAD (OSTART)	/SET ERROR
	DCA ERR
	TAD (MSG05)	/"_OUTPUT UNIT: "
	JMS I MSG
	JMS I NGETLN	/GET OUTPUT UNIT
	RTR
	RTR
	AND (777)
	DCA UNIT	/STORE UNIT
	TAD (MSG06)	/"OUTPUT ID: "
	JMS I MSG
	JMS I NGETLN	/GET ID
	DCA ID
	TAD (IBUF-1)	/SET BUFFER
	DCA LOC
	TAD (1000)	/SET FOR OUTPUT DIRECTORY
	DCA BLOCK
	TAD (-1205)	/SET LENGTH
	DCA LENGTH
	JMS I DTIO	/READ DIRECTORY
	TAD ID
	JMS I SEARCH	/FIND ID
	JMP ERR2	/DIRECTORY FULL
	JMP .+2		/ID NOT FOUND IN DIRECTORY
	JMP ERR3	/ID ALREADY IN DIRECTORY
	CLA CLL CMA RAL	/AC=-2
	TAD 10
	DCA 10
	TAD I 10	/GET LAST BLOCK NO
	TAD (3)		/SET TO FREE AREA
	ISZ 10
	DCA BN		/STORE NEW BLOCK NO
	TAD BN
	DCA I 10
	TAD ID
	DCA	TAD (-337)	/CHECK FOR _
	SNA CLA
	JMP CRLF
	TAD CHR
	TAD (240)
	AND (277)
	TAD (40)
	JMS PRTCH
	JMP I PRTC
CRLF,	TAD (215)
	JMS PRTCH
	TAD (212)
	JMS PRTCH
	JMP I PRTC
/
/
PRTCH,	0
	TSF
	JMP .-1
	TLS
	JMP I PRTCH
/
/
/
/
	*BFR+30
MSG01,	TEXT /__BEAM COPY__INPUT UNIT: /
MSG02,	TEXT /_INPUT ID: /
MSG05,	TEXT /_OUTPUT UNIT: /
MSG06,	TEXT /_OUTPUT ID: /
MSG03,	TEXT /__DECTAPE ERROR!!!!____/
MSG04,	TEXT /_ID NOT FOUND /
MSG07,	TEXT /_DIRECTORY FULL?
MSG08,	TEXT /_ID ALREADY USED/
/
/
	PAGE
ID7400,	7400
IDTAPE,	0
	CLA
	TAD I DTAPE
	DCA IDCODE
	ISZ IDTAPE
	TAD IDCODE
ID0200,	AND ID7400
	TAD ID0010
	DTCA DTXA
	DTLB
	TAD IDWC
	DCA I IDCA
IDSERR,	RTL
	RAL
	CLA CML
	TAD ID0200
IDCONT,	SNL
	TAD ID0400
	DTXA
	DTSF DTRB
	JMP .-1
	SPA
	JMP I DSERR
	DTRA
	RTL
	RTL
	SZL CLA
	TAD ID0002
	TAD I IDWC
	CMA
	TAD I IDTAPE
	CMA
	SZA CLA
	JMP IDCONT
	SZL
	JMP IDCONT+1
	ISZ IDTAPE