      JSB ZSAV
      STA CODE      /SAVE PARAMETER 
      LDA CNTL1 
      STA PARM
      CLA 
      STA ZIP 
      BLF           /POSITION FUNCTION CODE 
      RBL,RBL 
CNTL3 EQU * 
      ADB LU,I
      LDA CB11,I    * IF THIS TASK IS LOCKING 
      IOR CB12,I    *  IT'S DEVICE, LEAVE IT
      AND =B100000  *  LOCKED FOR CONTROL REQS
      IOR B         * 
      STA CONWD     * 
      JSB MTO,I 
      DEF *+6 
      DEF P03$
      DEF CONWD 
      DEF CODE
PARM  NOP 
      DEF IPAR
      JSB ZRET
CNTL1 DEF ZIP 
ZIP   NOP 
* 
CNTLX EQU * 
      NOP 
      JSB ZSAV
      STA CODE
      JMP CNTL3     /PREP FOR 2 PARAMETERS
      SKP 
****************************************************
********************************************************************************
****************************************************
* 
LU    EQU * 
CB1   NOP 
TYPE  EQU * 
CB2   NOP 
CB3   NOP 
CB4   NOP 
CB5   NOP 
CB6   NOP 
CB7   NOP 
CB8   NOP 
CB9   NOP 
CB10  NOP 
CB11  NOP 
CB12  NOP 
CB13  NOP 
CB14  NOP 
CB15  NOP 
CB16  NOP 
STP$  EQU * 
CB17  NOP 
SUPV  EQU * 
CB18  NOP 
STPX  EQU STP$-CB1+1
STPY  EQU STPX+1
CONWD NOP 
CODE  NOP 
      SKP 
********************************************************************************
* 
*     PUSH SUBROUTINE - SAVE RETURN AND CB POINTERS,SET NEW 
*       CB POINTERS 
*     JSB PUSH
*     DEF *+3 
*     DEF X         ADDRESS OF LAST SUBROUTINE ARGUMENT 
*     DEF CB        ADDRESS OF NEW CB ARRAY 
* 
********************************************************************************
PUSH  NOP 
      LDB PUSH
      LDA B,I 
      CMA,CLE,INA 
      ADA PUSH      / 
      STA TEMP      /SAVE NO. OF PARAMETERS 
      LDA B,I 
      STA PUSH      /SAVE RETURN ADDRESS(PUSH)
      INB 
      LDA B,I       /GET SUBROUTINE RETURN
* 
      RAL,CLE,ERA   /REMOVE INDIRECT BIT
      INA 
      LDA A,I 
      STA IRET      /SAVE FOR PUSH DOWN 
      INB 
      LDA B,I       /GET NEXT CB SETTING
      STA CBNXT 
      JSB PUSHR     /PUSH DOWN STACK
      LDA CBNXT 
      LDB TEMP
      CPB N03$      /CHANGE CB IF 2 PARAMETERS
      JSB SETCB     /SET NEW CB DEFINITIONS 
      JMP PUSH,I
TEMP  NOP 
* 
* 
PUSHR NOP 
      JSB SETAD     /SET ADDRESS OF CB POINTERS 
      LDB STP$,I    /GET STACK POINTER
      INB 
      CPB SMAX      /CHECK FOR OVERFLOW 
      JMP ABRT2 
      ADB CB1       /FORM ADDRESS 
      LDA IRET
      STA B,I       /SAVE RETURN
      INB 
      LDA CBLOC 
      STA B,I       /SAVE CB ARRAY
      ISZ STP$,I
      ISZ STP$,I    /INCR STACK POINTER 
      JMP PUSHR,I 
      SKP 
********************************************************************************
* 
*     POP SUBROUTINE
*     JSB POP 
*     DEF *+1 
* 
********************************************************************************
POP   NOP 
RTRN  EQU POP 
      JSB SETAD     /SET ADDRESS OF CB POINTERS 
      LDB STP$,I
      CPB SMIN      /STACK EMPTY? 
      JMP ABRT3 
      ADB CB1 
      LDA B,I 
      STA CBNXT     /GET CB ARRAY 
      ADB N01$
      LDA B,I       /GET RETURN ADDRESS 
      STA POPX
      SZA,RSS 
      JMP ABRT4 
      LDA STP$,I
      ADA N02$
      STA STP$,I    /DECR STACK POINTER 
      LDA CBNXT 
      JSB SETCB     /SET CB ARRAYS
      JMP POPX,I
POPX  NOP 
* 
      SKP 
