ASMB,R,L,C     ** RT DISPATCHER MODULE ** 
      HED REAL TIME DISPATCHER
*     DATE:   5/5/75
*     NAME:   DISPM 
*     SOURCE: 92060-18013 
*     RELOC:  92060-16013 
*     PGMR:   G.A.A.,L.W.A.,D.L.S.
* 
*  ***************************************************************
*  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1976.  ALL RIGHTS     *
*  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,      *
*  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT*
*  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.       *
*  ***************************************************************
* 
      NAM DISPM,0 92060-16013 REV.1813 780212 
* 
      SUP 
********************************************************************
* 
* 
***** AMD ***** JUL,73
* 
* 
********************************************************************
* 
*   DISPATCHER ENTRY POINT NAMES
* 
      ENT $RENT,$BRED,$ZZZZ,$XEQ
      ENT $MRMP,$ENDS,$MATA,$MPFT,$BGFR,$RTFR 
      ENT $ALDM,$DMAL,$SMAP,$PRCN 
      ENT $EMRP,$LPSA,$XDMP 
* 
*   DISPATCHER EXTERNAL REFERENCE NAMES 
* 
      EXT $RSRE,$ABRT,$XSIO,$DREQ 
      EXT $WATR,$TIME,$DREL,$TRRN 
      EXT $IOCL,$IRT
      EXT $ABRE,$LIST,$RTST,$SGAF 
* 
************MEW INSTRUCTIONS********* 
*     MIC USA,101711B,0 
************************************* 
* 
* 
* 
********************************************************************
* 
*        THE DISPA MODULE OF THE HP-2100 REAL TIME EXECUTIVE       *
*    PERFORMS THE FOLLOWING FUNCTIONS:                             *
*        1. IDLE LOOP WHEN NO PROGRAMS ARE SCHEDULED OR CANNOT BE  *
*           EXECUTED.                                              *
*        2. SWITCHES PROGRAM EXECUTION SUCH THAT THE HIGHEST       *
*           PRIORITY EXECUTABLE PROGRAM EXECUTES.                  *
*        3. SETS THE FENCE REGISTER ACCORDING TO PROGRAM TYPE.     *
*        4. LOADS, SWAPS, AND EXECUTES DISC RESIDENT PROGRAMS      *
      SPC 4 
ABORT LDA B,I       GET POSSIBLE NEXT PGM 
      STA $ZZZZ     AND SET IT FOR ABORT
      CLA           CLEAR THE XSUSP ADDRESS 
      STA B,I       FOR THE NEXT START
      ADB DM8       BACK UP TO ID-SEG ADDRESS 
      STB A         SAVE THE ID-SEG. ADDRESS
      STB TMP       A FEW TIMES 
      ADA D14       CHECK IF DISC RES.
      LDA A,I       PROGRAM 
      STA ATMP      SAVE TYPE FOR LATER CHECK 
      RAR,SLA       IF TYPE 2 OR 3
      JSB DREL      RELEASE ANY SWAP TRACKS 
      LDB TMP       RELEASE ANY RE-ENTRENT
      JSB $ABRE     MEMORY PROGRAM OWNS.
      LDB TMP       RELEASE ANY STRING STORAGE
      JSB $RTST      MEMORY THAT THE PROGRAM OWNS.
* 
      LDB TMP 
      JSB $WATR     SCHEDULE ANYONE WAITING 
      LDB TMP 
      LDA B 
      ADA D20 
      STA TEMP      SAVE ADDR OF FLAG WORD
      LDA A,I 
      ALF,ALF       GET FLAG WORD 
      SLA             ANY RESOURCES HELD? 
      JSB $TRRN      YES, RELEASE THEM
