/DECTAPE OUTPUT (NAMED FILE)
 .LOC 17000
    .SIZE
    042440                  /'DT'+40
    200002                  /OUTPUT
                            /DIRECTORY COMES HERE
UNIT 1
INC 4
DON
    SNL; JMP D5             /CLOSE ->
    SAD .NL; LAC (42       /DQ FOR NL
    TAD (-140; SPA; XOR (-40 /6 BITS
    SNA!CLL; LAC (36        /UP FOR AT
    JMP* GET                /EXIT FROM COROUTINE
D1  DAC I
    CLA
    JMS .BU; DAC DV+3       /GET BUFFER
    CLC; JMS ADVANCE        /FIND FIRST
    LAC BN; DAC BLK1        /FREE BLOCK
D2  LAC BN; DAC DV+1        /BLOCK NUMBER
    LAC DV+3; DAC CA        /CA = BUFF START
    LAC SUM; DAC* CA        /CHECKSUM IN WORD0
    ISZ CA                  /BUMP TO WORD1
    LAW -376; DAC WC        /254[10] DATA WORDS
    LAC I
D3  RCR; RTR; RTR; RTR      /CHAR1 << 12
    DAC* CA
    JMS GET; RTL; RTL; RTL  /CHAR2 << 6
    TAD* CA; DAC* CA
    JMS GET                 /CHAR3
    TAD* CA; DAC* CA
    TAD SUM; DAC SUM
    JMS GET                 /IN CASE EOF
    ISZ CA
    ISZ WC; JMP D3
    DAC I
    CLC; TAD INC; CMA       /-INC
    JMS ADVANCE             /FIND FREE BLOCK
    LAC BN; JMS WRITE
    JMP D2
D5  LAC DV+3                /FILE OPEN?
    SNA!CLL!CLC; JMP* DON   /NO =>
    ISZ CA; DZM* CA         /ZERO REST
    ISZ WC; JMP .-3
D6  CLC; JMS WRITE          /LAST BLOCK
    LAC DV+3; JMS .BU       /RELEASE BUFFER
    LAC (D5; DAC GET        /IN CASE RE-ENTRY
    LAC BLK1; XOR (400000   /STORE FIRST BN
    DAC INC; DZM DV+3       /OVERWRITING INC
    JMP D5                  /FOR EXEC
/COROUTINE
GET D1
    STL
    JMP* DON
/MOVE ON BIT POSITION
ADVANCE
A1  DAC WC                  /MINIMUM INC (NEG)
    LAC BIT                 /BIT POSITION
A2  RCR; SNL; JMP A3        /STILL IN AC ->
    ISZ BWC; RAR!SKP; JMP D6 /NO BLOCKS LEFT ->
A3  ISZ BN; ISZ WC; JMP A2  /NOT FAR ENOUGH
    DAC BIT
    LAC (UNIT; TAD BWC      /COMPUTE BIT-MAP
    DAC J                   /WORD ADDRESS
    LAC* J; AND BIT         /BIT SET?
    SZA!CLC; JMP A1         /YES ->
    LAC* J; XOR BIT         /ZERO BIT
    DAC* J
    JMP* ADVANCE
WRITE
    DAC* CA                 /LAST WORD
W1  LAC (4000; XOR UNIT     /FUNCTION + UNIT
    DAC DV
    LAC (DV
    GUARD; JMP .DH          /CALL HANDLER
    GUARD                   /WAIT FOR TRANSFER
    LAC DV; SMA!SZA; WAIT
    ION
    SMA!CMA; JMP* WRITE     /OK ->
    GUARD; JMP .MH          /REPORT
    JMP W1
I;J;CA;WC;SUM .SIXBT 'AA1'
BLK1;BN;BWC -40;BIT 400000
DV  0; 0; -400; 0
GUARD=JMS 3;WAIT=JMP 2
.BU=16000;.DH=16010;.MH=16020;.NL=16030
 .END