********************************************************************************
*     ALLOCATE DATA BLOCKS
*     JSB ALLOC 
*     DEF *+3 
*     DEF BLOK#     BLOCK # TO BE ALLOCATED 
*     DEF POOL#     BUFFER POOL #,0= RELEASE
* 
********************************************************************************
BLOK# NOP 
POOL# NOP 
ALLOC NOP 
      JSB .ENTR 
      DEF BLOK# 
      JSB SAVAD 
      LDA BLOK#,I   /SAVE BLOCK NO. 
      AND P01$      /INSURE 1 OR 2
      SZA,RSS 
      LDA P02$
      STA CB13,I
      LDA POOL#,I   /SAVE POOL NO.
      STA CB14,I
      SZA,RSS       /RELEASE? 
      JMP ALLC1     /YES
ALLC2 JSB GBUF      /NO-REQUEST BUFFER
      DEF *+3 
      DEF CB15,I
      DEF CB14,I
      LDB CB15,I
      CPB N01$      /AVAILABLE? 
      JMP ALLC3     /NO-GO PAUSE
      JSB BLKAD     /YES CALCULATE BLOCK PARAM. ADDR. 
      STA B,I       /SAVE ADDRESS 
      INB 
      LDA CB15,I
      ALF,ALF 
      IOR CB14,I    /FORM ID + POOL TYPE
      STA B,I       /SAVE POOL TYPE 
ALLCX EQU *         /RETURN 
      JSB POP 
* 
ALLC1 EQU * 
      JSB BLKAD     /CALCULATE BLOCK PARAM. ADDR. 
      CLA 
      STA B,I       /CLR ADDRESS
      INB 
      LDA B,I 
      AND RBYT$ 
      STA ALLC5     /SAVE POOL TYPE 
      LDA B,I 
      ALF,ALF 
      AND RBYT$ 
      STA ALLC4     /SAVE ID
      CLA 
      STA B,I       /CLR POOL TYPE
      JSB PBUF
      DEF *+3 
      DEF ALLC4 
      DEF ALLC5 
      JMP ALLCX 
ALLC4 NOP 
ALLC5 NOP 
* 
ALLC3 EQU * 
      JSB PAUZ      /PAUSE TILL BUFFER AVAIL. 
      DEF *+1 
      JMP ALLC2     /(NOTE) PAUZ SETS UP CB POINTERS
* 
BLKAD NOP 
      LDB CB13,I
      BLS 
      ADB CB4       ADDRESS OF BLOCK PARAM. 
      JMP BLKAD,I 
* 
* 
      SKP 
********************************************************************************
* 
*     PAUSE SUBROUTINE
* 
********************************************************************************
PAUZ NOP
      JSB .ENTR 
      DEF PAUZ
      JSB SAVAD 
      JSB MTO,I 
      DEF *+6 
      DEF P01$
      DEF P63$
      DEF P01$
      DEF P01$
      DEF IPAR
      JSB POP 
P63$  DEC 63
* 
      SKP 
********************************************************************************
* 
*     SPLIT SUBROUTINE
*     JSB SPLIT 
*     DEF *+4 
*     DEF LU        LOGICAL UNIT OF NEW THREAD
*     DEF BLOK#     BLOCK # TO BE ATTACHED TO NEW THREAD
*     DEF NWRDS    NO. OF WORK BLOCK WORDS TO PASS
*     JMP CONT      PARENT THREAD RETURNS HERE
*     ---           NEW THREAD STARTS HERE
* 
********************************************************************************
S1    NOP      LU OF NEW THREAD 
S2    NOP      BLOCK TO ATTACH
S3    NOP          # OF WORK BLOCK WORDS TO PASS
* 
SPLIT NOP 
      JSB .ENTR 
      DEF S1
      JSB SAVAD 
      LDA S1,I      /SAVE LU
      STA CB14,I
      LDA S2,I      /SAVE BLOCK # 
      AND P03$     /ALLOW 0-3 ONLY
      STA CB13,I
      LDA SPLIT     /SAVE RETURN ADDRESS
      INA 
      STA CB15,I
      LDA S3,I     /SAVE # OF WB WORDS
      STA CB16,I
* 
SPLT1 EQU * 
      CLA 
      STA CB3,I     /CLEAR FLAG 
      LDA ICBX1     /CALCULATE START OF CB'S
      MPY CBL 
      ADA ICBP
      STA B 
      LDA ICBX1 
      INA 
SPLT4 STA PIPAR     /SET PENDING IPAR 
      LDA B,I 
      CPA CB14,I    /LU MATCH?
      JMP SPLT2     /YES
SPLT3 EQU * 
      LDA PIPAR 
      CPA ICBX2     /END OF CB'S
      JMP SPLT5     /YES
      INA 
      ADB CBL       /NO-CHECK NEXT CB 
      JMP SPLT4 