* 
      CLA           IF CURRENTLY
      LDB TEMP,I
      STA TEMP,I     (CLEAR FLAG WORD)
      SLB           IS HE SERIALLY REUSABLE 
      JMP $XEQ      YES,LEAVE IN MEMORY 
      LDA ATMP      GET TYPE
      AND D15 
      CPA D1        IS IT MEM RES 
      JMP $XEQ      YES,DONT FOOL WITH PARTITION
      LDA TMP       GET ID SEG ADR
      JSB MATEN     GO SET UP POINTERS
      LDB MID,I     GET PART RESIDENT 
      CPB TMP       IS PROG STELL RESIDENT
      RSS           YES 
      JMP $XEQ      NO,DONT BOTHER WITH IT
      LDB MRDFL,I 
      SSB           IS IT REAL TIME PART
      JMP XN253     YES 
      JMP XN153     NO
      SKP 
*     CALLING SEQUENCE
*     JMP $XEQ
* 
$XEQ  LDB $ZZZZ     CHECK IF PROGRAM TO BE ABORTED
      SZB 
      JMP ABORT     YES GO HANDLE IT
      LDB $LIST     IF LIST NOT ENTERED 
      SZB,RSS       THEN NOTHING NEW SO 
      JMP $IRT      GO CONTINUE CURRENT PGM 
* 
X0005 LDA SKEDD     LOAD TOP OF SCHEDULE LIST 
      CLB 
      STB $LIST     PREVENT NEEDLESS LIST SCANS 
      RSS           SKIP FIRST TIME 
X0035 LDA ZWORK,I   GET THE NEXT PGM IN THE LIST
      SZA,RSS       IF ZERO,THEN NO PROG SCHED
      JMP ILOOP     GO IDLE LOOP
      CPA SGSUP     IS THIS PROG SEG LOAD SUSPENDED 
      LDA A,I       YES,TRY NEXT PROG 
      SZA          IF ZERO, THEN NO PROG SCHED
      JMP X0010    GO TO PROCESS SCHED LIST 
* 
*     NO PROGRAM SCHEDULED--SETUP FOR IDLE LOOP 
*                                                                  *
*        THE IDLE LOOP SECTION CONSISTS OF:                        *
*              CLEARING XEQT WORD TO SIGNIFY THAT NO PROGRAM       *
*                   CURRENTLY EXECUTING.                           *
*              STORE ADDRESS OF 4 DUMMY WORDS INTO XSUSP-XSUSP+3   *
*                   DUE TO I/O PROCESSING.                         *
*              SET MEMORY PROTECT REGISTER TO ZERO.                *
*              CALL INTERRUPT RESTORE ROUTINE, $IRT 
*              JUMP TO *                                           *
*                                                                  *
ILOOP STA FENCE     SET THE FENCE TO ZERO 
      OTA 5 
      STA XEQT     CLEAR XEQT ADDRESS VALUE 
      LDB VSUSP     SET XSUSP,XA,XB,XEO 
      STB XSUSP     TO POINT
      INB           TO DUMMY
      STB XA        LOCATION
      STB XB
      STB XEO 
      STB XI
      JMP $IRT      GO TO IDLE LOOP (JMP *) 
* 
IDLE  JMP *        IDLE LOOP
      SPC 1 
XQDEF DEF XLINK    XEQT TABLE ADDRESS 
VSUSP DEF *+1      ADDRESS OF IDLE DUMMY WORDS
      DEF IDLE     DUMMY XEQT IDLE WORDS
      OCT -1
      NOP 
      SKP 
X0N35 LDA ZMPID,I   IS LOAD FLAG SET
      SSA 
      JMP X0035     CANT SWAP IS S=1,PART SPEC AT LOAD
      LDB LSTHD,I   GETNEXT IN LIST 
      SZB,RSS 
      JMP X0035     END OF LIST, TOUGH LUCK 
XN351 CPB ALIST     END OF DORMANT LIST 
      LDB B,I       YES,BUMP ONE MORE 
      JMP SCHLA     GO TRY NEXT ONE 
      SKP 
