;   
;   
  IF  EXT
;   
DOS EQU $  PTDOS and CP/M boots
; Syntax: DOS [PTDOS]  or  DOS CP/M
 CALL SBLK  scan for blank then first char
 JZ PTPORT  default PTDOS
 LDAX D  get first non-blank char
 ANI 5FH  convert lower to upper case
 CPI 'P'  PTDOS
 JZ PTPORT
 CPI 'C'  CP/M
 JZ CPPORT
 JMP ERR1  invalid character
PTPORT MVI A,4  set Tarbell latch for PTDOS
 OUT CPDCCMD
 JMP PTBOOT
CPPORT MVI A,3  set Tarbell latch for CP/M
 OUT CPDCCMD
; CP/M bootstrap for SOLOS +
 MVI A,22H+CPDISK  ;select disk , restore
 OUT CPDCCMD  ;send restore pulse
 IN CPDWAIT  ;wait for seek complete
 MVI A,0E2H+CPDISK  ;enable wait on DRQ/INTRQ
 OUT CPDCCMD  ;latch
 XRA A
 OUT CPDTRCK  ;set track register to 0
 MOV L,A  ;set HL = 0
 MOV H,A
 INR A
 OUT CPDSCTR  ;one to sector register
 MVI A,8CH  ;set read command
 OUT CPDCOMD  ;read sector
RLOOP IN CPDWAIT  ;wait for DRQ/INTRQ
 ORA A
 JP RDONE  ;done if INTRQ
 IN CPDDATA  ;read byte
 MOV M,A  ;store in memory
 INX H
 JMP RLOOP  ;more
RDONE IN CPDSTAT  ;get status
 ORA A
 JZ 0  ;execute cold start loader
 JMP CPPORT  ;again if disk error
;   
;  Helios II bootstrap
PTBOOT:  EQU  $
 MVI A,0CFH
 OUT 0F7H  restore, latch load head, select 0
 OUT 0F5H  reset TC, ABORT, CRC error and checked
 MVI A,-1
 OUT 0F1H  set do nothing
;   
BOOTL IN 0F0H  wait til ABORT clears
 ANI 40H
 JNZ BOOTL
 MVI A,0DFH
 OUT 0F7H  latch load head, select 0
;   
IFIN IN 0F0H  wait for index
 RLC
 JC IFIN
 LXI D,318H
;   
IFIN2 DCX D  delay for 9.5 msec (11.88 with wait state)
 MOV A,D
 ORA E
 JNZ IFIN2
;   
IFIN3 IN 0F0H  wait for index - again!
 RLC
 JC IFIN3
;   
SWAIT IN 0F0H  wait for SREADY (controller ready)
 ANI 2
 JZ SWAIT
 MVI A,40H
 OUT 0F3H  set DMA length to 340H
 MVI A,3
 OUT 0F4H
 XRA A
 OUT 0F5H  set DMA start to DMA
 OUT 0F6H
 MVI A,3
 OUT 0F1H  read disk (latch 3 to U22)
;   
PTDLOOP EQU $
 IN 0F0H  wait until CRC error, TC, or
;              SREADY (controller ready)
 ANI 0BH
 JZ PTDLOOP
 ANI 8  non-zero means CRC error
 JNZ PTBOOT
 JMP 4
;   
  ENDF
;   
;   
;  CASSETTE BYTE BY BYTE EXTENSION LOCATER
;  A, B, AND HL MUST BE PRESERVED
  IF  EXT
CASEXT:  PUSH  PSW
  CALL  CKEXT  ;EXTENSION PRESENT?
  JZ  GOCAS  ;YES
  POP  PSW
  INX  SP  ;FIX STACK
  INX  SP
  STC .  ;SET ERROR - ROUTINES NOT AVAILABLE
  RET
;   
GOCAS:  POP  PSW
  POP  D  ;GET CALLING ADDRESS + 3
  PUSH  H
  PUSH  PSW
  XCHG
  MVI  H,<SOLEXT  ;ADJUST HL
  MOV  A,L  ;HL WILL POINT TO RIGHT ROUTINE
  SUI  10
  MOV  L,A
  POP  PSW
  XTHL .  ;RESTORE HL, STACK POINTS
  RET .  ;DISPATCH
  ENDF
