CLOSBAC867

(George Source)

Macros used: ACROSS, ALTLEN, AUTWIN, CAFSINFO, CAPCA, CHAIN, CHECKEXT, COOR3, DOWN, EXMESS, FADDRESS, FINDSU, FIPPER, FREECORE, GEOERR, GETWORD, ILLEGAL, JCAFSNBS, LADDP, LGEOG, LONGON, MENDAREA, MFINDEXOF, MFINDSUX, MFREE, MHUNTW, MURDER, OUTPACK, PAIR, PLOCKSU, PROGBRKIN, RELPERENT, RELST, REPMON, RUNPROG, SEGENTRY, SETNCORE, SMUSEST, STEPBACK, SUSEST, TESTMON, TESTREP, TESTREPNOT, TOPCA1, TWAIT, UNLOCKSU, UNPLUG, UP, WORDFIN

CLOSBAC867.txt
22FL ...#SEG  CLOSBAC82                    [FRANK BLUNDELL  
22KH ...#   
22PD ...#     COPYRIGHT INTERNATIONAL COMPUTERS LTD   1982  
22T* ...#   
22^=    #LIS  K0CLOSBAC 
23DW          8HCLOSBAC 
23YG    #   
24D6    #     THIS SEGMENT IMPLEMENTS MODES #1000 AND #1300  ENTRY POINT
24XQ    #     IS K1CLOSBAC  
25CB    #   
25X2    #     ON ENTRY XCA CONTAINS CONTROL AREA ADDRESS
26BL    #     AND CURRENT ACTIVITY IS THE AOLPT 
26W=    #     X5 CONTAINS CLOSE MODE
27*W    #     X6 CONTAINS ADDITIVE MODES (B22=1,#4000 B23=1,#2000   
27TG    #   
28*6    #     K1CLOSBAC EVENTUALLY OBEYS RELPERENT MACRO. THIS GOES DOWN TO 
28SQ    #     K2CLOSBAC TO RELEASE THE CHANNEL. 
29#B    #   
29S2    #   
2=?L          SEGENTRY K1CLOSBAC,QK1CLOSBAC 
2=R=          SEGENTRY K2CLOSBAC,QK2CLOSBAC 
2?=W          SEGENTRY CLOSTART            [ SET BY NOINTEG MACRO   
2?QG          +0
2#=6    #   
2#PQ    XLINK PAIR     PERION,1 
2*9B    XM1   #77777
2*P2    XM2   #37777777 
2B8L    XM3   #63777777 
2BN=    STEN           +10  
2C7W    #   
2CMG    #   
2D76    XRV   TOPCA1   XLINK(1)            [GO TO PCA   
2DLQ          UNPLUG                       [UNPLUG PROGRAM. 
2F6B          ILLEGAL  NOCA 
2FL2    #   
2G5L    XERR1 GEOERR   1,RESVIOL
2GK=    #   
2H4W    #DEF  XCA=EVENT2
2HJG    #   
2J46    #   
2JHQ    #SKI  BMONITOR  
2K3B    (   
2KH2    XMON  LDX   7  XCA(2)              [CONTROL AREA ADDRESS
2L2L          TOPCA1   XLINK(1) 
2LG=          REPMON   1
2L^W    )   
2MFG    #   
2M^6    #   
2NDQ    XC    FREECORE 3                   [FREE GEXD   
2PD2          ILLEGAL  MODE 
2PXL    #   
2QC=    QK1CLOSBAC  
2QWW          LDN   7  5                   [CHECK 5 WORDS OF CONTROL AREA   
2RBG          CHECKEXT XCA(2),7,XRV,APETADDR(2),W,XA,HLOCK1 
2RW6    XA  
2S*Q    #SKI  BMONITOR  
2STB    (   
2T*2          LDX   7  6                   [SAVE X6 
2TSL          LDX   4  5                   [AND X5  
32NW          LDCT  6  #6                  [DEVICE TYPE B0-B8   
338G          ORX   6  EWCHAN(2)           [CHANNEL IN B9-B23   
347Q          LDN   5  BBCLOSE  
34MB          TESTMON  APETADDR(2),5,6,XMON 
3572          LDX   6  7                   [RESTORE X6  
35LL          LDX   5  4                   [AND X5  
366=    )   
36KW          LDX   3  XCA(2)   
375G          LDX   1  APETADDR(2)  
37K6          ADN   3  2
384Q          FADDRESS 1,3,HLOCK1          [GET ADDRESS OF EOF UPDATE   
38JB          LDX   4  0(3) 
3942                                       [START PACKING DATA INTO ACCS
39HL          LDX   3  EXNUM(2)            [EXOFILE NUMBER  
3=3=          SLL   5  12   
3=GW          ORX   5  EXMODE(2)           [OPENING MODE
3?2G          SLL   6  22   
3?G6          ORX   6  EWCHAN(2)           [CHANNEL NUMBER  
3?^Q          LDX   7  XCA(2)              [CONTROL AREA ADDRESS
3#3X ...      SETNCORE GEXDLEN,1,EWDAS,GEXD 
3#4L ...      STOZ     A1(1)
3#5* ...      LDN   0  A1(1)
3#64 ...      ADN   1  A1+1 
3#6R ...      MOVE  0  GEXDLEN-1           [ZEROISE DATA BLOCK  
3#7G ...      SBN   1  A1+1 
3#89 ...      STO   3  CEFN(1)             [UNPACK AND STORE DATA.  
3#8Y ...      LDX   3  1
3#9M ...      STO   4  CEOF(3)             [END OF FILE UPDATE  
3#=B ...      STO   7  CNR(3)              [CA ADDRESS  
3#?5 ...      DEX   6  EXCHNL(3)
3#?S ...      SRL   6  22   
3##H ...      DSA   5  EOPMODE(3)          [OPENING MODE
3#*= ...      SRL   5  12   
3#*^ ...      LDX   0  EXTRAPS(2)          [EXOFILE ENTRY'S TRAPS RECORD
3#BN ...      STO   0  EXOTRAP(3)          [TRANSFER TO GEXD
3#CC ...      CHAIN    3,APETADDR(2)
3#FB          LDX   1  FX1  
3#^2          TOPCA1   XLINK(1)            [GO TOPCA
3*DL          UNPLUG
3*KR ...      CAPCA    EWDAS,GEXD          [TO CPA WITH GEXD
3*MG ...      MHUNTW    3,EWDAS,GEXD
3K=L          STO   5  AWORK1(2)           [CLOSE MODE  
3KQ=          STO   6  AWORK2(2)           [ADDITIVE BITS   
3L9W          MFINDEXOF 1,CEFN(3)          [FIND EXOF FOR FILE  
3LPG          LDX   7  ASUSN(1) 
3M96          STO   7  ESERL(3)            [SERIAL NO. FOR EXOPEN   
3MHG ...      STO   7  EWORK1(2)           [SERIAL NO FOR RELPER
3MNQ          SBN   5  #1000
3N8B          BZE   5  YA                  [JUMP IF CLOSE MODE =#1000   
3NN2          ACROSS   CLOSDEL,1           [MODE #1300 -DELETE  
3P7L    #   
3PM=    #   
3Q6W    YA    LDX   4  CEOF(3)  
3QLG          BZE   4  YB                  [JUMP IF NO UPDATE   
3R66          LDX   0  EOPMODE(3)   
3RKQ          SBN   0  #200                [OR OPEN FOR READING 
3S5B          BZE   0  YB   
3SK2          SBN   0  #1500               [OR MODE #1700   
3T4L          BZE   0  YB   
3TJ=          ADN   0  #100 
3W3W          BZE   0  YB                  [OR #1600
3WHG          ADN   0  #1000
3X36          BZE   0  YB                  [OR SCRATCH FILE 
3XGQ          ADX   4  FIP+10(1)
3Y2B          ADN   0  #200 
3YG2          BZE   0  YC                  [JUMP IF END OF FILE MODE (400)  
3Y^L          BNG   4  YD   
3^F=          BNZ   4  YE   
3^YW    YD    LDN   4  1                   [EOF =1  IF <1 ORIGINALLY
42DG          BRN      YE   
42Y6    YC    TXL   4  FIP+10(1)
43CQ          BCC      YE   
43XB          LDX   4  FIP+10(1)           [CURRENT EOF FOR MODE 400
44C2    YE    TXU   4  FIP+10(1)
44WL          BCC      YB                  [JUMP IF UPDATE AS CURRENTLY 
45B=          SUSEST   7,YF 
467= ...YFA   PLOCKSU  7,XGA,XFL3          [GET LOCK OUT
47SB          SETNCORE FDCELLS-A1,2,EWDAS,EXOF  
48#2          MHUNTW   3,EWDAS,GEXD 
48RL          MFINDEXOF 1,CEFN(3)   
49?=          LDX   0  BACK2(1) 
49QW          STO   0  BACK2(2)            [EXOFILE NUMBER  
4==G          ADN   1  A1   
4=Q6          ADN   2  A1   
4?9Q          MOVE  1  FDCELLS-A1   
4?PB          LDN   0  BSERL+BSPEC+BRITE+BLOCK  
4#92          STO   0  EXMARK-A1(2)        [OPERATION MARKERS   
4#NL          LDX   5  FIP+10-A1(1)        [SAVE OLD EOF
4*8=          STO   4  FIP+10-A1(1)        [NEW EOF 
4*MW ...      DOWN     WRITEFIP,1   
4B7G          TESTREP  OK,YG
4BM6          TESTREP  EXFAIL,YH
4C6Q    SA    GEOERR   1,EXOREP1
4CLB    YG    MHUNTW   2,EWDAS,EXOF 
4D62 ...      FIPPER   HOME(2),ASUSN(2),XGB,YGA,NOC [TELL OTHER SIDE TO RE-READ 
4DKL ...YGA 
4FJW          MHUNTW   2,EWDAS,EXOF 
4G4G    NOC 
4H3Q          FREECORE 2                   [FREE SPARE EXOF 
4HHB          EXMESS   ALL                 [OUTPUT MESSAGES 
4J32    WA    UNLOCKSU 7                   [UNLOCK UNIT 
4JGL          RELST    7                   [AND RELEASE 
4K2=          MHUNTW   3,EWDAS,GEXD 
4R*B    YB    LDCT  4  #6                  [DEVICE TYPE B0-B8   
4RT2          ORX   4  EXCHNL(3)           [CHANNEL IN B9-B23   
4S#L          RELPERENT 4,AWORK1(2)        [RELEASE CHANNEL 
4T?W          LDN   6  0
4TRG          BRN      XDA                 [GO TO SET REPLIES   
4W?6    #   
4WQQ    #     GET UNIT ONLINE   
4X=B    #   
4XD8 ...YF    LDN   3  0                   [MKR IF BREAKIN  
4XG6 ...      SMUSEST  7,XF,XG  
4Y9L          BRN      YFA  
4YP=    #   
5286    XGB   MFREE    EWDAS,EXOF   
52MQ          UNLOCKSU 7
52PH ...#   
52Q6 ...#     IPB FAIL FOR LOCKOUT  
52QP ...#   
52R# ...XFL3  NGNC  3  1
52RX ...#   
52SG ...#     BREAKIN  WHILE WAITING FOR IPB
52T5 ...#   
52TN ...XGA   LDN   3  0
52W? ...      RELST    7                   [RELEASE UNIT
52WW ...#   
52XF ...#     BREAKIN  WHILE WAITING FOR DISC   
52Y4 ...#   
52YM ...XG    MHUNTW   1,EWDAS,GEXD        [X3=0 IF BREAKIN =1 IF IPB FAIL  
52^= ...      FREECORE 1
52^T ...      STEPBACK                     [STEP ONR BACK   
532D ...      BZE   3  NIPB                [J IF BREAKIN
5333 ...      TWAIT    7,NIPB              [WAIT FOR IPB
533L ...      RUNPROG                      [TRY AGAIN   
5349 ...NIPB  PROGBRKIN                    [REPORT BREAKIN  
56JQ    #   
574B    #   
57J2    #     SET OBJECT PROGRAM REPLIES
583L    XD    LDCT  0  #400 
58H=          ORX   6  0                   [FAIL REPLIES
592W          UNLOCKSU 7
59GG          RELST    7                   [GET RID OF UNIT 
5=26    XDA   MHUNTW   3,EWDAS,GEXD 
5=FQ          LDX   7  CNR(3)              [C.A ADDRESS 
5=^B          ADN   7  1
5?F2          FREECORE 3                   [FREE GEXD   
5?YL ...      GETWORD  7,7,WRITE
5#D= ...      TESTREPNOT OK,XERR1   
5*CG          SMO      7
5*X6          STO   6  0                   [SET REPLY   
5B6Y ...      WORDFIN   
5BBQ          RUNPROG                      [RESTART PROGRAM 
5BWB    #   
5CB2    #   
5CTL    #     TRANSFER FAIL,OR NOT FOUND
5D*=    #   
5DSW    YH    MHUNTW   3,EWDAS,GEXD 
5F#G          LDX   0  EMARK(3) 
5FS6          ANDN  0  ARITE+AFAIL+ANFOUND  
5G?Q          BZE   0  SA   
5GRB          ANDN  0  ANFOUND  
5H?2          BZE   0  SB   
5HQL                                       [JUMP IF FAIL
5J==          MFINDEXOF 1,CEFN(3)   
5JPW          LDCT  0  4
5K9G          ANDX  0  EXMARK(1)
5KP6          BNZ   0  YG                  [JUMP IF S-TRUSTED   
5L8Q          GEOERR   1,NOT-S? 
5LNB    SB    MFINDEXOF 1,CEFN(3)   
5M82          STO   5  FIP+10(1)           [RESET EOF   
5MML    ZJ    MHUNTW   2,EWDAS,EXOF 
5N7=          FREECORE 2
5NLW    XFL1  UNLOCKSU 7
5P6G    XFL2  RELST    7
5PL6          EXMESS   ALL                 [OUTPUT MESSAGES 
5Q5Q    XF    MHUNTW   3,EWDAS,GEXD 
5QKB          LDX   7  CNR(3)                  [CA ADDRESS  
5R52          ADN   7  1
5RJL          LDX   5  EXCHNL(3)           [CONVERT CHANNEL NR TO DECIMAL   
5S4=          FREECORE 3
5SHW ...      LDCT  6  6
5T3G ...      ADX   5  6                   [CHANNEL AND DEVICE  
5TH6 ...XPAR  OUTPACK  5,1,PERINAME,XPAR
5W2Q ...      GETWORD  7,7,WRITE
5WGB ...      TESTREPNOT OK,XERR1   
62X2          LDCT  6  #440 
63BL          SMO      7                       [SET FAIL REPLY  
63W=          STO   6  0
6464 ...      WORDFIN   
64*W          ILLEGAL  PERFAIL  
64TG    #   
65*6    # ENTRY FROM RELPERENT, ACOMMUNE9  CONTAINS (1) ZERO IF RELEASE COMMAND 
65SQ    #                                           (2) #1000 ) MODE OF 
66#B    #                                         (3) #1300 )  CLOSE PERI   
66S2    #  X3 POINTS TO AOLPT   
67?L    #   
67R=    #   
68=W    QK2CLOSBAC  
68?= ...#UNS  CAFSINT   
68?L ...(   
68#2 ...#     FOR THE CAFS INTERFACE IN GEORGE, WE HAVE TO BE SURE THAT 
68#B ...#     THERE ARE NO CAFS ORDERS OUTSTANDING WHEN WE CLOSE DOWN A UDAS
68#Q ...#     CHANNEL.   WE ALSO HAVE TO INFORM CAFS IF THE FILE IS BING CLOSED 
68*6 ...#     FROM WRITING. 
68*G ...#   
68*W ...      JCAFSNBS 3,XNOCAFSTRNS       [JIF NO CAFS ORDERS OUTSTANDING  
68B= ...      COOR3    #41                 [ELSE WAIT A WHILE   
68BL ...      BRN      QK2CLOSBAC          [AND TRY AGAIN   
68C2 ...#   
68CB ...XNOCAFSTRNS 
68CQ ...      LDX   0  EXMODE(3)           [NOW CHECK OPENING MODE OF FILE  
68D6 ...      SBN   0  #200 
68DG ...      BZE   0  XOFR                [JIF FILE OPEN FOR READING   
68DW ...      SBN   0  #400 
68F= ...      BZE   0  XOFR                [TREAT SCRATCH FILES AS OPEN FOR READ
68FL ...      SBN   0  #1100
68G2 ...      BZE   0  XOFR                [JIF Q-TRUSTED READING   
68GB ...#   
68GQ ...      LDX   0  ACOMMUNE9(2)        [WE DON'T INFORM CAFS IF FILE IS 
68H6 ...      SBN   0  #1300               [BEING DE-ALLOCATED BY CLOSE 
68HG ...      BZE   0  XOFR                [JIF MODE #1300 CLOSE
68HW ...#   
68J= ...      CAFSINFO CLOSEFILE,EXNUM(3)  [TELL CAFS WE ARE CLOSING AFTER WRITE
68JL ...#   
68K2 ...XOFR
68KB ...#   
68KQ ...#     THE CHANNEL MAY HAVE 'CAFS BIT MAPS' ALLOCATED TO IT.  IF IT DOES 
68L6 ...#     WE MUST RELEASE THEM. 
68LG ...#   
68LW ...      LDCT  7  #70                 [BIT MAP ALLOCATION IS RECORDED IN   
68M= ...      ANDX  7  CFRDBITS(3)         [B3-5 OF CFRDBITS IN THE OLPA
68ML ...      BZE   7  NOBITMAPS           [JIF NO BIT MAPS BELONGING TO OLPA   
68N2 ...#   
68N8 ...      SLC   7  6                   [FORM BIT MAPS MASK FOR CAFSINFO 
68NB ...      CAFSINFO BITMAPS,7           [TELL CAFS SUBSYSTEM TO FREE BIT MAPS
68NQ ...#   
68P6 ...NOBITMAPS   
68PG ...)   
68QG          LDCT  0  #200 
69=6          ANDX  0  EXMAYBE(3)   
69PQ          BNZ   0  QA                  [JUMP IF S-TRUSTED   
6=9B          LDX   0  EXMODE(3)
6=P2          SBN   0  #600 
6?8L          BZE   0  TA                  [JUMP IF SCRATCH FILE
6?N=          LDX   0  ACOMMUNE9(2) 
6#7W          SBN   0  #1300
6#MG          BZE   0  TB   
6*76    #SKI  K6CLOSBAC>199-199 
6*LQ    (   
6B6B          ADN   0  #300 
6BL2          BZE   0  TK   
6C5L          ADN   0  #1000
6CK=          BZE   0  TK   
6D4W          GEOERR   1,K2CLOMOD   
6DJG    TK  
6F46    )   
6FHQ          LDN   7  0                   [MARKER FOR STORAGE UNIT ONLINE  
6G3B          MFINDEXOF 1,EXNUM(3)  
6GH2          LDX   4  ASUSN(1) 
6GTB ...      STO   4  EWORK1(3)           [SUSN FOR HLS PURPOSES INRELPER  
6H2L          SUSEST   4,TC                [KEEP UNIT ONLINE IF ALREADY THERE   
6HSK ...      LDN   7  1                   [IN CASE OF IPB FAIL 
6J5= ...XGC   PLOCKSU  4,XGC,TC            [GET LOCK OUT IF WE CAN  
6MWW          NGN   7  1                   [RESET MARKER
6NBG    TC    MFINDEXOF 1,EXNUM(3)  
6NW6          LDX   0  EXMODE(3)
6P*Q          SBN   0  #200 
6PTB          BZE   0  TD                  [JUMP IF READ
6Q*2          SBN   0  #1500
6QSL          BZE   0  TD                  [OR Q-TRUSTED READ   
6R#= ...      LDCT  0  #400 
79FB    #SKI  K6CLOSBAC>199-199 
79^2    (   
7=DL          ANDX  0  EXMARK(1)
7=Y=          BNZ   0  TE   
7?CW          GEOERR   1,CLOSWRIT          [ERROR IF WRITE BIT NOT SET  
7?XG    TE  
7#C6    )   
7#WQ          ERS   0  EXMARK(1)           [UNSET WRITE BIT 
7*BB    TD    LDX   5  COPEN(1) 
7*W2          SBN   5  1                   [UPDATE COUNT OF OPENS   
7B*L    #SKI  K6CLOSBAC>199-199 
7BT=    (   
7C#W          BPZ   5  TF   
7CSG          GEOERR   1,ZEROCLOS   
7D#6    TF  
7DRQ    )   
7F?B          STO   5  COPEN(1) 
7H9W          LDCT  6  #42  
7HPG          ANDX  6  EXMARK(1)           [WAITING BIT 
7J96          BNZ   5  TG                  [JUMP IF OTHER USERS 
7JNQ          FREECORE 1                   [OTHERWISE FREE EXOF 
7K8B    TG    BZE   6  TH                  [JUMP IF NOBODY WAITING  
7KN2          LONGON   EDFDCLS             [WAKE THEM UP
7M6W          LDCT  0  #2   
7MLG          ANDX  0  6
7N66          BZE   0  TH                  [J IF OTHER PROC NOT WAITING 
7NKQ          AUTWIN   GFCLOSE             [TELL HIM WE HAVE CLOSED 
7PK2    TH    BZE   7  TB                  [JUMP IF UNIT NOT LOCKED 
7PMH ...      LDX   6  EWORK1(3)           [SUSN
7PNB ...      MURDER   3                   [KIL AOLPT   
7PXB ...      BPZ   7  TBR                 [J IF IPB FAIL-JUST RELST
7Q4L          UNLOCKSU 4                   [UNLOCK  
7QC2 ...TBR 
7QJ=          RELST    4                   [AND RELEASE 
7QKL ...      BRN      TDUN 
7QL# ...TB  
7QSG ...      LDX   6  EWORK1(3)           [SUSN
7QT8 ...      MURDER   3                   [KILL THE AOLPT  
7QTW ...TDUN
7QWJ ...      STO   6  ACOMMUNE8(2)        [STORE FOR HLS PURPOSES  
7QYL ...      STOZ     ACOMMUNE9(2)        [ZEROISE GEOG UNIT NO
7R2N ...      BZE   6  TKILL               [NO SUSN - NO GEOG UNIT NO   
7R4Q ...      FINDSU   1,6,TKILL           [LOOK FOR ASTUC  
7R6S ...      LDX   4  HUNIT(1)            [DL POINTER  
7R8W ...      LGEOG    4,4                 [GET GEOG UNIT NO
7R=Y ...      STO   4  ACOMMUNE9(2)        [STORE FOR HLS PURPOSES  
7R*2 ...TKILL   
7RHG          UP
7S36    #     CLOSE  SCRATCH FILE   
7SGQ    #   
7T2B    TA    MFINDEXOF 1,EXNUM(3)  
7T#Q ...      STOZ     EWORK1(3)           [SUSN - ZERO IN CASE NO FILE AREAS   
7TG2          LDEX  4  FIP+5(1) 
7T^L          BZE   4  NK                  [JUMP IF NO FILE AREAS   
7WF=          LDN   5  FDCELLS  
7WYW    NH    SMO      5
7XDG          LDX   6  0(1)                [SERIAL NUMBER FOR THIS AREA 
7XQW ...      STO   6  EWORK1(3)           [SUSN FOR HLS PURPOSES   
7XY6    NB    MFINDSUX 2,6                 [FIND ASTUC  
7YCQ          LDXC  0  CSCRATCH(2)  
7YXB          BCC      NA                  [JUMP IF NOT LOCKED  
7^C2 ...      COOR3  #41
7^WL          MFINDEXOF 1,EXNUM(3)         [REFIND EXOF 
82B= ...      BRN      NB                  [CHECK AGAIN IF LOCKED   
82TW    NA    SMO      5
83*G          LDX   6  1(1)                [CALCULATE BLOCK NUMBER FOR THIS AREA
83T6          MPY   6  HBLOCK(2)
84#Q          SMO      5
84SB          ADX   7  2(1) 
85#2          LDN   6  HSCRATCH(2)  
85RL    #SKI  K6CLOSBAC>199-199 
86?=    (   
86QW          BNZ   0  NJ                  [ERROR IF NO SCRATCH AREAS   
87=G          GEOERR   1,SCRATCHC   
87Q6    NJ  
889Q    )   
88PB    ND    SMO      6
8992          TXU   7  0
89NL          BCC      NC                  [JUMP IF ENTRY FOUND 
8=8=          ADN   6  1                   [UPDATE POINTER  
8=MW          BCT   0  ND   
8?7G          GEOERR   1,LOSTSCRA   
8?M6    NC    SBN   0  1
8#6Q          BZE   0  XEA                 [J IF NO ENTRIES TO MOVE UP  
8#LB    NE    SMO      6
8*62          LDX   7  1                   [MOVE UP REST OF LIST
8*KL          SMO      6
8B5=          STO   7  0
8BJW          ADN   6  1
8C4G          BCT   0  NE   
8CJ6    XEA 
8D3Q          LDX   0  CSCRATCH(2)  
8DHB          SBN   0  1
8F32          STO   0  CSCRATCH(2)         [UPDATE SCRATCH COUNT
8FGL          LDX   6  BACK1(2) 
8G2=          BPZ   6  NF                  [JUMP IF NOT DEAD
8GFW          BNZ   0  NF                  [OR STILL HAS SCRATCH AREAS  
8G^G          FREECORE 2                   [FREE ASTUC  
8HF6          MFINDEXOF 1,EXNUM(3)  
8HYQ          BRN      NG   
8JDB    NF    LDN   6  HSCRATCH+8-A1
8JY2          ADX   6  CSCRATCH(2)  
8KCL          TXL   6  ALOGLEN(2)   
8KKW ...      BCC      NG                  [J IF NOT TO BE ALTLENED 
8LBW          SBN   6  8
8LWG          LDX   7  2
8MB6          LDCT  0  #400 
8MTQ          ORS   0  CSCRATCH(2)         [SET LOCKOUT BIT 
8N*B          ALTLEN   7,6                 [ALTER LENGTH OF BLOCK   
8NT2          MFINDEXOF 1,EXNUM(3)  
8P#L          SMO      5
8PS=          LDX   6  0(1) 
8Q?W          MFINDSUX 2,6                 [FIND ASTUC  
8QRG          LDCT  0  #400 
8R?6          ERS   0  CSCRATCH(2)         [UNSET LOCK BIT  
8RQQ    NG    ADN   5  6
8S=B          BCT   4  NH   
8SQ2    NK    FREECORE 1                   [FREE EXOF   
8T9L          BRN      TB   
8TP=    #   
8W8W    #   
8WNG    #   
8X86    Q24   +24   
8XMQ    #   
8Y7B    #   
8YM2    QA    MFINDEXOF 1,EXNUM(3)         [FIND EXOF FOR FILE  
8^6L          LDX   6  ASUSN(1) 
8^F2 ...      STO   6  EWORK1(3)           [SUSN FOR HLS PURPOSES   
8^YL ...QB    FINDSU   2,6,QBXX              [FIND ASTUC IF ONE EXISTS  
9CRB          LADDP    HUNIT(2),1          [GET POINTER TO AUXILARY PERIPHERAL I
9D?2          LDX   0  BSUNIT(1)
9DQL          BPZ   0  QBX                 [J IF NOT BEING GRUESOMED
9F== ...      COOR3     ENDGRU             [ELSE WAIT   
9FPW          BRN      QB                  [AND TRY AGAIN   
9G9G ...QBX   SMO      FX1  
9Q6S ...      LDX   0  XM3  
9Q8F ...      ANDS  0  ASMARK(2)
9Q=8 ...      LDCT  0  #20                 [SET B4 IN ASTUC SO THAT 
9QDW ...      ORS   0  ASMARK(2)           [KARTCONT WILLL OVERWRITE OLD
9QJ9 ...      LDX   0  HUNIT(2) 
9QMJ ...      SMO      FX2                 [INFO WITH NEWLY READ INFO   
9QW= ...      STO   0  AWORK3              [STORE D.L. PTR FOR CARTCONT 
9R4Y ...      DOWN     CARTCONT,2   
9TNN ...QBXX
9TYG          MFINDEXOF 1,EXNUM(3)  
9WD6    QE  
9WXQ    #SKI  K6CLOSBAC>199-199 
9XCB    (   
9XX2          LDX   0  COPEN(1) 
9YBL          SBN   0  1
9YW=          BZE   0  QD   
9^*W          GEOERR   1,CLOSSCNT   
9^TG    QD  
=2*6    )   
=2SQ          FREECORE 1                   [FREE EXOF   
=3#B          LONGON   #71  
=3FJ ...      BRN      TB   
=4R=    #   
=5=W    #   
=5QG          MENDAREA 30,K99CLOSBAC
=6=6    #END
^^^^ ...251614350002