* 
*        THE SWITCHING SECTION USES THE SCHEDULE LIST TO DETERMINE *
*        WHICH PROGRAM TO EXECUTE-STARTING FROM TOP OF LIST.       *
*              IF PROGRAM FROM LIST OF LOWER OR EQUAL PRIORITY,    *
*                   THEN EXECUTION OF CURRENT PROGRAM CONINUES.   * 
*              IF PROGRAM FROM LIST OF HIGHER PRIORITY AND         *
*                   TYPE EITHER REAL TIME RESIDENT OR BACKGROUND   *
*                        RESIDENT, EXECUTION SWITCHING TAKES PLACE.*
*                   TYPE IS BACKGROUND DISC RESIDENT,              *
*                        GO TO BACKGROUND DISC PROCESSING.         *
*                   TYPE IS REAL TIME DISC RESIDENT, GO TO REAL    *
*                        TIME DISC RESIDENT PROCESSING             *
* 
X0010 STA ZWORK    SCHED LIST PROG ID SEG ADDRESS 
      ADA D6
      STA ZPRIO     PRIORITY ADDRESS
      ADA D8
      STA ZTYPE    TYPE ADDRESS 
      ADA D7
      STA ZMPID     MAP WORD ADDRESS
      LDA A,I 
      AND S1700     SET UP FENCE INDEX
      LSL 1          FOR PROGRAM TRYING 
      ALF,ALF         TO BE DISPATCHED. 
      STA MPN 
* 
*     CHECK IF CURRENT PGM IS STILL TOP.
* 
      LDA XEQT    SEE IF PROGRAM CURRENTLY EXECUTING
      SZA,RSS       YES  SKIP 
      JMP X0030     NO, SO GO XECUTE IT 
      ADA D15      CHECK STATUS OF XEQT ID SEGMENT
      LDA A,I 
      AND D15       MASK TO MAJOR STATUS
      CPA D1
      RSS          SCHEDULED-SO GO TO CHECK PRIORITY
      JMP X0030    NOT SCHEDULED -SO GO SWITCH
      LDA XPRIO,I   LOAD TEST PROGRAM PR
      CMA,INA       MAKE NEGATIVE 
      ADA ZPRIO,I   SUPTRACT FROM CURRENT PGM PR. 
      SSA,RSS       IF SIGN A=0 THEN PROG OF HIGHER PR
      JMP $RENT     PROGRAM OF HIGHER PRIORITY
* 
*     CHECK PROGRAM TYPE
* 
X0030 LDA ZTYPE,I  PROGRAM TYPE 
      AND D15 
      STA TMP 
      CPA D1        CHECK IF REAL TIME RESIDENT 
      JMP X0F40     YES 
      LDB ZMPID,I 
      SSB           ASSIGNED TO A PARTITION 
      JMP PCHK      YES,GO SEE WHAT TYPE
      CPA D2        CHECK IF REAL TIME DISK RESIDENT
      JMP X0200     YES 
      CPA M3        CHECK IF BACKGROUND DISK RESIDENT PROGRAM 
      JMP X0100     YES 
      JMP X0035     NOT LEGAL TYPE, IGNOR 
PCHK  LDA B         ASSIGNED TO PART AT LOAD TIME 
      AND B77 
      MPY D6
      ADA MATA      GET PART ADR
      ADA D5        GET FLAG WORD 
      LDA A,I 
      SSA           IS IT RT
      JMP X0200     YES 
      JMP X0100     NO,BACKGROUND 
D5    DEC 5 
ATMP  BSS 1 
* 
DM8   DEC -8
DM12  DEC -12 
D7    DEC 7 
M40   OCT 40
      SKP 
X0F40 LDA MRMP      GET ADR MEM RES MAP 
      USA 
      LDA ZMPID,I   GET MAP ID WORK 
      AND S1700 
      ALF,ALF       PICK OUT MPFT INDES 
      RAL 
      STA MPN       STORE MPFT INDEX
      LDA ZWORK 
      STA MEMID     SET ID FOR MEM RES PROG 
      ADA MI        GET ADR FOR INDEX REGISTERS 
      STA XI        SET POINTER TO INDEX REGISTERS
      LDA $EMRP 
      STA RTDRA 
      STA AVMEM 
      STA BKDRA 
      STA BKLWA 
      LDA ADMEM 
      STA MID 
      JMP X0N40 