;   
  IF  STD
;   
; THE FOLLOWING ROUTINES PROVIDE "BYTE BY BYTE" ACCESS
; TO THE CASSETTE TAPES ON EITHER A READ ORWRITE BASIS.
;   
; THE TAPE IS READ ONE BLOCK AT A TIME AND INDIVIDUAL
; TRANSFERS OF DATA HANDLED BY MANAGING A BUFFER AREA.
;   
; THE BUFFER AREA IS CONTROLLED BY A FILE CONTROL BLOCK
; (FCB) WHOSE STRUCTURE IS:
;   
;    7 BYTES FOR EACH OF THE TWO FILES STRUCTURED AS
;    FOLLOWS:
;
;  1 BYTE - ACCESS CONTROL    00 IF CLOSED
;          FF IF READING
;          FEIF WRITING
;  1 BYTE - READ COUNTER
;  1 BYTE - BUFFER POSITION POINTER
;  2 BYTE - CONTROL HEADER ADDRESS
;  2 BYTE - BUFFER LOCATION ADDRESS
;
;
;
; THIS ROUTINE "OPENS" THE CASSETTE UNIT FOR ACCESS
;
; ON ENTRY:   A - HAS THE TAPE UNIT NUMBER (1 OR 2)
;    HL - HAS USER SUPPLIED HEADER FOR TAPE FILE
;
;
; NORMAL RETURN:  ALL REGISTERS ARE ALTERED
;      BLOCK IS READY FOR ACCESS
;   
; ERROR RETURN:   CARRY BIT IS SET
;
; ERRORS:   BLOCK ALREADY OPEN
;
;
BOPEN:  PUSH  H  ;SAVE HEADER ADDRESS
  CALL  LFCB  ;GET ADDRESS OF FILE CONTROL
  JNZ  TERE2  ;FILE WAS ALREADY OPEN
  MVI  M,1  ;NOW IT IS
  INX  H  ;POINT TO READ COUNT
  MOV  M,A  ;ZERO
  INX  H  ;POINT TO BUFFER CURSOR
  MOV  M,A  ;PUT IN THE ZERO COUNT
;   
; ALLOCATE THE BUFFER
;   
  LXI  D,FBUF1  ;POINT TO BUFFER AREA
  LDA  FNUMF  ;GET WHICH ONE WE ARE GOING TO USE
  ADD  D
  MOV  D,A  ;256 BIT ADD
;
UBUF:  POP  B  ;HEADER ADDRESS
  ORA  A  ;CLEAR CARRY AND RET AFTER STORING PARAMS
  JMP  PSTOR  ;STORE THE VALUES
;
; GENERAL ERROR RETURN POINTS FOR STACK CONTROL
;
TERE2:  POP  H
TERE1:  POP  D
TERE0:  XRA  A  ;CLEAR ALL FLAGS
  STC    ;SET ERROR
  RET
;
;
EOFER:  DCR  A  ;SET MINUS FLAGS
  STC    ;AND CARRY
  POP  D  ;CLEAR THE STACK
  RET    ;THE FLAGS TELL ALL
;
;
;
;
; THIS ROUTINE CLOSES THE FILE BUFFER TO ALLOW ACCESS
; FOR A DIFFERENT CASSETTE OF PROGRAM.  IF THE TILE
; OPERATIONS WERE "WRITE" THEN THE LAST BLOCK IS WRITTEN
; OUT AND AN "END OF FILE" WRITTEN TO THE TAPE.  IF
; THE OPERATIONS WERE "READS" THEN THE FILE IS JUST
; MADE READY FOR NEW USE.
;
; ON ENTRY:   A - HAS WHICH UNIT (1 OR 2)
;
; ERROR RETURNS:   FILE WASN'T OPEN
;
;
PCLOS:  CALL  LFCB  ;GET CONTROL BLOCK ADDRESS
  RZ    ;WASN'T OPEN, CARRY IS SET FROM LFCR
  ORA  A  ;CLEAR CARRY
  INR  A  ;SET CONDITION FLAGS
  MVI  M,0  ;CLOSE THE CONTROL BYTE
  RZ    ;WE WERE READING...NOTHING MORE TO DO
