SaveDatas	lea	$DFF000,A6		;set custom_base

		lea	DataBase(pc),A5		;set data_base

		move.b	D0,FirstTrack(A5)	;first track
		move.b	D1,TrackCount(A5)	;tracks to write
		move.b	D2,DiskSide(A5)		;set diskside
		move.b	D3,DriveNum(A5)		;set drive select
		addq.b	#3,DriveNum(a5)		;generate drive bit
		move.l	A0,Source(A5)		;memory location
		move.l	A1,MFMBuffer(A5)	;DMA buffer
		move.l	A2,SubPart(A5)		;subroutine DOS/CC

		st	TrackError(A5)		;preset write error

		move.l	#$55555555,D5		;mfm encoding bits

* preset count for timer_b **************************************************

		lea	$BFD000,A4		;set ciab_base

		move.b	$F00(A4),ciaCTRLB(A5)	;save ciab_control

		bset	#3,$F00(A4)		;timer b one-shot mode
		move.b	#$14,$600(A4)		;preset timer b low
		move.b	#$0B,$700(A4)		;preset timer b hi, wait 4ms

* set drive and motor on ****************************************************

		or.b	#$78,$100(A4)		;deselect all drives
		bclr	#7,$100(A4)		;set motor on
		move.b	DriveNum(A5),D0		;get drive number
		bclr	D0,$100(A4)		;select drive

		moveq	#0,D0			;reset counter
.wait1		addq.l	#1,D0			;add one
		btst	#Bit,D0			;check for break ?
		bne	SaveError		;branch if so

		btst	#5,$1001(A4)		;disk ready ?
		bne.b	.wait1			;branch if not

*****************************************************************************

		btst	#3,$1001(A4)		;write protected ?
		beq	SaveError		;branch if so

* move head back to track 00 ************************************************

		tst.b	Zero(A5)		;position(A5) known ?
		bne.b	.quit			;yes, skip

		btst	#4,$1001(A4)		;head at track 00 ?
		beq.b	.ready			;branch if so

		bset	#1,$100(A4)		;head direction backward.

.MoveBack	bclr	#0,$100(A4)		;move head.
		bset	#0,$100(A4)		;prepare to move head.

		bset	#0,$F00(A4)		;start timer b one-shot mode
.wait2		btst	#1,$D00(A4)		;head_step requires 3ms=$850
		beq.b	.wait2			;waits ($B14 = 4ms)

		btst	#4,$1001(A4)		;head at track 00 ?
		bne.b	.MoveBack		;branch if not

.ready		clr.b	Position(A5)		;position(A5) = 00 !!
		st	Zero(A5)		;set flag (position known)

.quit

* move head to firsttrack(a5) ***********************************************

		move.b	#$D8,$600(A4)		;set timer b low
		move.b	#$31,$700(A4)		;set timer b hi, wait 18ms
.wait3		btst	#1,$D00(A4)		;settle time 18ms=$31DA
		beq.b	.wait3			;waits ($31DA = 18ms)

		bset	#1,$100(A4)		;head direction backward.

		move.b	Position(A5),D0		;calculate step_count
		sub.b	FirstTrack(A5),D0
		bpl.b	.Move			;move backward

		not.b	D0			;move forward

		bclr	#1,$100(A4)		;head direction forward.

.MoveHead	bclr	#0,$100(A4)		;move head.
		bset	#0,$100(A4)		;prepare to move head.

		move.b	#$14,$600(A4)		;preset timer b low
		move.b	#$0B,$700(A4)		;preset timer b hi, wait 4ms
.wait4		btst	#1,$D00(A4)		;head_step requires 3ms=$850
		beq.b	.wait4			;waits ($B14 = 4ms)

.Move		subq.b	#1,D0			;decrement step_count
		bpl.b	.MoveHead		;do for all steps!

		bclr	#1,$100(A4)		;head direction forward.

		move.b	FirstTrack(A5),Position(A5) ;save current position

* set requested diskside  ***************************************************

		bset	#2,$100(A4)		;set lower side

		tst.b	DiskSide(A5)		;lower side?
		beq.b	.wait5			;branch if so

		bclr	#2,$100(A4)		;set upper side.

.wait5		bset	#0,$F00(A4)		;start timer b one-shot mode
.wait6		btst	#1,$D00(A4)		;flip_side requires 100us=$47
		beq.b	.wait6			;waits ($B14 = 4ms)

		bra.b	WriteTrack		;write track(s)

* move head one cylinder forward ********************************************

WriteNextTrack	moveq	#1,D0			;get count
		add.b	D0,Position(A5)		;increment position

		bclr	#0,$100(A4)		;move head.
		bset	#0,$100(A4)		;prepare to move head.

		bset	#0,$F00(A4)		;start timer b one-shot mode