ADMEM DEF MEMID 
MEMID BSS 1 
MPN BSS 1           INDEX TO MPFT, BP FLAG
PGN BSS 1           PROG LENGTH 
$EMRP BSS 1 
$LPSA BSS 1 
MLNK BSS 1          LINKAGE WORD
MPRIO BSS 1         PRIORITY RESIDENT 
MID   BSS 1         ID SET ADR
MADR  BSS 1         MAP START,BITS 0-9
MLTH  BSS 1         PART LENGTH, BITS 0-9 
MRDFL BSS 1         READ FLG(0-2),RT FLAG(15) 
CNT   BSS 1         PARTITION # 
B77   OCT 77
C77   OCT 177700
B76K  OCT 76000 
S1700 OCT 101700    SCREEN FOR LOAD FLAG &MP INDEX
B1777 OCT 1777
D21   DEC 21
MFLGS BSS 1         UPPER BITS
B7    OCT 7 
PTNUM EQU B77 
LTH BSS 1 
MI    OCT 177776    MINUS # INDEX REGS
LSTHD BSS 1 
NPGN  BSS 1 
SPRIO BSS 1 
ABGFR DEF $BGFR     ADR BG FREE LIST
ABGPR DEF BGPR      ADR BG ALC LIST HD
ARTFR DEF $RTFR 
ARTPR DEF RTPR
ALIST BSS 1 
FLIST BSS 1 
$MRMP BSS 1         ADDR MEM RES MAP
$ENDS BSS 1         PAGES OCCUPIED BY SYSTEM ,LIBR
$MATA BSS 1         ADR FIRST ENTRY MAT 
$MPFT BSS 1         ADR MEM PRT FRNCE TABLE 
MRMP  EQU $MRMP 
MATA EQU $MATA
MPFTA EQU $MPFT 
$BGFR BSS 1         LIST HEAD BG FREE PART
BGPR  BSS 1 
$RTFR BSS 1         LIST HEAD RT FREE LIST
RTPR  BSS 1         LIST HEAD RT ALC LIST 
ABGDM DEF BGDM
ARTDM DEF RTDM
BGDM  DEF BGPR
RTDM  DEF RTPR
DLIST NOP 
D22   DEC 22
      SPC 2 
******************************************* 
************MAT ENTRY********************** 
*EACH MAT ENTRY WILL BE AS FOLLOWS: 
* 
*  WORD    PURPOSE
*   0       LINKAGE (ADR NEXT ENTRY IN LIST)
*   1       PRIORITY OF RESIDENT
*   2       ID SEG ADR
*   3       BEGINNING PAGE ADR OF PARTITION 
*            BITS 0-9,BP FLAG BIT 15,DORMANT
*            FLAG BIT 13
*   4       NUMBER PAGES OCCUPIED BY PARTITION
*            BITS 0-9,RESERVED FLAG BIT 15
*   5       READ COMPLETION FLAG OF RESIDENT
*            BITS 0-2,REAL TIME FLAG BIT 15 
* 
* 
*THE FOLLOWING ARE SET AT GENERATION TIME:
*   BEGINNING PAGE ADR (WORD 3) 
*   NUMBER PAGES IN PART (WORD 4) 
*   REAL TIME FLAG (WORD 5) 
*   RESERVED FLAG (WORD 4)
* 
*THE FOLLOWING ARE SET AT PARTITION ASSIGNMENT: 
*   LINKAGE (WILL CHANGE IF PROG STATUS CHANGES 
*            OR PRIORITY CHANGES) 
*   PRIORITY (WILL CHANGE IF PROG CHANGES PRIO) 
*   ID ADR (CLEARED WHEN PART BECOMES FREE) 
*   BP FLAG (OBTAINED FROM MPID WORD IN ID SET) 
*   DORMANT FLAG (SET ON SAVE RESOURCES COMPLE) 
************************************************* 
      HED LOAD PROGRAM ID SEG ADR IN XEQT AREA