SPLT5 LDA CB3,I 
      SZA,RSS       /ANY LU'S MATCH?
      JSB RTRN      /NO-RETURN
      JSB PAUZ      /YES-WAIT FOR IT
      DEF *+1 
      JMP SPLT1 
* 
SPLT2 EQU * 
      ISZ CB3,I     /INDICATE MATCHING LU 
      STB BASE      /SAVE POTENTIAL NEW CB
      ADB P02$
      LDA B,I 
      SZA,RSS       /CB BUSY? 
      JMP SPLT6     /ON 
      ADB N02$      /YES-RESUME SEARCH
      JMP SPLT3 
SPLT6 EQU * 
      LDA IPAR
      STA B,I       /SET CB BUSY
      STA CB3,I 
      INB 
      LDA B,I      /SAVE WB ADDRESS 
      STA CB14,I
      LDA CB13,I    /CALCULATE ADDRESS OF BLOCK PARAMETERS
      SZA,RSS      /ANY DATA BLOCKS TO TRANSFER?
      JMP SPLT9    /NO
      ADB P02$      /YES-OFFSET TO CB6
      CPA P02$      /MOVING DB2 ONLY? 
      ADB P02$      /YES-OFFSET TO CB8
      STB PTR       /SAVE DESTINATION POINTER 
      LDB N02$      /PRIME FOR 1 DATA BLOCK 
      CPA P03$      /BOTH?
      LDB N04$      /YES-INDICATE 4 WORDS TO MOVE 
      STB CB13,I    /SET MOVE COUNT 
      LDB CB6       /DETERMINE SOURCE ADDRESS 
      CPA P02$      /MOVING DB2 ONLY? 
      ADB P02$      /YES-OFFSET TO CB8
      JSB SPLTM     /MOVE ADDRESS 
      ISZ CB13,I   /DONE? 
      JMP *-2      /NO
SPLT9 EQU * 
      LDA CB16,I
      SZA,RSS      /WORK BLOCK TRANSFER?
      JMP SPLTA    /NO
      CMA,INA      /YES-SET LOOP COUNT
      STA CB16,I
      LDB CB4,I    /GET ADDRESS OF WB(PARENT) 
      LDA CB14,I   /GET WORK BLOCK(NEW) 
      STA PTR 
SPLTB EQU * 
      LDA B,I      /MOVE
      STA PTR,I 
      INB 
      ISZ PTR 
      ISZ CB16,I   /DONE? 
      JMP SPLTB    /NO-MOVE NEXT WORD 
SPLTA EQU * 
      LDA BASE      /MODIFY POINTERS FOR NEW CB 
      STA CB1 
      ADA N01$
      ADA SMIN
      STA STP$
      LDA CB15,I
      STA IRET
      LDA SPLT7 
      STA PUSHR 
      JMP PUSHR+2   /PUT NEW CB RETURN ON STACK 
SPLT7 DEF *+1 
      LDA PIPAR     /SET POINTER TO PENDING VALUE 
      STA IPAR
      JSB MTO,I 
      DEF *+7 
      DEF P01$
      DEF PWAIT 
      DEF P01$
      DEF P01$
      DEF IPAR
      DEF SPLT8 
      LDA CB3,I     /RESTORE POINTER
      STA IPAR
      LDA PIPAR     /SET NEW THREAD IN PARENT 
      STA CB3,I 
      JSB POP       /RETURN 
SPLT8 EQU * 
      DEF *-1 
* 
PWAIT OCT 20077 
* 
SPLTM NOP 
      LDA B,I       /GET PARENT VALUE 
      STA PTR,I     /SAVE ON NEW CB 
      ISZ PTR 
      CLA           /CLR PARENT 
      STA B,I 
      INB 
      JMP SPLTM,I 
* 
      SKP 
* 
*     RELEASE CONTROL BLOCK 
* 
RLSCB NOP 
      JSB ALLOC     /RELEASE DATA BLOCK 1 
      DEF *+3 
      DEF P01$
      DEF P00$
      JSB ALLOC     /RELEASE DATA BLOCK 2 
      DEF *+3 
      DEF P02$
      DEF P00$
      CLA 
      STA CB3,I     /INDICAT NOT BUSY 
      LDA CB2,I     /INSURE LOGGING OFF.
      AND RBYT$ 
      STA CB2,I 
SUSP  JSB MTO,I     /SUSPEND
      DEF *+2 
      DEF P53$
P53$  DEC 53
      SKP 
********************************************************************************
********************************************************************************
* 
SAVAD NOP 
      LDB SAVAD 
      ADB N04$
      LDA B,I 
      STA IRET
      JSB PUSHR 
      JMP SAVAD,I 