;
; THE FILE OPERATIONS WERE "WRITES"
;
; PUT THE CURRENT BLOCK ON THE TAPE
; (EVEN IF ONLY ONE BYTE)
; THEN WRITE AN END OF FILE TO THE TAPE
;
;
  INX  H
  INX  H
  MOV  A,M  ;GET CURSOR POSITION
  CALL  PLOAD  ;BC GET HEADER ADDRESS, DE BUFFER ADDRESS
  PUSH  B  ;HEADER TO STACK
  LXI  H,BLKOF  ;OFFSET TO BLOCK SIZE
  DAD  B
  ORA  A  ;TEST COUNT
  JZ  EOFW  ;NO BYTES...JUST WRITE EOF
;
; WRITE LAST BLOCK
;   
  PUSH  H  ;SAVE BLOCK SIZE POINTER FOR EOF
  MOV  M,A  ;PUT IN COUNT
  INX  H
  MVI  M,0  ;ZERO THE HIGHER BYTE
  INX  H
  MOV  M,E  ;BUFFER ADDRESS
  INX  H
  MOV  M,D
  MOV  H,B
  MOV  L,C  ;PUT HEADER ADDRESS IN HL
  CALL  WFBLK  ;GO WRITE IT OUT
  POP  H  ;BLOCK SIZE POINTER
;
; NOW WRITE END OF FILE TO CASSETTE
;
EOFW:  XRA  A  ;PUT IN ZEROS FOR SIZE
;      EOF MARK IS ZERO BYTES!
  MOV  M,A
  INX  H
  MOV  M,A
  POP  H  ;HEADER ADDRESS
  JMP  WFBLK  ;WRITE IT OUT AND RETURN
;
;
;
;
; THIS ROUTINE LOCATES THE FILE CONTROL BLOCK POINTED TO
; BY REGISTER "A".  ON RETURN HL POINTS TO THE CONTROL BYTE
; AND REGISTER "A" HAS THE CONTROL WORD WITH THE FLAGS
; SET FOR IMMEDIATE CONDITION DECISIONS.
;
;
LFCB:  LXI  H,FCBAS  ;POINT TO THE BASE OF IT
  RAR    ;MOVE THE 1 & 2 TO 0 & 1 
  ANI  1  ;SMALL NUMBERS ARE THE RULE
  STA  FNUMF  ;CURRENT ACCESS FILE NUMBER
  JZ  LFCB1  ;UNIT ONE (VALUE OF ZERO)
  LXI  H,FCBA2  ;UNIT TWO--POINT TO ITS FCB
LFCB1:  EQU  $  ;HL POINT TO PROPER FCB
  MOV  A,M  ;PICK UP FLAGS FROM FCB
  ORA  A  ;SET FLAGS BASED ON CONTROL WORD
  STC    ;SET CARRY IN CASE OF IMMEDIATE ERROR RET
  RET