X0040 LDA MID,I     GET ID SET ADR
      ADA D22       GET LOW MAIN
      LDB A,I 
      STB XI
      LDA PGN       GET LENGTH IN PAGES 
      LDB MLNK      GET PART ENT ADR
      JSB $SMAP     GO SET UP USER MAP
X0N40 LDB ZWORK     IF SAME AS CURRENT PGM
      CPB XEQT      THEN
      JMP $RENT     SKIP BASE PAGE SET UP.
      LDA DM12      LOAD PROGRAM TO BE EXECUTED 
      STA TMP       INTO XEQT AREA
      LDA XQDEF 
      STB XEQT
X0041 STB A,I 
      INA 
      INB 
      ISZ TMP 
      JMP X0041 
      LDB XSUSP,I  CHECK IF PROGRAM SUSPENDED 
      CMB,INB,SZB   IF SO THEN
      JMP $RENT     GO SET IT UP
      LDB XPENT,I   GET PRIMARY ENTRY PT. 
      STB XSUSP,I   SET ENTRY ADDRESS 
      LDA ZTYPE,I   IF BACKGROUND 
      SLA           DISC RESIDENT 
      IOR M40       SET THE 
      STA ZTYPE,I   ALL OF CORE BIT.
* 
*      CHECK IF PT OF SUSPENSION IN LIBRARY AREA
* 
$RENT LDA XEQT      GET PROG TRYING DISPATCH
      CPA MID,I     HAS SETUP CHANGED 
      RSS           NO,GO TO IT 
      JSB FIX       GO SET BACK UP
      CPA ZWORK     INSURE Z WORDS
      RSS            MATCH CURRENTLY
      JSB FIX         EXECUTING PROGRAM.
      LDB XTEMP+4   GET THE RENT BIT
      ADB D15 
      LDB B,I       GET THE WORD
      BLF,RBL       ROTATE TO PUT RENT BIT IN SIGN
      SSB,RSS       IF RENT NOT IN CONTROL
      JMP X0028     GO SET FENCE
      SLB           IF MEMORY MOVED 
      JSB $RSRE     GO RESTORE IT 
      LDA FREG1     SET THE LIBRARY FENCE 
      JMP X0029     GO SET IT UP
      SKP 
* 
* 
******************************************************
******************************************************* 
*******NOTE THAT FIX IS BEING CALLED******************
*******TO RESET MAT POINTERS--THUS******************* 
*******THE TEMP WORDS MUST BE RESET****************** 
***************************************************** 
****AREG MUST CONTAIN XEQT ON ENTRY************** 
* 
FIX   NOP           ROUTINE TO RESET MAT POINTERS FOR CURRENT PROG
      STA ZWORK     RESET UP TEMP WORDS 
      ADA D6
      STA ZPRIO 
      ADA D8
      STA ZTYPE 
      ADA D7
      STA ZMPID 
      LDA ZTYPE,I   GET PROG TYEP 
      AND D15 
      CPA D1
      JMP X0F40     GO RESET MEM RES INFO 
      LDA ZMPID,I 
      AND S1700 
      LSL 1 
      ALF,ALF       GET MP FENCE INDEX
      STA MPN 
      JSB FND       GO SET MAT POINTERS, BNDRY WORDS
      LDA XEQT      RESET A-REG TO CURRENTLU XECUTING PROG. 
      JMP FIX,I 
* 
* 
*     SET MEMORY PROTECT ACCORDING TO PROG TYPE 
* 
* 
X0028 LDA MPN       GET MPFT INDEX
      ADA MPFTA 
      LDA A,I       GET FENCE 
X0029 STA FENCE 
      OTA 5B