.wait		btst	#1,$D00(A4)		;head_step requires 3ms=$850
		beq.b	.wait			;waits ($B14 = 4ms)

* encode mfm_buffer / write track to disk ***********************************

WriteTrack	btst	#2,$1001(A4)		;disk removed ?
		beq.b	SaveError		;branch if so

		movea.l	SubPart(A5),A2		;encode track datas
		jsr	(A2)			;either dos or cc

		move.w	#$4000,dsklen(A6)
		move.w	#$0002,intreq(A6)
		move.l	MFMBuffer(A5),dskpt(A6)
		move.w	#$6E00,adkcon(A6)
		move.w	#$9100,adkcon(A6)
		move.w	#$D9A0,dsklen(A6)
		move.w	#$D9A0,dsklen(A6)	;$19A0 words

		moveq	#0,D0

.wait		addq.l	#1,D0
		btst	#Bit,D0
		bne	SaveError

		btst	#1,$1f(A6)
		beq.b	.wait

		subq.b	#1,TrackCount(A5)
		bne.b	WriteNextTrack

		clr.b	TrackError(A5)

*****************************************************************************

SaveError	move.w	#$4000,$24(A6)		;beware accidental writes

* stop drive ****************************************************************

		or.b	#$F8,$100(A4)		;deselect all/motor off
		move.b	DriveNum(A5),D0
		bclr	D0,$100(A4)		;select drive

		move.b	ciaCTRLB(A5),$F00(A4)	;reset ciacontrol_b

		tst.b	TrackError(A5)		;warn user ?
		beq.b	.quit			;no, skip

		bchg	#1,$1001(A4)		;warn user

.quit		tst.b	TrackError(A5)		;set condition return
		rts

* encode cc track ***********************************************************

		cnop	0,4

MakeCCTrack	movea.l	MFMBuffer(A5),A2	;mfm_buffer

		move.w	#$3400/4-1,D0		;mfm_size $3400 bytes
		move.l	#$AAAAAAAA,D1
.ClearMem	move.l	D1,(A2)+		;clear mfm_buffer
		dbra	D0,.ClearMem

		movea.l	MFMBuffer(A5),A2	;get mfm_buffer
		lea	$474(A2),A2		;skip gap

		move.l	#$44894489,4(A2)	;set syncword

		moveq	#-1,D0
		move.b	Position(A5),D0		;get cylinder
		add.b	D0,D0			;calculate real track
		add.b	DiskSide(A5),D0		;calculate real track
		lea	8(A2),A0
		bsr	EncodeBits		;set tracknumber (mfm)

		move.w	#$1400,D0		;blocksize
		movea.l	Source(A5),A0		;get source
		lea	$18(A2),A1		;get dest.
		bsr	Blitter			;encode block datas

		lea	$18(A2),A0		;reset boundary bits
		bsr	SetMSB			;header/block

		lea	$1418(A2),A0		;reset boundary bits
		bsr	SetMSB			;oddbits/evenbits

		lea	$2818(A2),A0		;reset boundary bits
		bsr	SetMSB			;evenbits/gap

		lea	$18(A2),A0
		move.w	#$2800,D1		:blocksize (mfm)
		bsr	GetChkSum		;calc checksum

		lea	$10(A2),A0
		bsr	EncodeBits		;set checksum (mfm)
		add.l	#$1400,Source(A5)	;get next block (track)
		rts

* encode dos track **********************************************************

		cnop	0,4

MakeDTrack	movea.l	MFMBuffer(A5),A2	;mfm buffer

		move.w	#$3400/4-1,D0		;size
		move.l	#$AAAAAAAA,D1		;clear buffer
.ClearMem	move.l	D1,(A2)+
		dbra	D0,.ClearMem

		movea.l	MFMBuffer(A5),A2
		lea	$474(A2),A2		;skip gap

		moveq	#0,D7			;block count

.CreateBlock	moveq	#-1,D0
		move.b	Position(A5),D0		;get cylinder
		add.b	D0,D0			;calculate real track
		add.b	DiskSide(A5),D0		;calculate real track

		swap	D0
		move.w	D7,D0
		lsl.w	#8,D0
		move.b	#11,D0
		sub.b	D7,D0			;set blocknumber

		bsr.b	EncodeDOS		;make mfm_datas (dos track)

		lea	$440(A2),A2
		add.l	#$200,Source(A5)

* do a bit TML! promotion *********************

		cmp.b	#1,D7
		blt.b	.skip

		sub.l	#$200,Source(A5)
		movea.l	Source(A5),A0
		cmp.l	#"TML!",(A0)
		beq.b	.skip

		moveq	#63,D0