;
;
;
;
;  READ TAPE BYTE ROUTINE
;
; ENTRY:  - A - HAS FILE NUMBER
; EXIT:  NORMAL - A - HAS BYTE
;   ERROR
;      CARRY SET     - IF FILE NOT OPEN OR
;           PREVIOUS OPERATIONS WERE WRITE
;      CARRY & MINUS  - END OF FILE ENCOUNTERED
;
;
;
;
RTBYT:  CALL  LFCB  ;LOCATE THE FILE CONTROL BLOCK
  RZ    ;FILE NOT OPEN
  INR  A  ;TEST IF FF
  JM  TERE0  ;ERROR WAS WRITING
  MVI  M,-1  ;SET IT AS READ (IN CASE IT WAS JUST OPE
  INX  H
  MOV  A,M  ;GET READ COUNT
  PUSH  H  ;SAVE COUNT ADDRESS
  INX  H
  CALL  PLOAD  ;GET THE OTHER PARAMETERS
  POP  H
  ORA  A
  JNZ  GTBYT  ;IF NOT EMPTY GO GET BYTE
;
; CURSOR POSITION WAS ZERO...READ A NEW BLOCK
; INTO THE BUFFER.
;
RDNBLK:  PUSH  D  ;BUFFER POINTER
  PUSH  H  ;TABLE ADDRESS
  INX  H
  CALL  PHEAD  ;PREPARE THE HEADER FOR READ
  CALL  RFBLK  ;READ IN THE BLOCK
  JC  TERE2  ;ERROR POP OFF STACK BEFORE RETURN
  POP  H
  MOV  A,E  ;LOW BYTE OF COUNT (WILL BE ZERO IF 256)
  ORA  D  ;SEE IF BOTH ARE ZERO
  JZ  EOFER  ;BYTE COUNT WAS ZERO...END OF FILE
  MOV  M,E  ;NEW COUNT (ZERO IS 256 AT THIS POINT)
  INX  H  ;BUFFER LOCATION POINTER
  MVI  M,0
  DCX  H
  MOV  A,E  ;GET BACK BUFFER ADDRESS
  POP  D
;
;
;
; THIS ROUTINE GETS ONE BYTE FROM THE BUFFER
; AND RETURNS IT IN REGISTER "A".  IF THE END
; OF THE BUFFER IS REACHED IT MOVES THE POINTER
; TO THE BEGINNING OF THE BUFFER FOR THE NEXT
; LOAD.
;
GTBYT:  DCR  A  ;BUMP THE COUNT
  MOV  M,A  ;RESTORE IT
  INX  H
  MOV  A,M  ;GET BUFFER POSITION
  INR  M  ;BUMP IT
;
  ADD  E
  MOV  E,A  ;DE NOW POINT TO CORRECT BUFFER POSITION
  JNC  RT1
  INR  D
RT1:  LDAX  D  ;GET CHARACTER FROM BUFFER
  ORA  A  ;CLEAR CARRY
  RET    ;ALL DONE
;
;
;
; THIS ROUTINE IS USED TO WRITE A BYTE TO THE FILE
;
; ON ENTRY:  A - HAS FILE NUMBER
;    B - HAS DATA BYTE
;
;
WTBYT:  CALL  LFCB  ;GET CONTROL BLOCK
  RZ    ;FILE WASN'T OPEN
  INR  A
  RZ    ;FILE WAS READ
  MVI  M,0FEH  ;SET IT TO WRITE
  INX  H
  INX  H
  MOV  A,B  ;GET CHARACTER
  PUSH  PSW
  PUSH  H  ;SAVE CONTROL ADDRESS+2
;   
; NOW DO THE WRITE
;   
  CALL  PLOAD  ;BC GETS HEADER ADDR
;      DE BUFFER ADDRESS
  POP  H
  MOV  A,M  ;COUNT BYTE
  ADD  E
  MOV  E,A
  JNC  WT1
  INR  D
WT1:  POP  PSW  ;CHARACTER
  STAX  D  ;PUT CHR IN BUFFER
  ORA  A  ;CLEAR FLAGS
  INR  M  ;INCREMENT THE COUNT
  RNZ    ;RETURN IF COUNT DIDN'T ROLL OVER
;
; THE BUFFER IS FULL.  WRITE IT TO TAPE
; AND RESET CONTROL BLOCK.
;
  CALL  PHEAD  ;PREPARE THE HEADER
  JMP  WFBLK  ;WRITE IT OUT AND RETURN
;
;
;
;
; THIS ROUTINE PUTS THE BLOCK SIZE (256) AND BUFFER
; ADDRESS IN THE FILE HEADER.
;
PHEAD:  CALL  PLOAD  ;GET HEADER AND BUFFER ADDRESSES
  PUSH  B  ;HEADER ADDRESS
  LXI  H,BLKOF-1  ;PSTOR DOES AN INCREMENT
  DAD  B  ;HL POINTS TO  BLOCKSIZE ENTRY
  LXI  B,256
  CALL  PSTOR
  POP  H  ;HL RETURN WITH HEADER ADDRESS
  RET
;
;
PSTOR:  INX  H
  MOV  M,C
  INX  H
  MOV  M,B
  INX  H
  MOV  M,E
  INX  H
  MOV  M,D
  RET
;
;   
PLOAD:  INX  H
  MOV  C,M
  INX  H
  MOV  B,M
  INX  H
  MOV  E,M
  INX  H
  MOV  D,M
  RET
;   
;   
  ENDF
;
;
;THIS ROUTINE SETS THE CORRECT UNIT FOR SYSTEM READS
;
RFBLK:  CALL  GTUNT  ;SET UP A=UNIT WITH SPEED
;
;
;  ***** TAPE READ ROUTINES *****
;
; ON ENTRY:   A - HAS UNIT AND SPEED
;    HL - POINTS TO HEADER BLOCK
;    DE - HAS OPTIONAL PUT ADDRESS
;
; ON EXIT:  CARRY IS SET IF ERROR OCCURED
;    TAPE UNITS ARE OFF
;
;
RTAPE:  PUSH  D  ;SAVE OPTIONAL ADDRESS
  MVI  B,3  ;SHORT DELAY
  CALL  TON
  IN  TDATA  ;CLEAR THE UART FLAGS
;
PTAP1:  PUSH  H  ;HEADER ADDRESS
  CALL  RHEAD  ;GO READ HEADER
  POP  H
  JC  TERR  ;IF AN ERROR OR ESC WAS RECEIVED
  JNZ  PTAP1  ;IF VALID HEADER NOT FOUND
;
; FOUND A VALID HEADER NOW DO COMPARE
;
  PUSH  H  ;GET BACK AND RESAVE ADDRESS
  LXI  D,THEAD
  CALL  DHCMP  ;COMPARE DE/HL HEADERS
  POP  H
  JNZ  PTAP1
;
;
  POP  D  ;OPTIONAL "PUT" ADDRESS
  MOV  A,D
  ORA  E  ;SEE IF DE IS ZERO
  LHLD  BLOCK  ;GET BLOCK SIZE
  XCHG    ;....TO DE
; DE HAS HBLOCK...HL HAS USER OPTION
  JNZ  RTAP  ;IF DE WAS 0 GET TAPE LOAD ADDR
  LHLD  LOADR  ;GET TAPE LOAD ADDRESS
;
;
; THIS ROUTINE READS "DE" BYTES FROM THE TAPE
; TO ADDRESS HL.  THE BYTES MUST BY FROM ONE
; CONTIGUOUS PHYSICAL BLOCK ON THE TAPE.
;
;  HL HAS "PUT" ADDRESS
;  DE HAS SIZE OF TAPE BLOCK
;
RTAP:  PUSH  D  ;SAVE SIZE FOR RETURN TO CALLING PROGRAM
;
RTAP2:  EQU  $  ;HERE TO LOOP RDING BLKS
  CALL  DCRCT  ;DROP COUNT, B=LEN THIS BLOCK
  JZ  RTOFF  ;ZERO=ALL DONE
;
  CALL  RHED1  ;READ THAT MANY BYTES
  JC  TERR  ;IF ERROR OR ESC
  JZ  RTAP2  ;RD OK...READ SOME MORE
;
; ERROR RETURN
;
TERR:  XRA  A
  STC    ;SET ERROR FLAGS
  JMP  RTOF1
;
;
TOFF:  MVI  B,1
  CALL  DELAY
RTOFF:  XRA  A
RTOF1:  OUT  TAPPT
  POP  D  ;RETURN BYTE COUNT
  RET
;
;
DCRCT:  EQU  $  ;COMMON RTN TO COUNT DOWN BLK LENGTHS
  XRA  A  ;CLR FOR LATER TESTS
  MOV  B,A  ;SET THIS BLK LEN = 256
  ORA  D  ;IS ANMT LEFT < 256
  JNZ  DCRC2  ;NO...REDUCE AMNT BY 256
  ORA  E  ;IS ENTIRE COUNT ZERO
  RZ    ;ALL DONE..ZERO=THIS CONDITION
  MOV  B,E  ;SET THIS BLK LEN TO AMNT REMAINING
  MOV  E,D  ;MAKE ENTIRE COUNT ZERO NOW
  RET    ;ALL DONE (NON-ZERO FLAG)
DCRC2:  EQU  $  ;REDUCE COUNT BY 256
  DCR  D  ;DROP BY 256
  ORA  A  ;FORCE NON-ZERO FLAG
  RET    ;NON-ZERO=NOT DONE YET (BLK LEN=256)
;
;
; READ THE HEADER
;
RHEAD:  MVI  B,10  ;FIND 10 NULLS
RHEA1:  CALL  STAT
  RC    ;IF ESCAPE
  IN  TDATA  ;IGNORE ERROR CONDITIONS
  ORA  A  ;ZERO?
  JNZ  RHEAD
  DCR  B
  JNZ  RHEA1  ;LOOP UNTIL 10 IN A ROW
;
; WAIT FOR THE START CHARACTER
;
SOHL:  CALL  TAPIN
  RC    ;ERROR OR ESCAPE
  CPI  1  ;AT LEAST 10 NULLS FOLLOWED BY A 01
  JC  SOHL  ;STILL A NULL, KEEP WAITING
  JNZ  RHEAD  ;NON-ZERO, START SEQUENCE OVER AGAIN
;
; NOW GET THE HEADER
;
  LXI  H,THEAD  ;POINT TO BUFFER
  MVI  B,HLEN  ;LENGTH TO READ
;
RHED1:  EQU  $  ;RD A BLOCK INTO HL FOR B BYTES
  MVI  C,0  ;INITALIZE THE CRC
RHED2:  EQU  $  ;LOOP HERE
  CALL  TAPIN  ;GET A BYTE
  RC
  MOV  M,A  ;STORE IT
  INX  H  ;INCREMENT ADDRESS
  CALL  DOCRC  ;GO COMPUTE THE CRC
  DCR  B  ;WHOLE HEADER YET?
  JNZ  RHED2  ;DO ALL THE BYTES
;
; THIS ROUTINE GETS THE NEXT BYTE AND COMPARES IT
; TO THE VALUE IN REGISTER C.  THE FLAGS ARE SET ON
; RETURN.
;
  CALL  TAPIN  ;GET CRC BYTE
  XRA  C  ;CLR CARRY AND SET ZERO IF MATCH
;        ELSE NON-ZERO
  RZ    ;CRC WAS FINE
  LDA  IGNCR  ;GET POSSIBLE OVERRIDE CRC ERROR FLAG
  INR  A  ;FF=IGNORE CRC ERRORS
  RET    ;ELSE PROCESS CRC ERROR
;
;
; THIS ROUTINE GETS THE NEXT AVAILABLE BYTE FROM THE
; TAPE.  WHILE WAITING FOR THE BYTE THE KEYBOARD IS TESTED
; FOR AN ESC COMMAND.  IF RECEIVED THE TAPE LOAD IS
; TERMINATED AND A RETURN TO THE COMMAND MODE IS MADE.
;
STAT:  IN  TAPPT  ;TAPE STATUS PORT
  ANI  TDR
  RNZ
  CALL  SINP  ;CHECK INPUT
  JZ  STAT  ;NOTHING THERE YET
  ANI  7FH  ;CLR PARITY FIRST
  JNZ  STAT  ;NOT A MODE (OR EVEN CTRL-@)
  STC    ;SET ERROR FLAG
  RET    ;AND RETURN
;
;
;
TAPIN:  CALL  STAT  ;WAIT UNTIL A CHARACTER IS AVAILABLE
  RC
;
TREDY:  IN  TAPPT  ;TAPE STATUS
  ANI  TFE+TOE  ;DATA ERROR?
  IN  TDATA  ;GET THE DATA
  RZ    ;IF NO ERRORS
  STC    ;SET ERROR FLAG
  RET
;
;
; THIS ROUTINE GETS THE CORRECT UNIT FOR SYSTEM WRITES
;
WFBLK:  CALL  GTUNT  ;SET UP A WITH UNIT AND SPEED
;
;
;  ***** WRITE TAPE BLOCK ROUTINE *****
;
; ON ENTRY:   A - HAS UNIT AND SPEED
;    HL - HAS POINTER TO HEADER
;
;
WTAPE:  EQU  $  ;HERE TO WRITE TAPE
  PUSH  H  ;SAVE HEADER ADDRESS
  CALL  WHEAD  ;TURN ON, THEN WRITE HEADER
  POP  H
  LXI  D,BLKOF  ;OFFSET TO BLOCK SIZE IN HEADER
  DAD  D  ;HL POINT TO BLOCK SIZE
  MOV  E,M
  INX  H
  MOV  D,M  ;DE HAS SIZE
  INX  H
  MOV  A,M
  INX  H
  MOV  H,M
  MOV  L,A  ;HL HAS STARTING ADDRESS
;
; THIS ROUTINE WRITES ONE PHYSICAL BLOCK ON THE
; TAPE "DE" BYTES LONG FROM ADDRESS "HL".
;
;
WRLO1:  EQU  $  ;HERE FOR THE EXTRA PUSH
  PUSH  H  ;A DUMMY PUSH FOR LATER EXIT
WTAP2:  EQU  $  ;LOOP HERE UNTIL ENTIRE AMOUNT READ
  CALL  DCRCT  ;DROP COUNT IN DE AND SET UP B
;      WITH LENGTH THIS BLOCK
  JZ  TOFF  ;RETURNS ZERO IF ALL DONE
  CALL  WTBL  ;WRITE BLOCK FOR BYTES IN B (256)
  JMP  WTAP2  ;LOOP UNTIL ALL DONE
;
;
WRTAP:  PUSH  PSW
WRWAT:  IN  TAPPT  ;TAPE STATUS
  ANI  TTBE  ;IS TAPE READY FOR A CHAR YET
  JZ  WRWAT  ;NO...WAIT
  POP  PSW  ;YES...RESTORE CHAR TO OUTPUT
  OUT  TDATA  ;SEND CHAR TO TAPE
;
DOCRC:  EQU  $  ;A COMMON CRC COMPUTATION ROUTINE
  SUB  C
  MOV  C,A
  XRA  C
  CMA
  SUB  C
  MOV  C,A
  RET    ;ONE BYTE NOW WRITTEN
;
;
; THIS ROUTINE WRITES THE HEADER POINTED TO BY
; HL TO THE TAPE.
;
WHEAD:  EQU  $  ;HERE TO FIRST TURN ON THE TAPE
  CALL  WTON  ;TURN IT ON, THEN WRITE HEADER
  MVI  D,50  ;WRITE 50 ZEROS
NULOP:  XRA  A
  CALL  WRTAP
  DCR  D
  JNZ  NULOP
;
  MVI  A,1
  CALL  WRTAP
  MVI  B,HLEN  ;LENGTH TO WRITE OUT
;
WTBL:  MVI  C,0  ;RESET CRC BYTE
WLOOP:  MOV  A,M  ;GET CHARACTER
  CALL  WRTAP  ;WRITE IT TO THE TAPE
  DCR  B
  INX  H
  JNZ  WLOOP
  MOV  A,C  ;GET CRC
  JMP  WRTAP  ;PUT IT ON THE TAPE AND RETURN
;
;
; THIS ROUTINE COMPARES THE HEADER IN THEAD TO
; THE USER SUPPLIED HEADER IN ADDRESS HL.
; ON RETURN IF ZERO IS SET THE TWO NAMES COMPARED
;
DHCMP:  MVI  B,5
DHLOP:  LDAX  D
  CMP  M
  RNZ
  DCR  B
  RZ    ;IF ALL FIVE COMPARED
  INX  H
  INX  D
  JMP  DHLOP
;
GTUNT:  EQU  $  ;SET A=SPEED + UNIT
  LDA  FNUMF  ;GET UNIT
  ORA  A  ;SEE WHICH UNIT
  LDA  TSPD  ;BUT FIRST GET SPEED
  JNZ  GTUN2  ;MAKE IT UNIT TWO
  ADI  TAPE2  ;THIS ONCE=UNIT 2, TWICE=UNIT 1
GTUN2:  ADI  TAPE2  ;UNIT AND SPEED NOW SET IN A
  RET    ;ALL DONE
;
WTON:  MVI  B,4  ;SET LOOP DELAY, (BIT LONGER ON WRITE)
TON:  EQU  $  ;HERE TO TURN A TAPE ON THEN DELAY
  OUT  TAPPT  ;GET TAPE MOVING, THEN DELAY
;
DELAY:  LXI  D,0
DLOP1:  DCX  D
  MOV  A,D
  ORA  E
  JNZ  DLOP1
  DCR  B
  JNZ  DELAY
  RET
;
;
;********* END OF PROGRAM ************
;