* 
*    RESTORE REGISTERS, MEMORY PROTECT, AND TURN ON INTERRUPT SYSTEM
* 
X0031 JMP $IRT      GO EXECUTE THE PROGRAM
      HED XEQ PROCESSOR--BUFFERS, CONSTANTS, POINTERS, ETC
* 
ZMPID NOP 
* 
ZWORK NOP          SCHED LIST ID SEGMENT ADDRESS
ZPRIO NOP          SCHED LIST PRIORITY LIST 
ZTYPE LDB SKEDD    SCHED LIST PRIORITY ADDRESS
      SPC 1 
TEMP  ADB D6       TEMPORARY WORKING STORAGE AREA 
TEMP1 STB ZPRIO 
TEMP2 INA 
TEMP3 LDB B,I 
TEMP4 STB A,I 
TEMP5 CLB 
TEMP6 STB ZPRIO,I 
ZEXIT LDB BKRED 
      JMP $ZZZZ,I 
TMP   BSS 1         TEMPORARY WORKING STORAGE 
TMP1  BSS 1 
TMP2  BSS 1 
CN#SC NOP         CURRENT # SECTORS/TRACK (-) 
* 
DM3   DEC -3
* 
D2    DEC 2 
D4    DEC 4 
D8    DEC 8 
D6    DEC 6 
D14   DEC 14
D15   DEC 15
D20   DEC 20
D27   DEC 27
* 
D1    OCT 1 
M3    DEC 3 
B177  OCT 177 
B377  OCT 377 
      SKP 
********************************************
*ROUTINE TO SET USER MAP
*CALL:    AREG=LENGTH IN PAGES
*         BREG=ADR MAT ENTRY
********************************************
* 
* 
$SMAP NOP 
      STB XADR      MAT ENTRY ADR 
      STA XPGN      JPROG LENGTH IN PAGES 
      ADB D2
      LDA B,I       GET ID ADR
      ADA D22 
      LDA A,I       GET LOW MAIN
      AND B76K      GET START PAGE
      ALF 
      RAL,RAL       GET IN LOW 5 BITS 
      LDB ENDSY     GET RESITER USER STARTS ON
      STB STUSR     START USER WITH NO COMMON 
      CMB,INB 
      ADB A 
      SZB,RSS       B=0,NO COMMON 
      JMP MAPUS     NO COMMON 
MAPCM STA STUSR     SAVE START REG USER 
      LDA ENDSY     A REG START COMMON
      ADA D32       GET TO USER MAP 
      CBX           BREG HAS # REGISTERS
      LDB $ENDS     ADR OF START REG VALUE
CM1   XMS           MAP COMMON
MAPUS CLA,INA 
      CAX           SET TO MAP BASE PAGE REGISTER 
      LDA D32       FIRST REG IN USER MAP 
      LDB XADR
      ADB D3        GET TO START PARTITION WORD 
      LDB B,I 
      ELB,BRS       GET TO START PARTITION WORD 
      STB STVAL     STORE START VALUE 
      LDB STVAL     GET ADR START VALUE 
      XMS           MAP BASE PAGE 
      SEZ,RSS       E=1,DONT INCREMENT START VALUE
      ISZ STVAL 
      LDA D32 
      ADA STUSR     START REG IN USER MAP 
      LDX XPGN      GET LENGTH PROG 
      LDB STVAL 
      XMS           MAP 
MAPRM LDB STUSR     PROTECT REST OF MAP 
      ADB XPGN
      STB STUSR 
      CMB,INB 
      ADB D32 
      SZB,RSS       IF B=0,FINISHED 
      JMP $SMAP,I 
      CBX           GET # REGISTERS IN X
      LDA STUSR     GET START REGISTER
      ADA D32 
      LDB PRTCT     GET PROTECT VALUE 
      XMS 
      JMP $SMAP,I   YES,RETURN