* 
* 
*     SET CONTROL BLOCKS
* 
SETCB NOP 
      STA CBLOC     /SET CB ARRAY LOCATION
      JSB SETAD     /SET ADDRESS OF CB POINTERS 
      LDB CBLOC 
      ADB N01$      /ADJUST TO ARRAY POINTER
      LDA CB1 
      STA B,I       /SET CB ARRAY 
      ADB P02$
      LDA CB4,I 
      STA B,I       /SET WB ARRAY 
      ADB P02$
      LDA CB6,I 
      STA B,I       /SET DB#1 ARRAY 
      ADB P02$
      LDA CB8,I 
      STA B,I       /SET DB#2 ARRAY 
      JMP SETCB,I 
* 
* 
SETAD EQU * 
      NOP 
      JSB STAT      /GET STATUS 
      CCA 
      ADA IPAR      /CALCULATE ADDRESS OF CB
      MPY CBL 
      ADA ICBP
      LDB CBX       /INITIALIZE LOOP
      STB PTR 
      LDB CBTL
SETA1 STA PTR,I     /SET ADDRESSES
      ISZ PTR 
      INA 
      INB,SZB 
      JMP SETA1 
      JMP SETAD,I 
CBX   DEF CB1 
* 
*     INTERNAL SAVE/RESTORE RETURN ADDRESSES
* 
ZSAV  NOP 
      STB ZSAVB 
      LDB ZSAV
      ADB N02$
      LDB B,I 
      STB SUPV,I
      LDB ZSAVB 
      JMP ZSAV,I
* 
ZRET  NOP 
      JSB SETAD 
      LDB SUPV,I
      STB ZRET
      JMP ZRET,I
ZSAVB NOP 
* 
* 
* 
STAT  NOP 
      LDA IPAR
      STA PSTAT     /SAVE CURRENT THREAD
      JSB MTO,I 
      DEF *+6 
      DEF P79$
      DEF ISTAT 
      DEF IPAR
      DEF ILU 
      DEF ILOG
      LDA IPAR
      LDB PSTAT 
      SZA,RSS       /THREAD =0? 
      STB IPAR      /YES-RESTORE PREVIOUS THREAD
      LDA IPAR
      SZA,RSS 
      JMP ABRT5 
      JMP STAT,I
PSTAT NOP 
P79$  DEC 79
.STAT EQU STAT
      SKP 
********************************************************************************
* 
*     THREAD ABORT ROUTINES 
* 
********************************************************************************
ABRT5 JSB ABORT     /ILLEGAL THREAD ID (0)
ABRT4 JSB ABORT     /RETURN ADDRESS=0 
ABRT3 JSB ABORT     /STACK UNDERFLOW
ABRT2 JSB ABORT     /STACK OVERFLOW 
********************************************************************************
ABRTX DEF *+2 
ABORT NOP 
      LDA ABORT 
      CMA,INA 
      ADA ABRTX 
      ADA =B30060   /OUTPUT NAME:XX AB
      LDB =B40502   /XX=ERROR TYPE
      JSB ERR0
      JMP SUSP
CBTL  ABS -STPY 
SMIN  ABS STPX
SMAX  EQU CBL 
PTR   NOP 
PIPAR NOP 
CBLOC NOP 
IRET  NOP 
CBNXT NOP 
BASE  NOP 
* 
*     BASE PAGE CONSTANTS 
* 
#     EQU 53B 
N01$  EQU #-1 
N02$  EQU #-2 
N03$  EQU #-3 
N04$  EQU #-4 
N05$  EQU #-5 
N06$  EQU #-6 
N07$  EQU #-7 
N08$  EQU #-8 
N09$  EQU #-9 
N10$  EQU #-10
N64$  EQU #-11
P00$  EQU # 
P01$  EQU #+1 
P02$  EQU #+2 
P03$  EQU #+3 
P04$  EQU #+4 
P05$  EQU #+5 
P06$  EQU #+6 
P07$  EQU #+7 
P08$  EQU #+8 
P09$  EQU #+9 
P10$  EQU #+10
P17$  EQU #+11
P64$  EQU #+12
M17$  EQU #+13
M37$  EQU #+14
M77$  EQU #+15
M177$ EQU #+16
RBYT$ EQU #+17      OCT 377 
LBYT$ EQU #+18      OCT 177400
M3777 EQU #+19      OCT 3777
M1777 EQU #+20      OCT 177700
CLEAR EQU P00$
OPENL EQU P02$
LCLOS EQU P03$
RWND  EQU P04$
RWNDX EQU P05$
DSTAT EQU P06$
LDR   EQU P08$
TOF   EQU P09$
      END 
::
:CO MOUNT TAPE #8, TYPE :GO 
:PA 
                                                                                                                                                            