.promotion	move.l	D0,D1
		lsl.l	#3,D1
		move.l	#"TML!",0(A0,D1.w)
		move.l	#"2001",4(A0,D1.w)
		dbra	D0,.promotion
.skip

***********************************************

		addq.b	#1,D7
		cmp.b	#11,D7			;max. 11 blocks
		blt.b	.CreateBlock
		rts

*****************************************************************************

EncodeDOS	move.l	D0,D4
		move.l	A2,A0
		moveq	#0,D0
		bsr	EncodeBits

		move.l	#$44894489,4(A2)	;set syncword

		lea	8(A2),A0
		move.l	D4,D0
		bsr	EncodeBits		;insert track/block number

		moveq	#3,D4
.loop		moveq	#0,D0
		bsr	EncodeBits		;label area (block header)
		dbra	D4,.loop

		lea	8(A2),A0
		moveq	#$28,D1
		bsr.b	GetChkSum		;calc header checksum

		lea	$30(A2),A0
		bsr.b	EncodeBits		;set header checksum

		move.w	#$200,D0
		movea.l	Source(A5),A0
		lea	$40(A2),A1
		bsr	Blitter			;encode datablock

		lea	$40(A2),A0		;reset boundary bits
		bsr.b	SetMSB			;header/block

		lea	$240(A2),A0		;reset boundary bits
		bsr.b	SetMSB			;oddbits/evenbits

		lea	$440(A2),A0		;reset boundary bits
		bsr.b	SetMSB			;evenbits/header next block

		lea	$40(A2),A0
		move.w	#$400,D1
		bsr.b	GetChkSum		;calc checksum

		lea	$38(A2),A0
		bsr.b	EncodeBits		;set datablock checksum

		rts

*****************************************************************************

GetChkSum	lsr.w	#2,D1
		move.l	(A0)+,D0
		subq.w	#2,D1
.loop		move.l	(A0)+,D2
		eor.l	D2,D0
		dbra	D1,.loop
		and.l	D5,D0
		rts

*****************************************************************************

EncodeBits	move.l	D0,D3
		lsr.l	#1,D0
		bsr.b	Encode			;encode odd bits
		move.l	D3,D0
		bsr.b	Encode			;encode even bits

SetMSB		move.b	(A0),D0			;prepare most significant bit
		bclr	#7,D0
		btst	#6,D0
		bne.b	.quit
		btst	#0,-1(A0)
		bne.b	.quit
		bset	#7,D0
.quit		move.b	D0,(A0)
		rts

Encode		and.l	D5,D0
		move.l	D0,D2
		eor.l	D5,D2
		move.l	D2,D1
		add.l	D2,D2
		lsr.l	#1,D1
		bset	#31,D1
		and.l	D2,D1
		or.l	D1,D0
		btst	#0,-1(A0)
		beq.b	.quit
		bclr	#31,D0
.quit		move.l	D0,(A0)+
		rts

*****************************************************************************

Blitter		movea.l	A1,A3
		moveq	#-1,D1

		bsr.b	.WaitBlit

		move.l	D1,bltafwm(A6)
		moveq	#0,D1
		move.l	D1,bltbmod(A6)
		move.w	D1,bltdmod(A6)
		move.w	D5,bltcdat(A6)
		move.l	A0,bltbpt(A6)
		move.l	A0,bltapt(A6)
		move.l	A3,bltdpt(A6)
		move.w	#$1DE4,bltcon0(A6)
		move.w	D1,bltcon1(A6)
		move.w	D0,D2			;blocksize
		add.w	D2,D2
		add.w	#16,D2
		move.w	D2,bltsize(A6)

		lea	-2(A0,D0.W),A0
		add.w	D0,D0
		lea	-2(A3,D0.W),A1

		bsr.b	.WaitBlit

		move.l	A0,bltbpt(A6)
		move.l	A0,bltapt(A6)
		move.l	A1,bltdpt(A6)
		move.w	#$0DE4,bltcon0(A6)
		move.w	#$1002,bltcon1(A6)
		move.w	D2,bltsize(A6)

		bsr.b	.WaitBlit

		move.l	A3,bltbpt(A6)
		move.l	A3,bltapt(A6)
		move.l	A3,bltdpt(A6)
		move.w	#$1D89,bltcon0(A6)
		move.w	D1,bltcon1(A6)
		add.w	#16,D2
		move.w	D2,bltsize(A6)

.WaitBlit	tst.b	2(A6)
		btst	#$6,2(A6)
		beq.b	.Quit
.Wait		tst.b	$1001(A4)
		tst.b	$1001(A4)
		btst	#$6,2(A6)
		bne.b	.Wait
.Quit		rts