PRTCT OCT 140000    READ & WRITE PROTECT
ENDSY EQU $ENDS 
STVAL BSS 1 
XADR  BSS 1 
XPGN  BSS 1 
STUSR BSS 1 
D32   DEC 32
* 
* 
*************EXTERNAL ROUTINE TO SET USER MAP******** 
***************************************************** 
**********CALL: LDA IDADR     AREG HAS ID SEG ADR 
**********      JSB $PVMP 
**********      --RETURN
**********  AREG=0 ON RETURN IS ERROR--SAYS PROGRAM 
**********         NOT IN PARTITION 
* 
* 
* 
$XDMP NOP 
      STA XADR      TEMP SAVE OF ID ADR 
      LDB A 
      ADB D14 
      LDA B,I 
      AND D15       IS PROG MEM RES 
      CPA D1
      JMP MRPV      YES,GO SET MEM RES MAP
      ADB D7        GET MPID WORD 
      LDA B,I 
      STA XPGN      TEMP SAVE 
      AND B77 
      MPY D6
      ADA MATA      GET PART ADR
      LDB A         B HAS MAT ENTRY 
      ADA D2
      LDA A,I 
      CPA XADR      IS PROG STILL IN PARTITION
      JMP *+3       YES ,CONTINUE 
      CLA           NO,ERROR
      JMP $XDMP,I   ERROR RETURN
      LDA XPGN
      AND B76K
      ALF 
      RAL,RAL       GET LENGTH
      JSB $SMAP     GO SET MAP
      CCA           MAKE SURE A NOT 0 
      JMP $XDMP,I   RETURN
MRPV  LDA MRMP
      USA           SET MEM RES MAP 
      JMP $XDMP,I 
D3    DEC 3 
      SKP 
**********************************************
****ROUTINE TO SEARCH FOR A PARTITION** 
**********************************************
* 
FNDSG NOP 
      LDA ZMPID,I   GET ID SEG ADR
      AND B77       GET PART #
      STA CNT 
      MPY D6        MULTIPLY BY MAT ENTRY LENGTH
      ADA MATA
      STA MLNK      SAVE PART ADR 
      ADA D2
      STA MID       SET POINTER TO PART RESIDENT
      LDA ZMPID,I 
      AND B76K      GET PROG LENGTH 
      CCB 
      ADA B 
      STA LTH 
      INA 
      ALF 
      RAL,RAL 
      STA PGN       SAVE LENGTH IN PAGES
      LDA ZMPID,I 
      AND S1700     GET MPFT INDES
      CLE,ELA       GET LOAD FLAG IN E
      ALF,ALF 
      STA MPN       MPN HAS MPFT INDEX AND BF FLAG(15)
******************************************
*AT THIS POINT THE FOLLOWING WORD ARE IN USE
*CNT--PARTITION NUMBER PROG LAST IN 
*MID--MAT ENTRY ADR FOR PARTITION ID SEG
*PGN--PROGRAM LENGTH IN PAGES 
*MPN--BITSD 0-3,MPFT INDES
*     BIT 15,BP LOAD FLAG(1,RECVER BP AREA
*EREG--LOAD FLAG,E=1,CNT IS PARTITION SPEC
*      AT LOAD,E=0,CNT IS PART LAST IN
******************************************
      LDB MID,I 
      CPB ZWORK     PROG STILL IN PARTITION 
      JMP FNDNS     YES 
      SEZ,CLE       NO,IS LOAD FLAG SET 
      JMP FNDSW     YES GO SEE IF CAN SWAP
******************************************
***SEARCH FOR PARTITION*********
**********
SRCH  LDB PGN       GET NEG LENGTH OF PROGRAM 
      CMB,INB 
      STB NPGN
      LDB FLIST     GET POINTER TO FREE LIST HEADER 
      JSB SCHFR     GO SEARCH FOR FREE PARTITION
      LDA ZPRIO,I   NO FREE PARTITION 
      CMA,INA 
      STA SPRIO     SEARCH ALLOC LIST FOR PART
      LDB ABGPR     LOAD BR ALLOCATED LIST POINTER
      LDA MID       GET ADR PART RES
      ADA M3        GET RDFLG ADR 
      LDA A,I 
      SSA           IS THIS RT PARTITION
      LDB ARTPR     YES,LOAD RT ALLOCATED LIST POINTER
      AND B7
      CPA M3        RESIDENT SWAPPED OUT
      RSS           YES 
      JMP SRCNT     NO,CONTINUE SEARCH
      CLA 
      CPA CNT       IS THIS PARTITION ZERO
      JMP *+3       YES,CONTINUE PARTITION CHECK
CNTSW JSB FND       NO,GO USE THIS PARTITION
      JMP FNDSG,I 
      CPB ALIST     IS THIS RIGHT TYPE PARTITION
      RSS           YES,CONTINUE
      JMP SRCNT     NO,GO SEARCH ALLOCATED LIST 
      LDA MID 
      ADA D2        GET LENGTH WORD 
      LDA A,I 
      SSA           IS THIS RESERVED PARTITION
      JMP SRCNT     YES,DON'T USE 
      AND B1777     NO,GET LENGTH 
      ADA NPGN
      SSA,RSS       S=0,PARTITION LONG ENOUGH 
      JMP CNTSW     LONG ENOUGH,GO USE IT 
SRCNT LDB DLIST,I   LESS OR EAUAL PRIORITY
      CPB ALIST     IS DORM LIST EMPTY
      LDB B,I       YES,BUMP TO ALLOC LIST
      JSB SCHAL     GO SEARCH 
      JMP X0035     CANT SWAP, GO TRY SOMEONE ELSE
SCHND NOP 
      LDA MATA      GET ADR OF MAT
      CMA,INA 
      ADA LSTHD 
      CLB 
      DIV D6        CALCULATE PART #
      LDB A 
      LDA ZMPID,I   GET MAP ID WORD 
      AND C77 
      IOR B 
      STA ZMPID,I   KJPUT NEW PART # IN 
      JMP SCHND,I 
      SKP 
* 
* 
*************************************** 
*ROUTINE TO SEARCH FOR A FREE PARTITION 
****CALL:  JSB SCHFR
*           --NO FIND RETURN
*          BREG--POINTER TO LIST HEADER 
*          NPGN--NEG CURRENT LENGTH 
*************************************** 
* 
* 
********************************************* 
**FREE LIST IS IN ORDER OF INCREASING SIZE
**********************************************
SCHFR NOP 
FR1   LDA B,I       GET ADR ENTRY(HAS LINK WORD)
      SZA,RSS       END OF LIST 
      JMP SCHFR,I   YES,NO FREE PART
      STA LSTHD     STRE CURRENT ENTRY ADR
      ADA D4
      LDA A,I       GET LENGTH PARTITION
      SSA           PART RESERVED 
      JMP FR2       YES,CANT USE
      AND B1777     SCREEN OUT FLAGS
      ADA NPGN      SEE IF GRTR,EQUAL TO CURRENT PRG
      SSA,RSS       IS S=0 PART BIG ENOUGH
      JMP FNDFR     FOUND ONE 
FR2   LDA LSTHD 
      STA B 
      JMP FR1 
********************************************* 
********************************************
*UNLINK PART FROM FREE LIST 
*LIND PART INTO ALLOCATED LIST
********************************************
* 
* 
FNDFR LDA LSTHD,I   GET ADR NEXT ENTRY
      STA B,I       UNLINK CURRENT ENTRY
      JSB SCHND     GO SET MAP ID WORD
FNDF1 LDA ZWORK 
      JSB MATEN     GO SET UP MAT POINTERS
      LDA ZPRIO,I   GET NEW PRIORTY 
      STA MPRIO,I   PUT IN PARTITION
      JSB ALINK     GO LINK IN ALLOCATED LIST 
      CLB           SET TO CLEAR RESIDENT FLAG
      STB MID,I     CLEAR PART ID WORD
      JMP FNDSG,I 
      SKP 
                                                                                                                                                                        