%EXTERNALROUTINE SUP29
!-----------------------------------------------------------------------
%OWNSTRING(3) SUPID="23A"
!-----------------------------------------------------------------------
! STORE CONFIGURATION & EPAGE SIZE DECLARATIONS
! AMENDED 24/02/78  "SMACS","TRANS" & "KMON" INCLUDED
! COMMUNICATIONS RECORD FORMAT - EXTANT FROM CHOPSUPE 18A ONWARDS 
%RECORDFORMAT COMF(%INTEGER OCPTYPE,IPLDEV,SBLKS,SEPGS,NDISCS,  %C
         DDTADDR,GPCTABSIZE,GPCA,SFCTABSIZE,SFCA,SFCK,DIRSITE,  %C
         DCODEDA,SUPLVN,KLOKCORRECT,DATE0,DATE1,DATE2,  %C
         TIME0,TIME1,TIME2,EPAGESIZE,USERS,PROCMON,DQADDR,  %C
         SACPORT,OCPPORT,ITINT,CONTYPEA,GPCCONFA,FPCCONFA,SFCCONFA, %C
         BLKADDR,DPTADDR,SMACS,TRANS,%LONGINTEGER KMON,  %C
         %INTEGER SPDRQ,SMACPOS,SUPVSN,PSTVA,SECSFRMN,SECSTOCD, %C
         SYNC1DEST,SYNC2DEST,ASYNCDEST,MAXPROCS,INSPERSEC,  %C
         %INTEGERARRAY SP(0:15), %INTEGER  %C
         LSTL,LSTB,PSTL,PSTB,HKEYS,HOOT,SIM,CLKX,CLKY,CLKZ,  %C
         HBIT,SLAVEOFF,INHSSR,SDR1,SDR2,SDR3,  %C
         SDR4,SESR,S1,S2,S3,S4,END)
%RECORDNAME COM(COMF)
  COM==RECORD(X'80000000'+48<<18)
%CONSTINTEGER VIRTAD=X'81000000'
%CONSTINTEGER MAXPROCS=128
%INTEGER EPAGESIZE,SEGEPSIZE
  EPAGESIZE=COM_EPAGESIZE
  SEGEPSIZE=256//EPAGESIZE
!-----------------------------------------------------------------------
! PERIPHERAL CONTROLLER CONFIGURATION DECLARATIONS
%BYTEINTEGERARRAYNAME CONTYPE
%BYTEINTEGERARRAYFORMAT CONTYPEF(0:15)
  CONTYPE==ARRAY(COM_CONTYPEA,CONTYPEF)
%SWITCH CONROUT(1:3)
%INTEGERARRAYNAME BLOCKAD
%INTEGERARRAYFORMAT BLOCKADF(0:63)
  BLOCKAD==ARRAY(COM_BLKADDR,BLOCKADF)
!-----------------------------------------------------------------------
! MISC. ROUTINE SPECS
%EXTERNALROUTINESPEC SLAVESONOFF(%INTEGER ONOFF)
%EXTERNALSTRING(15)%FNSPEC STRINT(%INTEGER N)
%EXTERNALSTRING(8)%FNSPEC STRHEX(%INTEGER N)
%EXTERNALSTRING(63)%FNSPEC STRSP(%INTEGER N)
%EXTERNALROUTINESPEC PTREC(%RECORDNAME P)
%EXTERNALROUTINESPEC MONITOR(%STRING(63) S)
%EXTERNALROUTINESPEC EXTRADUMP(%INTEGER VAD,LEN)
%EXTERNALROUTINESPEC OPMESS(%STRING(63) S)
%EXTERNALROUTINESPEC DISPLAY TEXT(%INTEGER SCREEN,LINE,CHAR, %C
  %STRING(41) S)
%EXTERNALROUTINESPEC UPDATE TIME
%EXTERNALROUTINESPEC DPONPUTONQ(%RECORDNAME P)
%EXTERNALROUTINESPEC TURNONER(%RECORDNAME P)
%INTEGER I,J,K,FSTASL,BSTASL,FREEEPAGES,UNALLOCEPS,OVERALLOC, %C
  DEADLOCKS,STASLSEMA,PFREENL,NAMT,DRUMESIZE,DDSIZE,DRUMTASL,DRUMTN, %C
  MAXABTN,RECAPN,PTURNN,PSHAREN,LOADEPS,MAXP4,KSERVICE,LSERVICE, %C
  CURPROC1,CURPROC2,OLDLNB,ACTW0,ACTW1,ACTW2,ACTW3,IDLE,IDLEN,LCN, %C
  LPN,IT,IC,MPLEVEL,PAGEFREES,SESTK,SEIP,SELN,SCASSPC,KSTACK,ISTAD, %C
  LNBP5,PORT,GETEPN
%LONGINTEGER L
%STRING(3) STRPROC
!-----------------------------------------------------------------------
%RECORDFORMAT SSNP1F(%INTEGER LNB,PSR,PC,SSR,SF,IT,IC,LTB,XNB,%C
  B,DR0,DR1,A0,A1,A2,A3,PEAD,II)
%RECORD LSSNP1I(SSNP1F)
%RECORDFORMAT ISTF(%INTEGER LNB,PSR,PC,SSR,SF,IT,IC,SP)
%RECORD KSSNP1,LSSNP1,ISTDUM(ISTF)
%RECORDNAME ISTP,KSSNP1P,LSSNP1P(ISTF)
%LONGINTEGERARRAYFORMAT PSTF(0:127)
%LONGINTEGERARRAYNAME PST
!-----------------------------------------------------------------------
! STORE TABLE ETC. DECLARATIONS
%RECORDFORMAT STOREF(%BYTEINTEGER FLAGS,USERS, %C
  %HALFINTEGER LINK,BLINK,FLINK,%INTEGER REALAD)
%RECORDARRAY STORE(0:COM_SEPGS-1)(STOREF)    ;! ONE RECORD PER EPAGE
%INTEGERNAME STORESEMA
  PFREENL=COM_SEPGS//10
%INTEGERARRAY PFREEN(0:PFREENL)
!-----------------------------------------------------------------------
! ACTIVE MEMORY TABLE DECLARATIONS ETC.
  NAMT=COM_SEPGS*EPAGESIZE
%INTEGERARRAY AMTDA(1:NAMT)
! DA : DISC ADDRESS
%HALFINTEGERARRAY AMTP,AMTL(1:NAMT)
! P  : AMTDD POINTER
! L  : COLLISION LINK
%BYTEINTEGERARRAY AMTLEN,AMTUSERS,AMTPTS(1:NAMT)
! LEN : BLOCK LENGTH IN EPAGES
! USERS : NO OF USERS OF THIS BLOCK
%CONSTINTEGER MAXBLOCK=16    ;! MAX BLOCK SIZE
%CONSTINTEGER MAXAMTLIM=768
%CONSTINTEGER MINAMTLIM=112
  DDSIZE=NAMT*MAXBLOCK//2
%HALFINTEGERARRAY AMTDD(1:DDSIZE)
! NEW EPAGE(1) / STOREX-DRUMTX(1) / ?X(14)
  %IF COM_SFCK=0 %THEN DRUMESIZE=0 %ELSE DRUMESIZE=COM_SFCK//EPAGESIZE
%HALFINTEGERARRAY DRUMT(0:DRUMESIZE)
! SPARE(2) / STOREX(14)
%CONSTINTEGER DTEND=X'FFFF'
%CONSTINTEGER NEWEPBIT=X'8000'
%CONSTINTEGER DTXBIT=X'4000'
%CONSTINTEGER STXMASK=X'3FFF'
%CONSTINTEGER DDBIT=X'8000'
%CONSTINTEGER AMTOS=20    ;! 20 SECS PER AM TIME-OUT
%CONSTINTEGER AMTON=6    ;! 2 MINS TOTAL TIME-OUT
!-----------------------------------------------------------------------
! PON & POFF ETC. DECLARATIONS
%EXTERNALROUTINESPEC PON(%RECORDNAME P)
%EXTERNALROUTINESPEC FASTPON(%INTEGER CELL)
%EXTERNALROUTINESPEC DPON(%RECORDNAME P,%INTEGER DELAY)
%EXTERNALINTEGERFNSPEC NEWPPCELL
%EXTERNALROUTINESPEC RETURN PPCELL(%INTEGER PPCELL)
%EXTERNALROUTINESPEC SEMALOOP(%INTEGERNAME SEMA)
%EXTERNALROUTINESPEC POFF(%RECORDNAME P)
%EXTERNALROUTINESPEC SUPPOFF(%RECORDNAME SERV,P)
%EXTERNALROUTINESPEC INHIBIT(%INTEGER SERVICE)
%EXTERNALROUTINESPEC UNINHIBIT(%INTEGER SERVICE)
%EXTERNALROUTINESPEC CLEAR PARMS(%INTEGER SERVICE)
%EXTERNALINTEGERFNSPEC PPINIT(%INTEGERFN NEW EPAGE)
%INTEGERFNSPEC NEW EPAGE
%RECORDFORMAT PARMF(%INTEGER DEST,SRCE,P1,P2,P3,P4,P5,P6)
%RECORDFORMAT PARMAF(%INTEGERARRAY P(0:7))
%RECORDFORMAT PARMXF(%INTEGER DEST,SRCE,P1,P2,P3,P4,P5,P6,LINK)
%RECORDARRAYFORMAT PARMSPF(0:2015)(PARMXF)
%RECORDARRAYNAME PARM(PARMXF)    ;! 0 NOT USED
%CONSTINTEGER LOCSN0=64
%CONSTINTEGER LOCSN1=192    ;! = LOCSN0+MAXPROCS
%CONSTINTEGER LOCSN2=320    ;! = LOCSN0+2*MAXPROCS
%CONSTINTEGER LOCSN3=448    ;! = LOCSN0+3*MAXPROCS
%CONSTINTEGER MAXSERV=576   ;! = LOCSN0+4*MAXPROCS
%RECORDFORMAT SERVF(%INTEGER P,L)
%RECORDNAME KSERV,KSERVQ,LSERV,LSERVQ(SERVF)
%EXTRINSICRECORDARRAY SERVA(0:576)(SERVF)    ;! 0 NOT USED
%RECORD P(PARMF)
%RECORDNAME PA(PARMAF)
%EXTRINSICINTEGER KERNELQ,RUNQ1,RUNQ2
%INTEGERNAME RUNQ,CURPROC
%EXTERNALLONGINTEGER KMON=0
!-----------------------------------------------------------------------
! SERVICE ROUTINE SPECS
%ROUTINESPEC SCHEDULE(%RECORDNAME P)
%ROUTINESPEC PAGETURN(%RECORDNAME P)
%ROUTINESPEC GET EPAGE(%RECORDNAME P)
%ROUTINESPEC RETURN EPAGE(%RECORDNAME P)
%ROUTINESPEC DEADLOCK
%ROUTINESPEC ACTIVE MEM(%RECORDNAME P)
%ROUTINESPEC CLEAR TIME
%ROUTINESPEC CLEAR EPAGE(%INTEGER STAD)
%LONGINTEGERFNSPEC CLOCK
%ROUTINESPEC UPDISP(%INTEGER PROCESS,OFFSET,%STRING(13) S)
%EXTERNALROUTINESPEC ELAPSEDINT(%RECORDNAME P)
%EXTERNALROUTINESPEC SEMAPHORE(%RECORDNAME P)
%EXTERNALROUTINESPEC DISC(%RECORDNAME P)
%EXTERNALROUTINESPEC PDISC(%RECORDNAME P)
%EXTERNALROUTINESPEC MOVE(%RECORDNAME P)
%EXTERNALROUTINESPEC DRUM(%RECORDNAME P)
%EXTERNALROUTINESPEC GPC(%RECORDNAME P)
%EXTERNALROUTINESPEC TAPE(%RECORDNAME P)
%EXTERNALROUTINESPEC OPER(%RECORDNAME P)
%EXTERNALROUTINESPEC PRINTER(%RECORDNAME P)
%EXTERNALROUTINESPEC LP ADAPTOR(%RECORDNAME P)
%EXTERNALROUTINESPEC CR ADAPTOR(%RECORDNAME P)
%EXTERNALROUTINESPEC CP ADAPTOR(%RECORDNAME P)
%EXTERNALROUTINESPEC COMMS CONTROL(%RECORDNAME P)
%EXTERNALROUTINESPEC MK1FEADAPTOR(%RECORDNAME P)
%EXTERNALROUTINESPEC COMREP(%RECORDNAME P)
%SWITCH SERVROUT(1:64)    ;! KERNEL SERVICES, (1:LOCSN0)
!-----------------------------------------------------------------------
! TIMING INFORMATION DECS.
%ROUTINESPEC TIMEOUT(%RECORDNAME P)
%LONGINTEGERARRAY SERVIT,SERVIC(0:LOCSN0+2)
%INTEGERARRAY SERVN(0:LOCSN0+2)
%LONGINTEGER CLOCK0,IDLEIT,LCIT,LCIC,LPIT,PTIT,PTIC,DRUMIT,DRUMIC, %C
  PDISCIT,PDISCIC,GETIT,GETIC,AMIT,AMIC
%INTEGER PTCALLN,DRUMCALLN,PDISCCALLN,AMCALLN,GETCALLN
%INTEGERNAME KIT    ;! IT IN KERNEL CONTEXT
!-----------------------------------------------------------------------
! PROCESS INORMATION ARRAY DECS ETC.
%RECORDFORMAT PROCF(%STRING(6) USER,%BYTEINTEGER INCAR,CATEGORY,WSN, %C
  RUNQ,ACTIVE,%INTEGER LAMTX,LSTAD,STACK)
%EXTERNALRECORDARRAY PROCA(0:128)(PROCF)    ;! (0:MAXPROCS)
%EXTERNALINTEGER PROCMON=0
!-----------------------------------------------------------------------
! LOCAL CONTROLLER DECS ETC.
%ROUTINESPEC LOCAL CONTROL
%CONSTINTEGER LSTLEN=128    ;! LOCAL SEGMENT TABLE LENGTH
%LONGINTEGERARRAYFORMAT LSTF(0:LSTLEN-1)
%CONSTINTEGER LSTACKLEN=3    ;! LOCAL CONT. STACK ELEN
%CONSTINTEGER LSTACKLENP=2    ;! PAGED PART
%CONSTINTEGER LSTKN=3    ;! NO OF LOCAL STACKS
%CONSTINTEGER MAXIT=X'7FFFFF'
%OWNINTEGER TIMESLICE=X'4000'    ;! 131072 MICROSECS
%OWNINTEGER MAXEPAGES=96
%EXTERNALINTEGERFNSPEC SYSTEMCALL
%CONSTINTEGER COMMSALLOC=8
%EXTRINSICINTEGER QUEUED STREAMS
!-----------------------------------------------------------------------
! INTERRUPT ROUTINE SPECS
%EXTERNALROUTINESPEC SYSERR(%INTEGER STK,IP)
!-----------------------------------------------------------------------
! INITIALISE IST (AFTER DECLARATIONS I.E. LNB & SF VALID)
  ISTAD=X'80000000'+COM_OCPPORT<<18
  ISTP==RECORD(ISTAD)    ;! IST BASE
  *STLN_OLDLNB    ;! USED TO FRIG %MONITOR LATER
  ISTP_LNB=OLDLNB
  ISTP_PSR=X'00140001'        ;! ACR=1, PRIV=1, PM=0, ACS=1
  ISTP_PC=0
  ISTP_SSR=X'01800FFE'        ;! ONLY SYSERR
  *STSF_I
  ISTP_SF=I
  ISTP_IT=MAXIT
  ISTP_IC=MAXIT
  ISTP_SP=0
  %CYCLE I=ISTAD+X'20',X'20',ISTAD+X'160'
    RECORD(I)<-ISTP
  %REPEAT
  ! SET UP LOCAL CONTROLLER->KERNEL CONTEXT
  KSSNP1=ISTP
  *JLK_<LCRETURN> ; *LSS_%TOS ; *ST_I
  KSSNP1_PC=I
  KSTACK=OLDLNB&X'FFFC0000'
  KSSNP1P==RECORD(KSTACK!X'40000')
  LSSNP1P==RECORD(X'40000')
  ! MASK SYSERR. ON SYSERR. INTERRUPT
  ISTP_SSR=X'01800FFF'
  ! SET SYSTEM ERROR SF TO DISTANT PLACE
  ISTP_SF=ISTP_SF+X'1000'
  ! INSERT PCS
  *LXN_ISTAD
  *JLK_<IST1I> ; *LSS_%TOS ; *ST_(%XNB+2)
  *JLK_<IST2I> ; *LSS_%TOS ; *ST_(%XNB+10)
  *JLK_<IST3I> ; *LSS_%TOS ; *ST_(%XNB+18)
  *JLK_<IST4I> ; *LSS_%TOS ; *ST_(%XNB+26)
  *JLK_<IST5I> ; *LSS_%TOS ; *ST_(%XNB+34)
  *JLK_<IST6I> ; *LSS_%TOS ; *ST_(%XNB+42)
  *JLK_<IST7I> ; *LSS_%TOS ; *ST_(%XNB+50)
  *JLK_<IST8I> ; *LSS_%TOS ; *ST_(%XNB+58)
  *JLK_<IST9I> ; *LSS_%TOS ; *ST_(%XNB+66)
  *JLK_<IST10I> ; *LSS_%TOS ; *ST_(%XNB+74)
  *JLK_<IST11I> ; *LSS_%TOS ; *ST_(%XNB+82)
  *JLK_<IST12I> ; *LSS_%TOS ; *ST_(%XNB+90)
!-----------------------------------------------------------------------
! CREATE LOCAL CONTROLLER CONTEXT
  LSSNP1I=0
  LSSNP1I_LNB=LSTLEN*8+LSTKN*X'80'+X'50'
  LSSNP1I_PSR=X'00140001'
  *JLK_<LCCALL>
  *LSS_%TOS
  *ST_I
  LSSNP1I_PC=I    ;! GOES TO CALL OF LOCAL CONTROL AFTER ACTIVATE
  LSSNP1I_SSR=X'01800FFE'
  LSSNP1I_SF=LSTLEN*8+LSTKN*X'80'+X'80'  ;! 12 MORE WORDS AFTER LNB
  LSSNP1I_IT=MAXIT
  LSSNP1I_IC=MAXIT
  *LSS_(%LNB+5)    ;! PRESERVE DISPLAY PTR
  *ST_LNBP5
!-----------------------------------------------------------------------
! GET SYSTEM CALL ASSEMBLER PC
  SCASSPC=SYSTEMCALL
  COM_DCODEDA=COM_SUPLVN<<24!COM_DIRSITE
!-----------------------------------------------------------------------
! SET UP CLOCK REGS
  I=COM_CLKZ
  *LB_I
  *LSS_13          ;! SHOULD GIVE 1 INTERRUPT EVERY 2 SECS (APPROX)
  *ST_(0+%B)       ;! Z-REG
  %IF COM_OCPTYPE=4 %THEN %START    ;! 2980 ONLY
    I=X'80000000'>>COM_SACPORT
    *LB_X'4012'
    *LSS_(0+%B)
    *OR_I
    *ST_(0+%B)
  %FINISH %ELSE %START
    %IF COM_OCPTYPE=6 %THEN %START    ;! 2976
      I=X'80000000'>>COM_OCPPORT
      *LB_X'4012'
      *LSS_(0+%B)
      *OR_I
      *ST_(0+%B)
    %FINISH
  %FINISH

!-----------------------------------------------------------------------
! FIND END OF KERNEL STACK ETC.
  EXTRADUMP(ISTAD,X'180')    ;! IST
  PST==ARRAY(X'80040000',PSTF)      ;! PST IN SEG 8193 (OCPPORT NEVER 1)
  ! CLEAR CHOPSUPE CODE GLA & STACK SEGMENTS FROM PST
  PST(44)=0 ; PST(45)=0 ; PST(46)=0 ; PST(47)=0
  EXTRADUMP(X'80040000',INTEGER(X'80040008')&X'FFFC'+128)    ;! PST
  EXTRADUMP(X'80240000',PST(9)>>32&X'3FF80'+X'80')    ;! KERNEL GLA
  EXTRADUMP(X'80C00000',X'1000')
  ! CLEAR 8 K OF STACK
  %CYCLE I=0,1,7999; *LSD_0; *ST_%TOS; %REPEAT
  %CYCLE I=0,1,7999; *LSD_%TOS; %REPEAT
  K=128//EPAGESIZE    ;! EPAGESPERBLOCK
  %CYCLE I=0,1,COM_SEPGS-1
    STORE(I)=0
    J=I//K
    STORE(I)_REALAD=BLOCKAD(J)!(EPAGESIZE*(I-J*K))<<10
  %REPEAT
  ! SET KERNEL STACK SEGMENT LIMIT
  L=(ISTP_SF&X'3FFFF'+X'107F')>>7
  I=PST(4)&X'0FFFFFF8'+L<<7
  J=EPAGESIZE<<10
  K=(I+J-1)//J*J    ;! ALLIGN ON EPAGE
  L=L+(K-I)>>7
  PST(4)=PST(4)&X'FFFC007FFFFFFFFF'!(L-1)<<39
  EXTRADUMP(X'80100000',L*128)
  ! INITIALISE FREE STORE PAGES ARRAY
  FSTASL=K//J
  BSTASL=COM_SEPGS-1
  %CYCLE I=FSTASL,1,BSTASL-1
    STORE(I)_FLINK=I+1
  %REPEAT
  STORE(BSTASL)_FLINK=0
  FREEEPAGES=COM_SEPGS-FSTASL
  J=12    ;! USE 12K TO 16K
  %IF COM_OCPTYPE=3 %THEN K=16 %ELSE K=32    ;! USE OVERLAY AREA IF NOT 2970
  J=(J+EPAGESIZE-1)//EPAGESIZE
  K=K//EPAGESIZE-1
  %CYCLE I=J,1,K
    STORE(I)_FLINK=I+1
  %REPEAT
  STORE(K)_FLINK=FSTASL
  FSTASL=J
  FREEEPAGES=FREEEPAGES+K-J+1
  STORE(FSTASL)_BLINK=0
  I=FSTASL    ;! SET UP BACKWARD LINKS
  %UNTIL I=BSTASL %CYCLE
    J=I
    I=STORE(I)_FLINK
    STORE(I)_BLINK=J
  %REPEAT
  STORESEMA==STORE(0)_REALAD
  STORESEMA=-1
  STASLSEMA=-1
  GETEPN=0
!-----------------------------------------------------------------------
  PARM==ARRAY(PPINIT(NEW EPAGE),PARMSPF)
  OVERALLOC=COM_SEPGS//4    ;! 25% OVERALLOCATION
  UNALLOCEPS=FREEEPAGES+OVERALLOC-COMMSALLOC
  CURPROC1=0
  CURPROC2=0
  IDLE=0
  KIT==INTEGER(X'80140014')
!-----------------------------------------------------------------------
! INITIALISE ACTIVATE WORDS
  ACTW0=(LSTLEN-1)<<18
  ACTW2=0              ;! NOT USED
!-----------------------------------------------------------------------
! INITIALISE GPC, DRUM & DISC ROUTINES
  P_DEST=X'300002'
  P_P1=COM_GPCA
  GPC(P)
  P_DEST=X'370000'
  P_P1=EPAGESIZE
  P_P2=COMMSALLOC
  P_P3=ADDR(PARM(0))
  COMMS CONTROL(P)
  P_DEST=X'200000'
  P_P1=EPAGE SIZE
  P_P2=COM_FPCCONFA
  P_P3=COM_DDTADDR
  P_P4=COM_NDISCS
  P_P5=ADDR(STORE(0))
  P_P6=COM_DQADDR
  DISC(P)
  %UNLESS DRUMESIZE=0 %THEN %START
    P_DEST=X'280000'
    P_P1=EPAGESIZE
    P_P2=COM_SFCA
    P_P3=ADDR(STORE(0))
    P_P4=ADDR(PARM(0))
    DRUM(P)
  %FINISH
!-----------------------------------------------------------------------
! TURN ON SLAVING WHICH HAS BEEN INHIBITED BY CHOPSUPE
  SLAVESONOFF(-1)
!-----------------------------------------------------------------------
! INITIALISE LEFT-HAND OPER SCREEN
  %CYCLE I=0,24,48
    DISPLAY TEXT(0,0,0,"  EMAS 2900  SUP".SUPID)
  %REPEAT
  DISPLAY TEXT(0,0,22,STRING(ADDR(COM_DATE0)+3))
  %CYCLE I=1,1,MAXPROCS
    STRPROC=STRINT(I)
    UPDISP(I,3-LENGTH(STRPROC),STRPROC)
  %REPEAT
  P_DEST=X'30000'
  SCHEDULE(P)
  P_DEST=X'80000'
  ACTIVE MEM(P)
!-----------------------------------------------------------------------
! START "DIRECT" PROCESS
  P_DEST=X'30001'
  P_SRCE=0    ;! NO REPLY WANTED
  STRING(ADDR(P_P1))="DIRECT"
  P_P3=COM_SUPLVN<<24!X'400'    ;! LSTACKDA
  P_P4=0    ;! USE DEFAULT DIRVSN
  P_P5=P_P3+LSTACKLEN    ;! DSTACKDA
  P_P6=P_P5+SEGEPSIZE    ;! DGLADA
  PON(P)
!-----------------------------------------------------------------------
! CLEAR TIMING ARRAY ETC.
  CLEAR TIME
  P_DEST=X'A0001'
  P_SRCE=0
  P_P1=X'B0000'
  P_P2=2
  PON(P)    ;! KICK UPDATE TIME
  P_P1=X'3000F'
  PON(P)    ;! UPDATE SCHEDULER INFO ON OPER
  P_P1=X'80004'
  PON(P)    ;! ACTIVE MEM
  P_P1=X'320009'
  PON(P)    ;! DISPLAY OPER
  P_P1=X'360000'
  PON(P)    ;! KICK PRINTER
  P_P1=X'D0001'; P_P2=10
  PON(P);                               ! KICK ERROR REORTING
!-----------------------------------------------------------------------
! SERVICE LOOPS
  IT=MAXIT+1
  IC=MAXIT+8
  KSERVICE=0
KSERVE:! KERNEL SERVICES
  *LSS_X'7FFFFF'    ;! SET IT & IC TO MAX.
  *ST_(5)
  *ST_(6)
  SERVIT(KSERVICE)=SERVIT(KSERVICE)+MAXIT-IT
  SERVIC(KSERVICE)=SERVIC(KSERVICE)+MAXIT-IC
  *LSS_X'01800820'    ;! LET INTERRUPTS IN
  *ST_(3)
  *LSS_X'01800FFE'
  *ST_(3)
  %IF KERNELQ=0 %THEN %START
    %IF CURPROC1=0 %THEN %START
      %IF RUNQ1#0 %THEN CURPROC==CURPROC1 %AND RUNQ==RUNQ1 %AND ->LSERVE
      %IF CURPROC2=0 %THEN %START
        %IF RUNQ2#0 %THEN CURPROC==CURPROC2%AND RUNQ==RUNQ2%AND ->LSERVE
        IDLEN=IDLEN+1
        IDLE=1
        *LSS_X'01800820'    ;! ALL EXCEPT TIMER INTERRUPTS
        *ST_(3)
IDLE0:  *IDLE_0
        ->IDLE0    ;! IN CASE "EKS" SET
      %FINISH %ELSE CURPROC==CURPROC2 %AND RUNQ==RUNQ2
    %FINISH %ELSE CURPROC==CURPROC1 %AND RUNQ==RUNQ1
    LPN=LPN+1
    ACTW1=PROCA(CURPROC)_LSTAD
    ACTW3=PROCA(CURPROC)_STACK
    *ACT_ACTW0    ;! REACTIVATE INTERRUPTED PROCESS
  %FINISH
  KSERVQ==SERVA(KERNELQ)
  KSERVICE=KSERVQ_L
  KSERV==SERVA(KSERVICE)
  %IF KSERV_P>0 %THEN %START
    %IF KSERVICE>LOCSN1 %THEN %START    ;! SUSPEND REPLY
      %IF KSERVICE<=LOCSN2 %THEN I=KSERVICE-LOCSN1 %ELSE %START
        %IF KSERVICE<=LOCSN3 %THEN I=KSERVICE-LOCSN2 %C
          %ELSE I=KSERVICE-LOCSN3
      %FINISH
      INHIBIT(I+LOCSN1)
      INHIBIT(I+LOCSN2)
      INHIBIT(I+LOCSN3)
      P_DEST=X'30007'    ;! RESCHEDULE LOCAL CONTROLLER
      P_SRCE=0
      P_P1=I
      SCHEDULE(P)
      ->KTIMER
    %FINISH
    SUPPOFF(KSERV,P)
    ->SERVROUT(KSERVICE)
  %FINISH %ELSE %START
    %IF KSERVICE=KERNELQ %THEN KERNELQ=0 %ELSE %START
      KSERVQ==SERVA(KERNELQ)
      KSERVQ_L=KSERV_L
    %FINISH
    KSERV_L=0
  %FINISH
  %IF KSERVICE>LOCSN1 %THEN KSERVICE=3    ;! SCHEDULER
  ->KTIMET
!-----------------------------------------------------------------------
! SERVICE ROUTINE CALLS
SERVROUT(1):I=P_DEST&X'FFFF'
  UNALLOCEPS=UNALLOCEPS-OVERALLOC+I
  OVERALLOC=I
  ->KTIMER
SERVROUT(2):TIMESLICE=P_DEST&X'FFFF'<<12 ; ->KTIMER
SERVROUT(3):SCHEDULE(P) ; ->KTIMER
SERVROUT(4):PAGETURN(P) ; ->KTIMER
SERVROUT(5):GET EPAGE(P) ; ->KTIMER
SERVROUT(6):RETURN EPAGE(P) ; ->KTIMER
SERVROUT(7):SEMAPHORE(P) ; ->KTIMER
SERVROUT(8):ACTIVE MEM(P) ; ->KTIMER
SERVROUT(9):TIMEOUT(P) ; ->KTIMER
SERVROUT(10):ELAPSEDINT(P) ; ->KTIMER
SERVROUT(11):UPDATE TIME ; ->KTIMER
SERVROUT(12):DPONPUTONQ(P) ; ->KTIMER
SERVROUT(13):TURNONER(P) ; ->KTIMER
SERVROUT(14):SERVROUT(15):SERVROUT(16):
SERVROUT(17):SERVROUT(18):SERVROUT(19):SERVROUT(20):SERVROUT(21):
SERVROUT(22):SERVROUT(23):SERVROUT(24):SERVROUT(25):SERVROUT(26):
SERVROUT(27):SERVROUT(28):SERVROUT(29):SERVROUT(30):SERVROUT(31):
  ->INVALID
SERVROUT(32):DISC(P) ; ->KTIMER
SERVROUT(33):PDISC(P) ; ->KTIMER
SERVROUT(34):SERVROUT(35):->INVALID
SERVROUT(36):SERVROUT(37):MOVE(P) ; ->KTIMER
SERVROUT(38):SERVROUT(39):->INVALID
SERVROUT(40):SERVROUT(41):DRUM(P) ; ->KTIMER
SERVROUT(42):SERVROUT(43):SERVROUT(44):SERVROUT(45):SERVROUT(46):
SERVROUT(47):->INVALID
SERVROUT(48):GPC(P) ; ->KTIMER
SERVROUT(49):TAPE(P) ; ->KTIMER
SERVROUT(50):OPER(P) ; ->KTIMER
SERVROUT(51):LP ADAPTOR(P) ; ->KTIMER
SERVROUT(52):CR ADAPTOR(P) ; ->KTIMER
SERVROUT(53):CP ADAPTOR(P) ; ->KTIMER
SERVROUT(54):PRINTER(P) ; ->KTIMER
SERVROUT(55):SERVROUT(56):COMMS CONTROL(P) ; ->KTIMER
SERVROUT(57):MK1FEADAPTOR(P) ; ->KTIMER
SERVROUT(58):SERVROUT(59):SERVROUT(60):SERVROUT(61):->INVALID
SERVROUT(62):COMREP(P) ; ->KTIMER
SERVROUT(63):SERVROUT(64):->INVALID
!-----------------------------------------------------------------------
KTIMER:%IF KSERV_P<=0 %THEN %START
    %IF KSERVICE=KERNELQ %THEN KERNELQ=0 %ELSE %START
      KSERVQ==SERVA(KERNELQ)
      KSERVQ_L=KSERV_L
    %FINISH
    KSERV_L=0
  %FINISH
  ! RECORD TIMING INFO
  %IF KSERVICE>LOCSN1 %THEN KSERVICE=3    ;! SCHEDULER
KTIMES:SERVN(KSERVICE)=SERVN(KSERVICE)+1
KTIMET:*LSS_(6) ; *ST_IC
  *LSS_(5) ; *ST_IT
  ->KSERVE
!-----------------------------------------------------------------------
INVALID:PRINT STRING("INVALID POFF:")
  PTREC(P)
  KSERVICE=48    ;! GPC
  ->KTIMET
!-----------------------------------------------------------------------
LSERVE:! LOCAL CONTROLLER SERVICES
  LSERVQ==SERVA(RUNQ)
  LSERVICE=LSERVQ_L
  LSERV==SERVA(LSERVICE)
  %IF LSERV_P>0 %THEN %START
    SUPPOFF(LSERV,P)
    %IF LSERV_P=0 %THEN %START
      %IF LSERVICE=RUNQ %THEN RUNQ=0 %ELSE %START
        LSERVQ==SERVA(RUNQ)
        LSERVQ_L=LSERV_L
      %FINISH
      LSERV_L=0
    %FINISH %ELSE RUNQ=LSERVICE
    CURPROC=LSERVICE-LOCSN0
    ACTW1=PROCA(CURPROC)_LSTAD
    ACTW3=0    ;! SSN=0
    LCN=LCN+1
    *LSS_(6)
    *ST_IC
    LCIC=LCIC+MAXIT-IC
    *LSS_(5)
    *ST_IT
    LCIT=LCIT+MAXIT-IT
    *ACT_ACTW0    ;! ACTIVATE TO LOCAL CONTROLLER
!-----------------------------------------------------------------------
LCCALL:*JLK_%TOS ; LOCAL CONTROL    ;! INITIAL CALL
!-----------------------------------------------------------------------
LCRETURN:*JLK_%TOS
    ! LOCAL CONTROL RETURNS TO HERE
    CURPROC=0
  %FINISH %ELSE %START
    %IF LSERVICE=RUNQ %THEN RUNQ=0 %ELSE %START
      LSERVQ==SERVA(RUNQ)
      LSERVQ_L=LSERV_L
    %FINISH
    LSERV_L=0
  %FINISH
  KSERVICE=LOCSN0+1
  ->KTIMET
!-----------------------------------------------------------------------
! INTERRUPT ENTRY POINTS
! SYSTEM ERROR
IST1I:*JLK_%TOS    ;! ENTRY POINT IS LINK PC I.E. NEXT INSTR
  *LSS_%TOS ; *ST_SESTK ; *LSS_%TOS ; *ST_SEIP
  *LSS_(%LNB+7) ; *ST_SELN    ;! OLD LINE NUMBER
  SYSERR(SESTK,SEIP)
! DOES NOT RETURN
!-----------------------------------------------------------------------
! EXTERNAL
IST2I:*JLK_%TOS
! EXTERNAL INTERRUPTS (CLOCK) ENTER HERE
  *LSS_%TOS ; *ST_I
  *LSS_%TOS ; *ST_J
  %IF IDLE#0 %THEN IDLEIT=IDLEIT+MAXIT-KIT %AND IDLE=0
  P_P1=I
  P_P2=J
  I=X'44000100'!COM_SACPORT<<20    ;! CLEAR 2980 SAC EXT. REG.
  *LB_I
  *LSS_(0+%B)
  *ST_J
  P_P3=J
  P_DEST=X'A0000'
  ELAPSEDINT(P)
  KSERVICE=10
  ->KTIMES
!-----------------------------------------------------------------------
! MULTIPROCESSOR
IST3I:*JLK_%TOS
  *IDLE_X'F3'
!-----------------------------------------------------------------------
! PERIPHERAL
IST4I:*JLK_%TOS
! PERIPHERAL INTERRUPTS ENTER HERE
  *LSS_%TOS    ;! OLD STACK
  *LSS_%TOS    ;! PARAMETER = SAC NUMBER<<20
  *ST_I
  %IF IDLE#0 %THEN IDLEIT=IDLEIT+MAXIT-KIT %AND IDLE=0
  PORT=I>>20&3
  I=X'44000000'!PORT<<20    ;! IMAGE STORE ADDR FOR TRUNK FLAGS
  *LB_I
  *LSS_(0+%B)
  *ST_I
  K=0
  %CYCLE
    *LSS_I
    *SHZ_J
    *USH_1
    *ST_I
    P_SRCE=0
    J=J+K
    P_P1=PORT<<4!J
    ->CONROUT(CONTYPE(J))
    CONROUT(1):P_DEST=X'280003'
    DRUM(P)
    KSERVICE=42
    ->CONTINUE
    CONROUT(2):P_DEST=X'200003'
    DISC(P)
    KSERVICE=34
    ->CONTINUE
    CONROUT(3):P_DEST=X'300003'
    GPC(P)
    KSERVICE=58
CONTINUE:%IF I=0 %THEN ->KTIMES
    *LSS_(6)
    *ST_IC
    *LSS_(5)
    *ST_IT
    *LSS_X'7FFFFF'
    *ST_(5)
    *ST_(6)
    SERVN(KSERVICE)=SERVN(KSERVICE)+1
    SERVIT(KSERVICE)=SERVIT(KSERVICE)+MAXIT-IT
    SERVIC(KSERVICE)=SERVIC(KSERVICE)+MAXIT-IC
    K=J+1
  %REPEAT
!-----------------------------------------------------------------------
! VIRTUAL STORE INTERRUPT (BEFORE PROCESS CREATED)
IST5I:*JLK_%TOS ; *IDLE_X'F5'
!-----------------------------------------------------------------------
! INTERVAL TIMER INTERRUPT (BEFORE PROCESS CREATED)
IST6I:*JLK_%TOS ; *IDLE_X'F6'
!-----------------------------------------------------------------------
! PROGRAM ERROR INTERRUPT (BEFORE PROCESS CREATED)
IST7I:*JLK_%TOS ; *IDLE_X'F7'
!-----------------------------------------------------------------------
! SYSTEM CALL (BEFORE PROCESS CREATED)
IST8I:*JLK_%TOS ; *IDLE_X'F8'
!-----------------------------------------------------------------------
! OUT INTERRUPT (BEFORE PROCESS CREATED)
IST9I:*JLK_%TOS ; *IDLE_X'F9'
!-----------------------------------------------------------------------
! EXTRACODE
IST10I:*JLK_%TOS ; *IDLE_X'FA'
!-----------------------------------------------------------------------
! EVENT PENDING (BEFORE PROCESS CREATE)
IST11I:*JLK_%TOS ; *IDLE_X'FB'
!-----------------------------------------------------------------------
! INSTRUCTION COUNTER (BEFORE PROCESS CREATE)
IST12I:*JLK_%TOS ; *IDLE_X'FC'
!-----------------------------------------------------------------------
%ROUTINE SCHEDULE(%RECORDNAME P)
! ACTIVITY 0 : MAXEPAGES TOO BIG
! ACTIVITY 1 : CREATE PROCESS
! ACTIVITY 2 : REPLY FROM CREATE PROCESS
! ACTIVITY 3 : RUN OUT OF EPAGE ALLOCATION FROM LOCAL CONTROLLER
! ACTIVITY 4 : RUN OUT OF TIME SLICES FROM LOCAL CONTROLLER
! ACTIVITY 5 : SUSPEND PROCESS
! ACTIVITY 7 : UNSUSPEND PROCESS
! ACTIVITY 8 : DESTROY PROCESS
! ACTIVITY 9 : REPLY FROM PAGE-IN OF LOCAL CONTROLLER STACK
! ACTIVITY 10: MORE EPAGES ON THE FLY ?
! ACTIVITY 11: MORE TIME ON THE FLY ?
! ACTIVITY 12: LOADEPS AVAILABLE
! ACTIVITY 13: DO NOT WANT REST OF ALLOCATION
%RECORDSPEC P(PARMF)
!-----------------------------------------------------------------------
! CATEGORY TABLES (CATEGORY 0 FOR START-UP)
%CONSTBYTEINTEGERARRAY PRIORITY(0:13)=1,1,1,1,2,1,2,3,3,3,4,3,4,4
%OWNBYTEINTEGERARRAY EPLIM(0:13)=0,48,32(3),48(3),72(3),96(3)
%CONSTBYTEINTEGERARRAY RTLIM(0:13)=0,4,4,12,36,4,12,36,4,12,36,4,12,36
%CONSTBYTEINTEGERARRAY MOREEP(1:13)=8,5,6,7,8,9,10,11,12,13,11,12,13
%CONSTBYTEINTEGERARRAY MORET(1:13)=6,3,4,4,6,7,7,9,10,10,12,13,13
%CONSTBYTEINTEGERARRAY LESSEP(1:13)=2,0,0,0,2,3,4,5,6,7,8,9,10
%CONSTBYTEINTEGERARRAY LESST(1:13)=5,0,2,3,0,5,6,0,8,9,0,11,12
%CONSTBYTEINTEGERARRAY PRAT(0:15)=1,1,2,1,3,1,2,1,4,1,1,2,1,3,1,2
%OWNINTEGER PRATP=0
!-----------------------------------------------------------------------
! PRIORITY QUEUE ARRAY ETC.
%OWNBYTEINTEGERARRAY PQ(1:128)=0(128)    ;! (1:MAXPROCS)
%OWNBYTEINTEGERARRAY PQH(1:4)=0(4)     ;! NUMBER OF PRIORITIES=4
%OWNINTEGER NPQ=0,PPLOADPROC=0,PPLOAD=0,P4L=0,NPL4=0,SUSPN=0
%OWNBYTEINTEGERARRAY PQN(1:4)=0(4)
!-----------------------------------------------------------------------
%CONSTSTRING(2)%ARRAY STRPN(1:4)="P1","P2","P3","P4"
%CONSTSTRING(16)%ARRAY STARTMESS(0:2)=" PROCESS CREATED",
  " : SYSTEM FULL"," : NO AMT"
%LONGINTEGERARRAYNAME LST
%INTEGER SRCE,ACT,PROCESS,PTY,OLDCAT,LSTAD,LSTACKDA,DCODEDA,DSTACKDA, %C
  DGLADA,XEPS,NEWCAT,INCAR,PPCELL,I,J,K,L
%LONGINTEGER LIM
%STRING(15) USER
%STRING(2) RTL
%RECORDNAME PROC(PROCF)
%RECORDNAME PARMA(PARMAF)
%SWITCH ACTIVITY(0:15)
  %IF KMON&1<<3#0 %THEN PRINT STRING("SCHEDULE:") %AND PTREC(P)
  ACT=P_DEST&X'FFFF'
  PROCESS=P_P1
  PROC==PROCA(PROCESS) %IF 0<PROCESS<=MAXPROCS
  ->ACTIVITY(ACT)
!-----------------------------------------------------------------------
ACTIVITY(0):! INITIALISE
  I=UNALLOCEPS//2-LSTACKLEN
  %IF MAXEPAGES>I %THEN %START
    MAXEPAGES=I
    %CYCLE I=1,1,13
      %IF EPLIM(I)>MAXEPAGES %THEN EPLIM(I)=MAXEPAGES
    %REPEAT
  %FINISH
  MAXP4=UNALLOCEPS//(2*MAXEPAGES)
  LOADEPS=9999
  COM_USERS=0
  MPLEVEL=0
  PAGEFREES=0
  %CYCLE I=1,1,MAXPROCS
    PROCA(I)=0
    INHIBIT(I+LOCSN0)
    INHIBIT(I+LOCSN1)
    INHIBIT(I+LOCSN2)
    INHIBIT(I+LOCSN3)
  %REPEAT
  DISPLAY TEXT(0,50,0,"RUNQ1    : 0")
  DISPLAY TEXT(0,51,0,"RUNQ2    : 0")
  %CYCLE I=1,1,4
    DISPLAY TEXT(0,51+I,0,"PQ".STRINT(I)."      : 0")
  %REPEAT
  DISPLAY TEXT(0,56,0,"SUSPENDED: 0")
  DISPLAY TEXT(0,57,0,"EP/RT CATEGORIES")
  %CYCLE I=1,1,13
    RTL=STRINT(RTLIM(I))
    DISPLAY TEXT(0,57+I,0,STRINT(EPLIM(I))."/".RTL. %C
      STRSP(6-LENGTH(RTL)).": 0")
  %REPEAT
  %RETURN
!-----------------------------------------------------------------------
ACTIVITY(1):! CREATE PROCESS
! P_P1/P2 : STRING(USER NAME)
! P_P3 : LOCAL CONTROLLER STACK DISC ADDRESS
! P_P4 : DIRECTOR CODE DISC ADDRESS (<=0 FOR DEFAULT)
! P_P5 : DIRECTOR STACK DISC ADDRESS
! P_P6 : DIRECTOR GLA DISC ADDRESS
  SRCE=P_SRCE
  USER=STRING(ADDR(P_P1))
  INCAR=BYTE INTEGER(ADDR(P_P2)+3)
  %IF COM_USERS=MAXPROCS %THEN P_P1=1 %AND ->STARTREP    ;! SYSTEM FULL
  %CYCLE PROCESS=1,1,MAXPROCS
    PROC==PROCA(PROCESS)
    %IF PROC_USER="" %THEN %EXIT
  %REPEAT
  LSTACKDA=P_P3
  %IF P_P4<=0 %THEN DCODEDA=COM_DCODEDA %ELSE DCODEDA=P_P4
  DSTACKDA=P_P5
  DGLADA=P_P6
  P_DEST=X'80001'    ;! GET AMTX FOR LOCAL CONTROLLER STACK
  P_SRCE=0
  P_P1=0
  P_P2=LSTACKDA
  P_P3=X'FFFF0000'!(LSTACKLEN-1)    ;! "NEW" EPAGES
  ACTIVE MEM(P)
  %IF P_P2<=0 %THEN P_P1=2 %AND ->STARTREP    ;! NO AMT
  PROC_LAMTX=P_P2
  COM_USERS=COM_USERS+1
  PROC_USER=USER
  UPDISP(PROCESS,4,USER)
  PROC_INCAR=INCAR
  PROC_ACTIVE=AMTON+2
  CLEAR PARMS(PROCESS+LOCSN0)
  CLEAR PARMS(PROCESS+LOCSN1)
  CLEAR PARMS(PROCESS+LOCSN2)
  CLEAR PARMS(PROCESS+LOCSN3)
  ! PON TO INITIALIZE LOCAL CONTROLLER
  P_DEST=(PROCESS+LOCSN0)<<16
  P_SRCE=X'30002'
  P_P1=PROCESS
  P_P2=DCODEDA
  P_P3=DGLADA
  P_P4=DSTACKDA
  PON(P)    ;! INHIBITED AS YET THOUGH
  ! REPLY TO START-UP
  P_P1=0    ;! PROCESS CREATED SUCCESSFULLY
  P_P2=(PROCESS+LOCSN1)<<16
  P_P3=(PROCESS+LOCSN2)<<16
  P_P4=(PROCESS+LOCSN3)<<16!1    ;! ASYNCH SNO FOR INPUT CONTROL MESS
  P_P5=PROCESS
STARTREP:%IF SRCE<=0 %THEN OPMESS(USER.STARTMESS(P_P1)) %C
    %ELSE P_DEST=SRCE %AND P_SRCE=X'30001' %AND PON(P)
  %IF P_P1=0 %THEN ->ONPQ
  %RETURN
!-----------------------------------------------------------------------
ACTIVITY(2):! REPLY FROM CREATE PROCESS
  PROC_CATEGORY=1    ;! INITIAL CATEGORY
  %IF PPLOADPROC#0 %THEN UNALLOCEPS=UNALLOCEPS+LSTACKLEN %AND ->STOUT
  PPLOADPROC=PROCESS
  PPLOAD=0
  LOADEPS=0
  PROC_RUNQ=0
  ->CPL    ;! TREAT AS PARTIAL LOAD
!-----------------------------------------------------------------------
ACTIVITY(3):! OUT OF EPAGES
  OLDCAT=PROC_CATEGORY
  NEWCAT=MOREEP(OLDCAT)
  %WHILE P_P2<RTLIM(LESST(NEWCAT)) %THEN NEWCAT=LESST(NEWCAT)
  PROC_CATEGORY=NEWCAT
  ->OLDC
!-----------------------------------------------------------------------
ACTIVITY(10):! MORE EPAGES ON THE FLY ?
  %UNLESS PPLOADPROC=NPQ=0 %THEN P_P1=0 %AND %RETURN    ;! NO
  OLDCAT=PROC_CATEGORY
  NEWCAT=MOREEP(OLDCAT)
  %WHILE P_P2<RTLIM(LESST(NEWCAT)) %THEN NEWCAT=LESST(NEWCAT)
  XEPS=EPLIM(NEWCAT)-EPLIM(OLDCAT)
  %UNLESS XEPS>0 %AND UNALLOCEPS>=XEPS %THEN P_P1=0 %AND %RETURN
CONT:UNALLOCEPS=UNALLOCEPS-XEPS
  PROC_CATEGORY=NEWCAT
  P_P1=EPLIM(NEWCAT)
  P_P2=RTLIM(NEWCAT)
  %IF PRIORITY(OLDCAT)=4 %THEN P4L=P4L-1
  %IF PRIORITY(NEWCAT)=4 %THEN P4L=P4L+1
  %RETURN
!-----------------------------------------------------------------------
ACTIVITY(4):! OUT OF TIME
  OLDCAT=PROC_CATEGORY
  NEWCAT=MORET(OLDCAT)
  %WHILE P_P2<EPLIM(LESSEP(NEWCAT)) %THEN NEWCAT=LESSEP(NEWCAT)
  PROC_CATEGORY=NEWCAT
  ->OLDC
!-----------------------------------------------------------------------
ACTIVITY(11):! MORE TIME (AND AT LEAST PRESENT NO OF EPAGES) ON THE FLY?
  %UNLESS PPLOADPROC=NPQ=0 %THEN P_P1=0 %AND %RETURN
  OLDCAT=PROC_CATEGORY
  NEWCAT=MORET(OLDCAT)
  %WHILE P_P2<EPLIM(LESSEP(NEWCAT)) %THEN NEWCAT=LESSEP(NEWCAT)
  XEPS=EPLIM(NEWCAT)-EPLIM(OLDCAT)
  %UNLESS UNALLOCEPS>=XEPS %THEN P_P1=0 %AND %RETURN
  ->CONT
!-----------------------------------------------------------------------
ACTIVITY(5):! SUSPEND
  SUSPN=SUSPN+1
  UNINHIBIT(P_SRCE)    ;! SERVICE AWAITED
  UNINHIBIT(PROCESS+LOCSN3) %UNLESS P_SRCE>LOCSN3
  UPDISP(PROCESS,11,"S ")
  PROC_ACTIVE=0
  OLDCAT=PROC_CATEGORY
  NEWCAT=OLDCAT
  %WHILE P_P2<EPLIM(LESSEP(NEWCAT)) %THEN NEWCAT=LESSEP(NEWCAT)
  %WHILE P_P3<RTLIM(LESST(NEWCAT)) %THEN NEWCAT=LESST(NEWCAT)
  PROC_CATEGORY=NEWCAT
  %IF PROCESS<=3 %AND PRIORITY(PROC_CATEGORY)<4 %THEN NPL4=NPL4+1
  ->OLDC
!-----------------------------------------------------------------------
ACTIVITY(7):! UNSUSPEND
  SUSPN=SUSPN-1
  PROC_ACTIVE=AMTON+2
  %IF PROCESS<=3 %AND PRIORITY(PROC_CATEGORY)<4 %THEN NPL4=NPL4-1
  ->ONPQ
!-----------------------------------------------------------------------
ACTIVITY(8):! DESTROY PROCESS
  OLDCAT=PROC_CATEGORY
  UPDISP(PROCESS,4,"         ")
  COM_USERS=COM_USERS-1
  INHIBIT(PROCESS+LOCSN0)
  INHIBIT(PROCESS+LOCSN1)
  INHIBIT(PROCESS+LOCSN2)
  INHIBIT(PROCESS+LOCSN3)
  MPLEVEL=MPLEVEL-1
  UNALLOCEPS=UNALLOCEPS+EPLIM(OLDCAT)+LSTACKLEN
  %IF PRIORITY(OLDCAT)=4 %THEN P4L=P4L-1
  %CYCLE I=0,1,LSTACKLEN-1
    P_DEST=X'40002'    ;! PAGE-TURN OUT
    P_P1=PROC_LAMTX<<16!I
    P_P2=0    ;! REGARD AS NOT WRITTEN TO
    PAGETURN(P)
  %REPEAT
  P_DEST=X'80002'    ;! RETURN AMTX FOR LOCAL CONTROLLER STACK
  P_SRCE=0
  P_P1=0    ;! ID NOT USED
  P_P2=PROC_LAMTX
  ACTIVE MEM(P)
  PROC=0
  ->CPL
!-----------------------------------------------------------------------
OLDC:! UPDATE UNALLOCEPS FOR REMOVAL OF PROCESS FROM STORE
  MPLEVEL=MPLEVEL-1
FAIL1:UNALLOCEPS=UNALLOCEPS+EPLIM(OLDCAT)+LSTACKLEN
FAIL2:%IF PRIORITY(OLDCAT)=4 %THEN P4L=P4L-1
  ! PAGE OUT LOCAL CONTROLLER STACK
STOUT:PROC_RUNQ=0
    %CYCLE I=0,1,LSTACKLEN-1
    P_DEST=X'40002'    ;! PAGETURN/PAGE-OUT
    P_P1=PROC_LAMTX<<16!I
    %IF I>=LSTACKLENP %THEN P_P2=2 %ELSE P_P2=X'C'
    ! MAKE "NEW" IF NON-PAGED PART
    PAGETURN(P)    ;! NO REPLIES
  %REPEAT
  %UNLESS ACT=5 %THEN %START   ;! SUSPEND
ONPQ:! PUT ON PRIORITY QUEUE
    PTY=PRIORITY(PROC_CATEGORY)
    %IF PQH(PTY)=0 %THEN PQ(PROCESS)=PROCESS %ELSE %C
       PQ(PROCESS)=PQ(PQH(PTY)) %AND PQ(PQH(PTY))=PROCESS
    PQH(PTY)=PROCESS
    NPQ=NPQ+1    ;! COUNT PROCESSES QUEUED
    PQN(PTY)=PQN(PTY)+1
    UPDISP(PROCESS,11,STRPN(PTY))
  %FINISH
!-----------------------------------------------------------------------
ACTIVITY(12):! LOADEPS AVAILABLE
! COMPLETE PARTIAL LOAD
CPL:%IF PPLOADPROC#0 %THEN %START
    PROCESS=PPLOADPROC
    PROC==PROCA(PROCESS)
    %IF PPLOAD=0 %THEN %START
      I=EPLIM(PROC_CATEGORY)
      %IF I<=UNALLOCEPS %THEN %START    ;! FULL ALLOCATION
        UNALLOCEPS=UNALLOCEPS-I
        PPLOADPROC=0
        %IF PQ(PROCESS)=0 %THEN %START
          P_DEST=(PROCESS+LOCSN0)<<16!1
          P_SRCE=X'30000'
          P_P1=EPLIM(PROC_CATEGORY)
          P_P2=RTLIM(PROC_CATEGORY)
          P_P3=0
          PON(P)
        %FINISH
      %FINISH %ELSE %START
        J=LOADEPS    ;! PROC_WSN
        %IF J<=UNALLOCEPS %THEN %START    ;! PARTIAL ALLOCATION
          UNALLOCEPS=UNALLOCEPS-J
          PPLOAD=1
          LOADEPS=I-J
          %IF PQ(PROCESS)=0 %THEN %START
            P_DEST=(PROCESS+LOCSN0)<<16!1
            P_SRCE=X'30000'
            P_P1=EPLIM(PROC_CATEGORY)
            P_P2=RTLIM(PROC_CATEGORY)
            P_P3=1
            PON(P)
          %FINISH
        %FINISH %ELSE LOADEPS=J
        %RETURN
      %FINISH
    %FINISH %ELSE %START
      I=EPLIM(PROC_CATEGORY)-PROC_WSN    ;! =LOADEPS !
      %IF I<=UNALLOCEPS %THEN %START    ;! REST OF ALLOCATION
        UNALLOCEPS=UNALLOCEPS-I
        PPLOADPROC=0
        %IF PQ(PROCESS)=0 %THEN %START
          P_DEST=(PROCESS+LOCSN0)<<16!7
          P_SRCE=X'30000'
          PON(P)
        %FINISH
      %FINISH %ELSE LOADEPS=I %AND %RETURN
    %FINISH
  %FINISH
!-----------------------------------------------------------------------
  %CYCLE    ;! LOAD AS MANY AS POSSIBLE
    %IF NPQ=0 %THEN LOADEPS=9999 %AND %RETURN
    %IF UNALLOCEPS<LSTACKLEN %THEN LOADEPS=LSTACKLEN %AND %RETURN
NPTY:PTY=PRAT(PRATP)
    PRATP=(PRATP+1)&15
    %IF PQH(PTY)=0 %THEN ->NPTY
    ! LOAD ONLY MAXP4 PRIORITY 4 PROCESS UNLESS NOTHING ELSE
    %IF PTY=4 %THEN %START
      %IF P4L>=MAXP4 %THEN %START
        %IF PQN(4)#NPQ %THEN ->NPTY
        %IF NPL4>0 %THEN LOADEPS=9999 %AND %RETURN
      %FINISH
      P4L=P4L+1
    %FINISH
    PROCESS=PQ(PQH(PTY))
    PROC==PROCA(PROCESS)
    UNALLOCEPS=UNALLOCEPS-LSTACKLEN
    %IF PROCESS=PQH(PTY) %THEN PQH(PTY)=0 %C
      %ELSE PQ(PQH(PTY))=PQ(PROCESS)
    NPQ=NPQ-1
    PQN(PTY)=PQN(PTY)-1
    ! PAGE IN LOCAL CONTROLLER STACK
    P_DEST=X'40001'    ;! PAGETURN/PAGE-IN
    P_SRCE=X'30009'
    P_P1=PROC_LAMTX<<16
    PPCELL=NEWPPCELL
    P_P2=PPCELL<<16!PROCESS<<8
    PARM(PPCELL)_P6=0    ;! READ FAIL FLAG
    P_P3=0    ;! WRITE/HIGH PRIORITY
    %CYCLE I=0,1,LSTACKLEN-1
      PON(P)
      P_P1=P_P1+1
      P_P2=P_P2+1
    %REPEAT
    PQ(PROCESS)=LSTACKLEN    ;! TO COUNT PAGE-TURN REPLIES
    I=EPLIM(PROC_CATEGORY)
    %IF I<=UNALLOCEPS %THEN %START    ;! FULL ALLOCATION
      UNALLOCEPS=UNALLOCEPS-I
    %FINISH %ELSE %START
      PPLOADPROC=PROCESS    ;! #0 WHEN PARTIAL LOAD IN PROGRESS
      UPDISP(PROCESS,11,"PL")
      J=PROC_WSN
      %IF J<=UNALLOCEPS %THEN %START    ;! PARTIAL ALLOCATION
        UNALLOCEPS=UNALLOCEPS-J
        PPLOAD=1
        LOADEPS=I-J
      %FINISH %ELSE PPLOAD=0 %AND LOADEPS=J    ;! NO ALLOCATION
      %RETURN
    %FINISH
  %REPEAT
!-----------------------------------------------------------------------
ACTIVITY(13):! DO NOT WANT REST OF ALLOCATION
  %IF PPLOADPROC#P_P1 %THEN P_DEST=0 %ELSE %START
    UNALLOCEPS=UNALLOCEPS-LOADEPS
    PPLOADPROC=0
    LOADEPS=9999
  %FINISH
  %RETURN
!-----------------------------------------------------------------------
ACTIVITY(14):! DEADLOCK RECOVERY
  OLDCAT=PROC_CATEGORY
  %IF PPLOADPROC#0 %THEN ->OLDC    ;! THROW OUT
  PPLOADPROC=PROCESS    ;! GO BACK TO PARTIAL ALLOCATION STATE
  PPLOAD=0    ;! NO ALLOCATION
  LOADEPS=PROC_WSN
  MPLEVEL=MPLEVEL-1
  UNALLOCEPS=UNALLOCEPS+EPLIM(OLDCAT)
  PROC_CATEGORY=MOREEP(OLDCAT)    ;! BIGGER STORE CAT TO DELAY
  PROC_RUNQ=0
  ->CPL
!-----------------------------------------------------------------------
ACTIVITY(9):! REPLY FROM PAGE-IN LOCAL CONTROLLER STACK
  PPCELL=P_P1>>16
  PARMA==RECORD(ADDR(PARM(PPCELL)))
  I=P_P1&X'FF'    ;! EPAGE NO
  PARMA_P(I)=P_P2    ;! SAVE REAL ADDRESS
  %IF P_P3#0 %THEN PARMA_P(7)=1    ;! FAIL FLAG
  PROCESS=P_P1>>8&X'FF'
  PQ(PROCESS)=PQ(PROCESS)-1
  %RETURN %UNLESS PQ(PROCESS)=0    ;! WAIT UNTIL ALL PAGES HERE
  PROC==PROCA(PROCESS)
  %IF PARMA_P(7)#0 %THEN %START
    ! READ FAIL - TRY TO PAGE IT OUT AND TRY AGAIN
    PRINT STRING("LOCAL CONTROLLER STACK READ FAIL, PROCESS ".%C
      STRINT(PROCESS))
    OLDCAT=PROC_CATEGORY
    %IF PPLOADPROC#PROCESS %THEN ->FAIL1
    %IF PPLOAD=0 %THEN I=0 %ELSE I=PROC_WSN
    LOADEPS=9999
    UNALLOCEPS=UNALLOCEPS+I+LSTACKLEN
    ->FAIL2
  %FINISH
  LSTAD=PARMA_P(0)
  PROC_LSTAD=LSTAD
  LST==ARRAY(VIRTAD!LSTAD,LSTF)
  LIM=LSTACKLEN*EPAGESIZE-1
  K=LSTAD+LSTLEN*8+X'50'
  LST(0)=X'4150038080000001'!LIM<<42!K
  ! FILL IN PAGE TABLE ENTRIES
  K=VIRTAD!K
  %CYCLE I=0,1,LSTACKLEN-1
    L=X'80000001'!PARMA_P(I)
    %CYCLE J=0,1,EPAGESIZE-1
      INTEGER(K+J<<2)=L+J<<10
    %REPEAT
    K=K+EPAGESIZE<<2
  %REPEAT
  RETURN PPCELL(PPCELL)
  LST(1)=X'01F0000080000001'!(LSTAD+LSTLEN*8)
  PROC_RUNQ=1
  %IF PROC_CATEGORY=0 %THEN %START    ;! PROCESS BEING CREATED
    ! ALL LST ENTRIES FROM 2 ZERO ALREADY
    I=VIRTAD!LST(1)&X'0FFFFFF8'
    RECORD(I)<-LSSNP1I    ;! COPY LOCAL CONTROLLER CONTEXT IN
    INTEGER(I+LSTKN*X'80'+X'64')=LNBP5    ;! DISPLAY PTR
    UNINHIBIT(PROCESS+LOCSN0)    ;! LET CREATE PON GO
  %FINISH %ELSE %START
    %IF PPLOADPROC=PROCESS %AND PPLOAD=0 %THEN %RETURN
    P_DEST=(PROCESS+LOCSN0)<<16!1
    P_SRCE=X'30000'
    P_P1=EPLIM(PROC_CATEGORY)
    P_P2=RTLIM(PROC_CATEGORY)
    %IF PPLOADPROC=PROCESS %AND PPLOAD#0 %THEN P_P3=1 %ELSE P_P3=0
    PON(P)
  %FINISH
  %RETURN
!-----------------------------------------------------------------------
ACTIVITY(15):! UPDATE OPER INFO
  I=FREEEPAGES//10
  PFREEN(I)=PFREEN(I)+1
%BEGIN
%INTEGERARRAY CAT(0:13),RUNQ(0:2)
  %CYCLE I=0,1,13
    CAT(I)=0
  %REPEAT
  %CYCLE I=0,1,2
    RUNQ(I)=0
  %REPEAT
  %CYCLE I=1,1,MAXPROCS
    PROC==PROCA(I)
    %IF PROC_USER#"" %THEN CAT(PROC_CATEGORY)=CAT(PROC_CATEGORY)+1 %C
      %AND RUNQ(PROC_RUNQ)=RUNQ(PROC_RUNQ)+1
  %REPEAT
  DISPLAY TEXT(0,50,11,STRINT(RUNQ(1))." ")
  DISPLAY TEXT(0,51,11,STRINT(RUNQ(2))." ")
  %CYCLE I=1,1,4
    DISPLAY TEXT(0,51+I,11,STRINT(PQN(I))." ")
  %REPEAT
  DISPLAY TEXT(0,56,11,STRINT(SUSPN)." ")
  %CYCLE I=1,1,13
    DISPLAY TEXT(0,57+I,11,STRINT(CAT(I))." ")
  %REPEAT
%END
  %RETURN
!-----------------------------------------------------------------------
%END
!-----------------------------------------------------------------------
%ROUTINE PAGETURN(%RECORDNAME P)
%RECORDSPEC P(PARMF)
! ALL ACTS   : P_P1=AMTX<<16!EPX
! ACTIVITY 1 : "PAGE IN" REQUEST FROM LOCAL
!            : P_P2=IDENTIFIER
!            : P_P3=PRIORITY : 0 : HIGH, 1 : LOW
! ACTIVITY 2 : "PAGE OUT" REQUEST FROM LOCAL
!            : P_P2=WRITTEN MARKER BIT
!            : P_P3=TYPE
! ACTIVITY 3 : REPLY FROM "EPAGE"
!            : P_P2=STOREX
! ACTIVITY 4 : REPLY FROM DISC/READ
! ACTIVITY 5 : REPLY FROM DISC/WRITE
%ROUTINESPEC PUSHPIT
%INTEGER AEX,AMTX,EPX,DDX,DTX,FLAGS,STOREX,SRCE,CALL,ID,IT,IC,ITT,ICC,%C
  I,J
%RECORDNAME ST(STOREF)
%SWITCH ACTIVITY(1:7)
  %IF KMON&1<<4#0 %THEN PRINT STRING("PAGETURN:") %AND PTREC(P)
  AEX=P_P1
  AMTX=AEX>>16
  EPX=AEX&X'FFFF'
  DDX=AMTP(AMTX)+EPX
  ->ACTIVITY(P_DEST&X'FFFF')
!-----------------------------------------------------------------------
ACTIVITY(1):! PAGE-IN (ALLOWS FOR PAGETURN TO BE "CALLED")
  PTURNN=PTURNN+1
  I=AMTDD(DDX)
  %IF I&DTXBIT=0 %THEN DTX=-1 %AND STOREX=I&STXMASK %ELSE %C
    DTX=I&STXMASK %AND STOREX=DRUMT(DTX)
  AMTUSERS(AMTX)=AMTUSERS(AMTX)+1
  CALL=P_SRCE
  SRCE=CALL&X'7FFFFFFF'
  ID=P_P2
  %IF STOREX#STXMASK %THEN %START    ;! EPAGE ALLOCATED
HERE:ST==STORE(STOREX)
    %IF ST_FLAGS=1 %THEN %START    ;! RECAPTURE
      ST_FLAGS=0
      ST_USERS=0
      ST_LINK=0
      %UNLESS ST_BLINK=0 %THEN STORE(ST_BLINK)_FLINK=ST_FLINK %C
        %ELSE FSTASL=ST_FLINK
      %UNLESS ST_FLINK=0 %THEN STORE(ST_FLINK)_BLINK=ST_BLINK %C
        %ELSE BSTASL=ST_BLINK
      FREEEPAGES=FREEEPAGES-1
      %IF FREEEPAGES=0 %THEN INHIBIT(5)
      RECAPN=RECAPN+1
    %FINISH %ELSE %START
       PSHAREN=PSHAREN+1
      %IF ST_USERS=0 %THEN PAGEFREES=PAGEFREES-1
    %FINISH
    ! STORE FLAGS :
    ! BIT 0 : DISC TRANSFER IN PROGRESS(1)/NOT IN PROGRESS(0)
    ! BIT 1 : DISC INPUT(0)/OUTPUT(1)
    ! BIT 2 : DRUM TRANSFER IN PROGRESS(1)/NOT IN PROGRESS(0)
    ! BIT 3 : DRUM INPUT(0)/OUTPUT(1)
    ! BIT 4 : WRITTEN TO MARKER
    ! BIT 5 : TYPE (0:DISC ONLY, 1:DISC & DRUM)
    ! BITS 6-7 : NOT USED
    ST_USERS=ST_USERS+1
    %IF ST_USERS>1 %THEN %START
      UNALLOCEPS=UNALLOCEPS+1
      %IF UNALLOCEPS>=LOADEPS %THEN P_DEST=X'3000C'%AND SCHEDULE(P)
    %FINISH
    ! EPAGE ASSUMED TO BE EITHER IN STORE OR IN TRANSIT
    ! IF ->STORE TRANSIT, SAVE IN PAGE-IN-TRANSIT TABLE
    %IF ST_FLAGS&X'C0'=X'80' %OR ST_FLAGS&X'30'=X'20' %THEN %C
      PUSHPIT %AND P_DEST=0 %ELSE %START
      ! INTACT COPY IN STORE (EVEN IF STORE-> TRANSIT), SO REPLY NOW
      P_P1=ID    ;! IDENTIFIER
      P_P2=STORE(STOREX)_REALAD
      P_P3=0    ;! SUCCESS
      %IF CALL>0 %THEN P_DEST=SRCE %AND P_SRCE=X'40001' %AND PON(P)
    %FINISH
    %RETURN
  %FINISH
! ALLOCATE EPAGE
  P_DEST=X'50000'!P_P3&X'FFFF'    ;! GET EPAGE!PRIORITY
  P_SRCE=X'80040003'
  ! AEX INTACT IN P1
  ! PRIORITY INTACT IN P3
  P_P5=SRCE
  P_P6=ID
  *LSS_(6)
  *ST_IC
  *LSS_(5)
  *ST_IT
  GET EPAGE(P)
  *LSS_(5)
  *ST_ITT
  *LSS_(6)
  *ST_ICC
  I=IT-ITT
  GETIT=GETIT+I
  PTIT=PTIT-I
  I=IC-ICC
  GETIC=GETIC+I
  PTIC=PTIC-I
  GETCALLN=GETCALLN+1
  %IF P_DEST#0 %THEN ->ACT3 %ELSE %RETURN
!-----------------------------------------------------------------------
ACTIVITY(3):! REPLY FROM GET EPAGE
  I=AMTDD(DDX)
  %IF I&DTXBIT=0 %THEN DTX=-1 %AND STOREX=I&STXMASK %ELSE %C
    DTX=I&STXMASK %AND STOREX=DRUMT(DTX)
  CALL=1    ;! I.E. >0
  SRCE=P_P5
  ID=P_P6
  ! IN CASE 2ND PAGE-IN REQUEST BEFORE GET EPAGE REPLY
  %IF STOREX#STXMASK %THEN %START
    %IF P_P2#0 %THEN RETURN EPAGE(P)
    ->HERE
  %FINISH
  %IF P_P2=0 %THEN P_DEST=SRCE!1 %AND P_P3=-1 %AND PON(P) %AND %C
    AMTUSERS(AMTX)=AMTUSERS(AMTX)-1 %AND %RETURN 
ACT3:STOREX=P_P2
  ST==STORE(STOREX)
  ST_USERS=1
  ST_LINK=0
  %IF AMTDD(DDX)&NEWEPBIT#0 %THEN %START    ;! NEW EPAGE
    J=STORE(STOREX)_REALAD
    CLEAR EPAGE(J)
    AMTDD(DDX)=STOREX    ;! NOT "NEW" & NOT DRUM
    ST_FLAGS=8    ;! "WRITTEN"
    P_P1=ID
    P_P2=J
    P_P3=0    ;! SUCCESS
    %IF CALL>0 %THEN P_DEST=SRCE %AND P_SRCE=X'40001' %AND PON(P)
  %FINISH %ELSE %START
    P_P4=P_P3&X'FFFF'    ;! PRIORITY
    %IF DTX<0 %THEN %START    ;! NOT ON DRUM
      AMTDD(DDX)=STOREX
      %IF DRUMESIZE=0 %OR P_P3>>16=0 %THEN %START
        P_DEST=X'210005'    ;! DIRECT REPLIES TO LC
        P_SRCE=0
      %FINISH %ELSE %START
DRUMRF: P_DEST=X'210006'    ;! PDISC / READ
        P_SRCE=X'80040004'
      %FINISH
      ! P1=AEX
      P_P2=AMTDA(AMTX)+EPX    ;! DISC ADDRESS
      P_P3=STOREX
      *LSS_(6)
      *ST_IC
      *LSS_(5)
      *ST_IT
      PDISC(P)
      *LSS_(5)
      *ST_ITT
      *LSS_(6)
      *ST_ICC
      I=IT-ITT
      PDISCIT=PDISCIT+I
      PTIT=PTIT-I
      I=IC-ICC
      PDISCIC=PDISCIC+I
      PTIC=PTIC-I
      PDISCCALLN=PDISCCALLN+1
      ST_FLAGS=X'80'    ;! DISC->STORE TRANSIT
    %FINISH %ELSE %START    ;! ON DRUM
      DRUMT(DTX)=STOREX
      P_DEST=X'280001'
      P_SRCE=X'80040006'
      ! AEX INTACT IN P1
      P_P2=DTX
      P_P3=STOREX
      *LSS_(6)
      *ST_IC
      *LSS_(5)
      *ST_IT
      DRUM(P)
      *LSS_(5)
      *ST_ITT
      *LSS_(6)
      *ST_ICC
      I=IT-ITT
      DRUMIT=DRUMIT+I
      PTIT=PTIT-I
      I=IC-ICC
      DRUMIC=DRUMIC+I
      PTIC=PTIC-I
      DRUMCALLN=DRUMCALLN+1
      ST_FLAGS=X'20'    ;! DRUM->STORE TRANSIT
    %FINISH
    PUSHPIT %UNLESS SRCE=0    ;! SAVE REPLY DESTS UNLESS DRUM FAIL
    P_DEST=0
  %FINISH
  %RETURN
!-----------------------------------------------------------------------
ACTIVITY(4):! REPLY FROM DISC READ
  STOREX=AMTDD(DDX)&STXMASK
  ST==STORE(STOREX)
  %IF P_P2>1 %THEN CLEAR EPAGE(ST_REALAD)
  ST_FLAGS=0
  I=ST_LINK
  %UNTIL I=0 %THEN PARM(I)_P3=P_P2 %AND J=PARM(I)_LINK %C
    %AND FASTPON(I) %AND I=J
  ST_LINK=0
  ! GET COPY ON DRUM AS SOON AS POSSIBLE
  %IF DRUMTASL=DTEND %THEN %RETURN    ;! NO DRUM PAGE FREE
  DTX=DRUMTASL
  DRUMTASL=DRUMT(DRUMTASL)
  DRUMTN=DRUMTN+1
  AMTDD(DDX)=DTXBIT!DTX
  DRUMT(DTX)=STOREX
  FLAGS=0
  ->DRUMUP
!-----------------------------------------------------------------------
ACTIVITY(6):! REPLY FROM DRUM/READ ON FAILURE ONLY
  DTX=AMTDD(DDX)&STXMASK
  STOREX=DRUMT(DTX)
  ST==STORE(STOREX)
  AMTDD(DDX)=STOREX
  DRUMT(DTX)=DRUMTASL    ;! RETURN DRUM PAGE
  DRUMTASL=DTX
  DRUMTN=DRUMTN-1
  DTX=-1
  SRCE=0
  ->DRUMRF
!-----------------------------------------------------------------------
ACTIVITY(2):! PAGE-OUT
  I=AMTDD(DDX)
  %IF I&DTXBIT=0 %THEN DTX=-1 %AND STOREX=I&STXMASK %ELSE %C
    DTX=I&STXMASK %AND STOREX=DRUMT(DTX) 
  ST==STORE(STOREX)
  AMTUSERS(AMTX)=AMTUSERS(AMTX)-1
  ST_FLAGS=ST_FLAGS!P_P2    ;! INSERT WRITTEN ETC. MARKERS
  ST_USERS=ST_USERS-1
  %IF ST_USERS>0 %THEN UNALLOCEPS=UNALLOCEPS-1 %AND %RETURN
  PAGEFREES=PAGEFREES+1    ;! PAGE ABOUT TO BECOME FREE
  %IF ST_FLAGS&X'A0'#0 %THEN %RETURN
PAGEOUT:FLAGS=0
  %IF ST_FLAGS&X'08'#0 %THEN %START
    ! WRITE TO DISC IF PAGE WRITTEN TO
    P_DEST=X'210002'    ;! STORE->DISC
    P_SRCE=X'80040005'
    ! AEX INTACT IN P1
    P_P2=AMTDA(AMTX)+EPX    ;! DISC ADDR
    P_P3=ST_REALAD!VIRTAD
    *LSS_(6)
    *ST_IC
    *LSS_(5)
    *ST_IT
    PDISC(P)
    *LSS_(5)
    *ST_ITT
    *LSS_(6)
    *ST_ICC
    I=IT-ITT
    PDISCIT=PDISCIT+I
    PTIT=PTIT-I
    I=IC-ICC
    PDISCIC=PDISCIC+I
    PTIC=PTIC-I
    PDISCCALLN=PDISCCALLN+1
    FLAGS=X'C0'    ;! DISC TRANSFER IN PROGRESS FLAG BITS
    AMTPTS(AMTX)=AMTPTS(AMTX)+1 ;! AVOIDS DRUM SPACE BEING DEALLOCATED
  %FINISH
  %IF ST_FLAGS&4=0 %THEN %START    ;! NO DRUM UPDATE
    %IF DTX>=0 %THEN %START    ;! RETURN DRUM PAGE
      AMTDD(DDX)=STOREX
      DRUMT(DTX)=DRUMTASL
      DRUMTASL=DTX
      DRUMTN=DRUMTN-1
      DTX=-1
    %FINISH
    ->NODRUM
  %FINISH
  %IF DTX<0 %THEN %START    ;! NOT ON DRUM YET
    %IF DRUMTASL=DTEND %THEN ->NODRUM %ELSE %START
      DTX=DRUMTASL    ;! GET DRUM PAGE
      DRUMTASL=DRUMT(DRUMTASL)
      DRUMTN=DRUMTN+1
      AMTDD(DDX)=DTXBIT!DTX
      DRUMT(DTX)=STOREX
      ->DRUMUP
    %FINISH
  %FINISH
  %IF ST_FLAGS&8#0 %THEN %START    ;! PAGE WRITTEN TO
DRUMUP:P_DEST=X'280002'    ;! DRUM WRITE
    P_SRCE=X'80040007'
    P_P1=AEX    ;! MAY NOT BE INTACT AFTER CALL OF PDISC !
    P_P2=DTX
    P_P3=STOREX
    P_P4=ADDR(AMTPTS(AMTX))
    *LSS_(6)
    *ST_IC
    *LSS_(5)
    *ST_IT
    DRUM(P)
    *LSS_(5)
    *ST_ITT
    *LSS_(6)
    *ST_ICC
    I=IT-ITT
    DRUMIT=DRUMIT+I
    PTIT=PTIT-I
    I=IC-ICC
    DRUMIC=DRUMIC+I
    PTIC=PTIC-I
    DRUMCALLN=DRUMCALLN+1
    FLAGS=FLAGS!X'30'    ;! DRUM TRANSFER IN PROGRESS BITS
    AMTPTS(AMTX)=AMTPTS(AMTX)+1  ;! AVOIDS AMT SPACE GOING
  %FINISH
NODRUM:%IF FLAGS=0 %THEN %START    ;! NO TRANSFERS INITIATED
    %IF DTX<0 %THEN %START
      %IF ST_FLAGS&2#0 %THEN AMTDD(DDX)=NEWEPBIT!STXMASK %C
      %ELSE ST_LINK=DDX %AND ST_FLAGS=1
    %FINISH %ELSE ST_LINK=DDBIT!DTX %AND ST_FLAGS=1
    P_P2=STOREX
    RETURN EPAGE(P)
    PAGEFREES=PAGEFREES-1
    %IF AMTUSERS(AMTX)=0 %AND AMTPTS(AMTX)=0 %THEN %START
      P_DEST=3
      P_P2=AMTX
      *LSS_(6)
      *ST_IC
      *LSS_(5)
      *ST_IT
      ACTIVE MEM(P)
      *LSS_(5)
      *ST_ITT
      *LSS_(6)
      *ST_ICC
      I=IT-ITT
      AMIT=AMIT+I
      PTIT=PTIT-I
      I=IC-ICC
      AMIC=AMIC+I
      PTIC=PTIC-I
      AMCALLN=AMCALLN+1
    %FINISH
  %FINISH %ELSE ST_FLAGS=FLAGS
  %RETURN  ;!  ->RETURN
!-----------------------------------------------------------------------
ACTIVITY(5):! REPLY FROM DISC/WRITE
  I=AMTDD(DDX)
  %IF I&DTXBIT=0 %THEN DTX=-1 %AND STOREX=I&STXMASK %ELSE %C
    DTX=I&STXMASK %AND STOREX=DRUMT(DTX)
  ST==STORE(STOREX)
  ! DISC WRITE FAILURE ???
  ST_FLAGS=ST_FLAGS&X'3F'    ;! NO DISC TRANSFER
  AMTPTS(AMTX)=AMTPTS(AMTX)-1
  %IF ST_FLAGS&X'20'#0 %OR ST_USERS#0 %THEN %RETURN
  %IF ST_FLAGS#0 %THEN ->PAGEOUT
REP:%IF DTX<0 %THEN ST_LINK=DDX %ELSE ST_LINK=DDBIT!DTX
  ST_FLAGS=1
  P_P2=STOREX
  RETURN EPAGE(P)
  PAGEFREES=PAGEFREES-1
  %IF AMTUSERS(AMTX)=0 %AND AMTPTS(AMTX)=0 %THEN %START
    P_DEST=3
    P_P2=AMTX
    *LSS_(6)
    *ST_IC
    *LSS_(5)
    *ST_IT
    ACTIVE MEM(P)
    *LSS_(5)
    *ST_ITT
    *LSS_(6)
    *ST_ICC
    I=IT-ITT
    AMIT=AMIT+I
    PTIT=PTIT-I
    I=IC-ICC
    AMIC=AMIC+I
    PTIC=PTIC-I
    AMCALLN=AMCALLN+1
  %FINISH
  %RETURN
!-----------------------------------------------------------------------
ACTIVITY(7):! REPLY FROM DRUM/WRITE
  DTX=AMTDD(DDX)&STXMASK
  STOREX=DRUMT(DTX)
  ST==STORE(STOREX)
  %IF P_P2<0 %THEN %START    ;! WRITE FAILURE
    AMTDD(DDX)=STOREX    ;! RETURN DRUM PAGE
    DRUMT(DTX)=DRUMTASL
    DRUMTASL=DTX
    DRUMTN=DRUMTN-1
    DTX=-1
  %FINISH
  ! NEXT 2 LINES NOW DONE IN DRUM ROUTINE
  !ST_FLAGS=ST_FLAGS&X'CF'    ;! NO DRUM TRANSFER
  !AMTPTS(AMTX)=AMTPTS(AMTX)-1
  %IF ST_FLAGS&X'80'#0 %OR ST_USERS#0 %THEN %RETURN
  %IF ST_FLAGS#0 %THEN ->PAGEOUT
  ->REP    ;! RETURN EPAGE
!-----------------------------------------------------------------------
%ROUTINE PUSHPIT
%RECORDNAME PP(PARMXF)
%INTEGER I
  I=NEWPPCELL
  PP==PARM(I)
  PP_DEST=SRCE
  PP_SRCE=X'40001'
  PP_P1=ID
  PP_P2=STORE(STOREX)_REALAD
  PP_P3=0    ;! SUCCESS FLAG
  PP_LINK=ST_LINK
  ST_LINK=I
%END
!-----------------------------------------------------------------------
%END
!----------------------------------------------------------------------
%ROUTINE GET EPAGE(%RECORDNAME P)
%RECORDSPEC P(PARMF)
%INTEGER STOREX,PS,I
!  *INCT_STASLSEMA
!  *JCC_8,<SEMACL>
!  SEMALOOP(STASLSEMA)
!SEMACL:
  %IF FREEEPAGES=0 %THEN %START
    P_SRCE=P_SRCE&X'7FFFFFFF'
    !I=SERVA(5)_P
    PON(P)
    ! PUT HIGH PRIORITY REQUESTS ON FRONT
    !%IF P_DEST&X'FFFF'=0 %AND I<<1#0 %THEN SERVA(5)_P=I
    PS=P_SRCE
    %IF PS=X'40003' %THEN PS=P_P5
    %IF LOCSN0<PS>>16<=LOCSN1%AND 9<=PS&X'FFFF'<=10%THEN GETEPN=GETEPN+1
    %IF PAGEFREES=0 %AND MPLEVEL=GETEPN %THEN DEADLOCK
    P_DEST=0
    %RETURN
  %FINISH
  %IF KMON&1<<5#0 %THEN PRINT STRING("GETEPAGE:") %AND PTREC(P)
  STOREX=FSTASL
  FSTASL=STORE(FSTASL)_FLINK
  %IF FSTASL=0 %THEN BSTASL=0 %ELSE STORE(FSTASL)_BLINK=0
  %IF STORE(STOREX)_FLAGS=1 %THEN %START    ;! RECAPTURABLE FLAG
    I=STORE(STOREX)_LINK
    %IF I&DDBIT=0 %THEN AMTDD(I)=AMTDD(I)!STXMASK %ELSE %C
      I=I&(\DDBIT) %AND DRUMT(I)=STXMASK
    STORE(STOREX)_FLAGS=0
  %FINISH

  P_P2=STOREX    ;! LEAVE P1 & P3 & P5 & P6 INTACT
  P_P4=VIRTAD!STORE(STOREX)_REALAD
  %IF P_SRCE>0 %THEN %START
    P_DEST=P_SRCE
    P_SRCE=X'50000'
    PON(P)
    PS=P_DEST
    %IF PS=X'40003' %THEN PS=P_P5
    %IF LOCSN0<PS>>16<=LOCSN1%AND 9<=PS&X'FFFF'<=10%THEN GETEPN=GETEPN-1
  %FINISH
  FREEEPAGES=FREEEPAGES-1
  %IF FREEEPAGES=0 %THEN %START
    INHIBIT(5)
    %IF PAGEFREES=0 %AND MPLEVEL=GETEPN %THEN DEADLOCK
  %FINISH
!RETURN:STASLSEMA=-1
%END
!-----------------------------------------------------------------------
%INTEGERFN NEW EPAGE
%RECORD P(PARMF)
%INTEGER I
  %IF FREEEPAGES=0 %THEN %RESULT=-1
  P_SRCE=0
  GET EPAGE(P)
  I=STORE(P_P2)_REALAD
  CLEAR EPAGE(I)
  %RESULT=I
%END
!-----------------------------------------------------------------------
%ROUTINE RETURN EPAGE(%RECORDNAME P)
%RECORDSPEC P(PARMF)
%INTEGER STOREX
!  *INCT_STASLSEMA
!  *JCC_8,<SEMACL>
!  SEMALOOP(STASLSEMA)
!SEMACL:
  %IF KMON&1<<6#0 %THEN PRINT STRING("RETURNEPAGE:") %AND PTREC(P)
  STOREX=P_P2
  STORE(STOREX)_FLINK=0
  STORE(STOREX)_BLINK=BSTASL
  %IF BSTASL=0 %THEN FSTASL=STOREX %ELSE STORE(BSTASL)_FLINK=STOREX
  BSTASL=STOREX
  %IF FREEEPAGES=0 %THEN UNINHIBIT(5)
  FREEEPAGES=FREEEPAGES+1
!  STASLSEMA=-1
%END
!-----------------------------------------------------------------------
%ROUTINE DEADLOCK
%INTEGER PP,PPP,PL,PS
! HORRIBLE FRIG TO MAKE SURE SUITABLE PROCESS GETS PAGE ZERO !!!
  PP=SERVA(5)_P&X'7FFFFFFF'    ;! SERVICE 5 = GET EPAGE
  PPP=PP
  %UNTIL PP=PPP %CYCLE
    PL=PARM(PP)_LINK
    PS=PARM(PL)_SRCE
    %IF PS=X'00040003' %THEN PS=PARM(PL)_P5    ;! 4/3=PAGE-IN GET EPAGE
    %IF LOCSN0<PS>>16<=LOCSN1 %AND 9<=PS&X'FFFF'<=10 %THEN %START
      SERVA(5)_P=X'80000000'!PP
      UNINHIBIT(5)
      FREEEPAGES=1
      PRINT STRING("DEADLOCK RECOVERED
")
      DEADLOCKS=DEADLOCKS+1
      %RETURN
    %FINISH
    PP=PL
  %REPEAT
  MONITOR("DEADLOCK UNRECOVERABLE")
%END
!-----------------------------------------------------------------------
%ROUTINE ACTIVE MEM(%RECORDNAME P)
%RECORDSPEC P(PARMF)
%OWNHALFINTEGERARRAY AMTH(0:511)    ;! HASH ARRAY
%OWNINTEGER AMTASL=1
%OWNINTEGERARRAY DDP(1:16)=0(16)    ;! (1:MAXBLOCK)
%OWNINTEGER DDALLOC=0
%OWNINTEGER AMTLIM
%OWNINTEGERARRAY AEPN(1:128)=0(128)    ;! (1:MAXPROCS)
%ROUTINESPEC DDPALLOC(%INTEGER FROM,TO)
%ROUTINESPEC DEALLOCAMT
%ROUTINESPEC DEALLOCDD(%INTEGER DDX,LEN)
%ROUTINESPEC RELAM(%INTEGER PROCESS,N)
%INTEGER HASH,SL,CL,DDX,GARB,AMTX,SRCE,ID,DA,LEN,MASK,I,J,K
%RECORDNAME PROC(PROCF)
%OWNINTEGER AMTOSN=0
%SWITCH ACT(0:5)
  %IF KMON&1<<8#0 %THEN PRINT STRING("ACTIVEMEM:") %AND PTREC(P)
  SRCE=P_SRCE
  ID=P_P1
  ->ACT(P_DEST&X'FFFF')
!-----------------------------------------------------------------------
ACT(0):! INITIALISE
  %CYCLE I=0,1,511
    AMTH(I)=I+NAMT+1
  %REPEAT
  %CYCLE I=1,1,NAMT-1
    AMTL(I)=I+1
  %REPEAT
  AMTL(NAMT)=0
  DDPALLOC(1,DDSIZE)
  AMTLIM=MAXAMTLIM
  DISPLAY TEXT(0,50,20,"AMT   :  0%")
  %IF DRUMESIZE=0 %THEN DRUMTASL=DTEND %ELSE %START
    %CYCLE I=0,1,DRUMESIZE-2
      DRUMT(I)=I+1
    %REPEAT
    DRUMT(DRUMESIZE-1)=DTEND
    DRUMTASL=0
    DRUMTN=0
    DISPLAY TEXT(0,51,20,"DRUM  :  0%")
  %FINISH
  %RETURN
!-----------------------------------------------------------------------
ACT(1):! GET AMTX
  DA=P_P2
  LEN=P_P3&X'F'+1
  MASK=P_P3&X'FFFF0000'<<(16-LEN)    ;! "NEW" EPAGE BIT MASK (TOP BITS)
  HASH=(DA-(DA//509)*509)&X'1FF'    ;! DA MIGHT BE NEGATIVE
  SL=AMTH(HASH)
  %IF SL<=NAMT %THEN %START  ;! SOMETHING ALREADY HAS SAME HASH
    CL=SL
    %UNTIL CL>NAMT %CYCLE    ;! SCAN DOWN LIST
      %IF AMTDA(CL)=DA %THEN %START    ;! THIS DA ALREADY IN TABLE
        %IF AMTLEN(CL)#LEN %THEN %START
          %IF AMTUSERS(CL)#0 %THEN CL=-3 %AND ->RETURN
          I=AMTLEN(CL)
          %IF I<LEN %THEN CL=0 %AND ->RETURN    ;! EXTEND ?
          DDX=AMTP(CL)
          %CYCLE J=DDX+LEN,1,DDX+I-1
            K=AMTDD(J)&STXMASK    ;! STOREX
            %IF K#STXMASK %THEN  CL=0 %AND ->RETURN    ;! STILL IN USE
          %REPEAT
          AMTLEN(CL)=LEN
          AMTX=CL
          DEALLOCDD(DDX+LEN,I-LEN)
        %FINISH
        AMTUSERS(CL)=AMTUSERS(CL)+1    ;! USERS
        ->RETURN
      %FINISH
      CL=AMTL(CL)
    %REPEAT
  %FINISH
  %IF AMTASL=0 %THEN OPMESS("NO AMT CELLS") %AND CL=-1 %AND ->RETURN
  ! ALLOCATE SPACE
  GARB=0    ;! NOT GARBAGE COLLECTED YET
RETRY:%CYCLE I=LEN,1,MAXBLOCK
    DDX=DDP(I)
    %UNLESS DDX=0 %THEN %START
      DDP(I)=AMTDD(DDX)
      %IF I>LEN %THEN %START
        I=I-LEN
        J=DDX+LEN
        K=DDP(I)
        AMTDD(J)=K
        DDP(I)=J
      %FINISH
      CL=AMTASL    ;! PUSHDOWN NEW AMT CELL
      AMTASL=AMTL(AMTASL)
      AMTDA(CL)=DA
      AMTP(CL)=DDX
      AMTL(CL)=SL
      AMTH(HASH)=CL
      AMTUSERS(CL)=1
      AMTLEN(CL)=LEN
      AMTPTS(CL)=0
      %CYCLE I=0,1,LEN-1
        AMTDD(DDX+I)=MASK>>31<<15!STXMASK
        MASK=MASK<<1
      %REPEAT
      DDALLOC=DDALLOC+LEN
      %IF DDALLOC/DDSIZE>0.85 %AND AMTLIM>MINAMTLIM %THEN %C
        AMTLIM=AMTLIM-1
      ->RETURN
    %FINISH
  %REPEAT
  ! NO HOLES BIG ENOUGH
  %IF GARB#0 %THEN OPMESS("NOT ENOUGH GARBAGE") %AND CL=-2 %AND ->RETURN
  %CYCLE I=1,1,MAXBLOCK
    %WHILE DDP(I)#0 %CYCLE
      J=DDP(I)
      DDP(I)=AMTDD(J)
      AMTDD(J)=0
    %REPEAT
  %REPEAT
  I=DDSIZE+1
ALLOC:%WHILE I>1 %CYCLE
    I=I-1
    %IF AMTDD(I)=0 %THEN ->UNALLOC
  %REPEAT
  ->NOGARB
UNALLOC:DDX=I
  %WHILE I>1 %CYCLE
    I=I-1
    %IF AMTDD(I)#0 %THEN DDPALLOC(I+1,DDX) %AND ->ALLOC
  %REPEAT
  DDPALLOC(1,DDX)
NOGARB:PRINT STRING("AMT GARBAGE COLLECT:".STRINT(INT(100*%C
    (DDSIZE-DDALLOC)/DDSIZE))."% FREE
")
  GARB=1
  ->RETRY
RETURN:P_P1=ID
  P_P2=CL
  %IF SRCE>0 %THEN P_DEST=SRCE %AND P_SRCE=X'80001' %AND PON(P) %C
    %ELSE %START
    %IF ID>0 %AND CL>0 %THEN AEPN(ID)=AEPN(ID)+LEN %C
        %AND P_P3=AEPN(ID)-AMTLIM
  %FINISH
  %RETURN
!-----------------------------------------------------------------------
ACT(2):! RETURN AMTX
  AMTX=P_P2
  LEN=AMTLEN(AMTX)
  DDX=AMTP(AMTX)
  MASK=0
  %CYCLE I=DDX+LEN-1,-1,DDX    ;! GET "NEW" EPAGE BIT MASK
    MASK=AMTDD(I)>>15<<31!MASK>>1
  %REPEAT
  AMTUSERS(AMTX)=AMTUSERS(AMTX)-1
  %IF AMTUSERS(AMTX)=0 %AND AMTPTS(AMTX)=0 %THEN DEALLOCDD(DDX,LEN) %C
    %AND DEALLOCAMT
  P_P1=MASK
  %IF SRCE=0 %AND ID>0 %THEN AEPN(ID)=AEPN(ID)-LEN
  %RETURN
!-----------------------------------------------------------------------
ACT(3):! RETURN AMTX AFTER TRANFERS FINISHED
  AMTX=P_P2
  DEALLOCDD(AMTP(AMTX),AMTLEN(AMTX))
  DEALLOCAMT
  %RETURN
!-----------------------------------------------------------------------
ACT(4):! ENTERED EVERY 2 SECS
  ! UPDATE OPER
  DISPLAY TEXT(0,50,29,STRINT(100*DDALLOC//DDSIZE)."% ")
  %IF DRUMESIZE#0 %THEN DISPLAY TEXT(0,51,29,STRINT(100*%C
    DRUMTN//DRUMESIZE)."% ")
  AMTOSN=AMTOSN+2
  %IF AMTOSN<AMTOS %THEN %RETURN
  AMTOSN=0
  ! RELEASE AM IF NOT BEING USED
  I=1
  J=0
  %UNTIL J=COM_USERS %CYCLE
    PROC==PROCA(I)
    %IF PROC_USER#"" %THEN %START
      %IF PROC_ACTIVE=AMTON %AND AEPN(I)>0 %THEN RELAM(I,AEPN(I))
      PROC_ACTIVE=PROC_ACTIVE+1 %UNLESS PROC_ACTIVE>AMTON
      J=J+1
    %FINISH
    I=I+1
  %REPEAT
  %RETURN
!-----------------------------------------------------------------------
ACT(5):! CHECK DISC ADDRESS ACTIVE
  DA=P_P1
  HASH=(DA-(DA//509)*509)&X'1FF'
  CL=AMTH(HASH)
  %WHILE CL<=NAMT %THEN %CYCLE
    %IF AMTDA(CL)=DA %THEN %START
      %IF AMTPTS(CL)#0 %THEN P_DEST=1 %AND %RETURN
      MONITOR("BLOCK STILL ACTIVE ?")
    %FINISH
    CL=AMTL(CL)
  %REPEAT
  P_DEST=0
  %RETURN
!-----------------------------------------------------------------------
%ROUTINE DDPALLOC(%INTEGER FROM,TO)
%INTEGER I,J,K
  J=1
  %CYCLE I=TO,-1,FROM
    %IF J=MAXBLOCK %OR I=FROM %THEN K=DDP(J) %AND DDP(J)=I %C
      %AND J=1 %ELSE K=0 %AND J=J+1
    AMTDD(I)=K
  %REPEAT
%END
!-----------------------------------------------------------------------
%ROUTINE DEALLOCAMT
%INTEGER CL,SL,HASH,J
  CL=AMTX    ;! SCAN TO END OF LIST
  CL=AMTL(CL) %UNTIL CL>NAMT
  HASH=CL-NAMT-1
  CL=AMTH(HASH)    ;! FIND PREVIOUS CELL
  J=AMTL(AMTX)
  %IF CL=AMTX %THEN AMTH(HASH)=J %ELSE %START
    SL=CL %AND CL=AMTL(CL) %UNTIL CL=AMTX
    AMTL(SL)=J
  %FINISH
  AMTL(AMTX)=AMTASL    ;! RETURN CELL
  AMTASL=AMTX
%END
!-----------------------------------------------------------------------
%ROUTINE DEALLOCDD(%INTEGER DDX,LEN)
%INTEGER I,J,DTX
  %CYCLE I=DDX,1,DDX+LEN-1
    %IF AMTDD(I)&DTXBIT#0 %THEN %START    ;! RETURN DRUM PAGE
      DTX=AMTDD(I)&STXMASK
      J=DRUMT(DTX)
      %IF J#STXMASK %THEN STORE(J)_FLAGS=0
      DRUMT(DTX)=DRUMTASL
      DRUMTASL=DTX
      DRUMTN=DRUMTN-1
    %FINISH %ELSE %START
      J=AMTDD(I)&STXMASK
      %IF J#STXMASK %THEN STORE(J)_FLAGS=0
    %FINISH

    AMTDD(I)=0
  %REPEAT
  I=DDP(LEN)
  AMTDD(DDX)=I
  DDP(LEN)=DDX
  DDALLOC=DDALLOC-LEN
  %IF DDALLOC/DDSIZE<0.85 %AND AMTLIM<MAXAMTLIM %THEN AMTLIM=AMTLIM+1
%END
!-----------------------------------------------------------------------
%ROUTINE RELAM(%INTEGER PROCESS,N)
%RECORD P(PARMF)
  P_DEST=(PROCESS+LOCSN3)<<16    ;! ASYNCH. ACTIVITY 0
  P_SRCE=X'80000'
  P_P1=2    ;! RELEASE ACTIVE MEMORY
  P_P2=N
  PON(P)
%END
!-----------------------------------------------------------------------
%END
!-----------------------------------------------------------------------
%ROUTINE TIMEOUT(%RECORDNAME P)
%RECORDSPEC P(PARMF)
%CONSTSTRING(15)%ARRAY SERVROUT(0:66)="IDLE TIME",""(2),"SCHEDULE",
  "PAGETURN","GET EPAGE","RETURNEPAGE","SEMAPHORE","ACTIVEMEM","",
  "ELAPSEDINT","UPDATE TIME","DPONPUTONQ","TURNONEP",""(18),
  "DISC","DISCP","DISC INTERRUPT","","MOVE/1","MOVE/2",""(2),
  "DRUM/1","DRUM/2","DRUM INTERRUPT",""(5),"GPC","TAPE",
  "OPER","LP ADAPTOR","CR ADAPTOR","CP ADAPTOR","PRINTER",
  "COMMS CONTROL/1","COMMS CONTROL/2","MK1FEADAPTOR","GPC INTERRUPT",
  ""(3),"COMREP",""(2),"LOCAL CONTROL","LOCAL PROCESS"  ;! (0:LOCSN0+2)
%STRING(31)%FN STRPRINT(%REAL X,%INTEGER B,A)
! STRING OF "PRINT(X,B,A)"
%STRING(31) S,T,U
%INTEGER I
%REAL Y
  %IF X<0 %THEN X=-X %AND U="-" %ELSE U=""
  Y=10**A
  X=INT(X*Y)/Y    ;! ROUND
  I=INTPT(X)
  S=U.STRINT(I)
  %WHILE LENGTH(S)<B %THEN S=" ".S
  %IF A=0 %THEN %RESULT=S
  T=STRINT(INT((X-I)*Y))
  %WHILE LENGTH(T)<A %THEN T="0".T
  %RESULT=S.".".T
%END
%INTEGER I
%REAL PERIOD,TOTAL,IDLETIME,PROCTIME,SERVTIME
%STRING(15) S
  PERIOD=CLOCK-CLOCK0
  NEWPAGE
  PRINT STRING("

EMAS 2900 SUP".SUPID." TIMING MEASUREMENTS

  PERIOD=".STRPRINT(PERIOD/1000000,1,3)." SECS
")
  SERVIT(0)=IDLEIT
  SERVIC(0)=IDLEN
  SERVN(0)=IDLEN
  IDLETIME=COM_ITINT*IDLEIT
  SERVIT(4)=SERVIT(4)+PTIT    ;! PAGETURN
  SERVIC(4)=SERVIC(4)+PTIC
  SERVN(4)=SERVN(4)+PTCALLN
  SERVIT(5)=SERVIT(5)+GETIT    ;! GET EPAGE
  SERVIC(5)=SERVIC(5)+GETIC
  SERVN(5)=SERVN(5)+GETCALLN
  SERVIT(8)=SERVIT(8)+AMIT    ;! ACTIVE MEM
  SERVIC(8)=SERVIC(8)+AMIC
  SERVN(8)=SERVN(8)+AMCALLN
  SERVIT(33)=SERVIT(33)+PDISCIT    ;! PDISC
  SERVIC(33)=SERVIC(33)+PDISCIC
  SERVN(33)=SERVN(33)+PDISCCALLN
  SERVIT(40)=SERVIT(40)+DRUMIT    ;! DRUM
  SERVIC(40)=SERVIC(40)+DRUMIC
  SERVN(40)=SERVN(40)+DRUMCALLN
  SERVIT(LOCSN0+1)=SERVIT(LOCSN0+1)+LCIT
  SERVIC(LOCSN0+1)=SERVIC(LOCSN0+1)+LCIC
  SERVN(LOCSN0+1)=LCN
  SERVIT(LOCSN0+2)=LPIT
  SERVN(LOCSN0+2)=LPN
  PROCTIME=COM_ITINT*LPIT
  PRINT STRING("
    SERVICE        CALLS     TIME    AVERAGE      % OF     % OF     ".%C
"% OF  INSTRNS  AVERAGE
                            (SECS)   (MSECS)     TOTAL   NON-IDLE  ".%C
"SUPVSR

")
  TOTAL=0
  %CYCLE I=0,1,LOCSN0+2
    S=SERVROUT(I)
    %IF S#"" %THEN %START
      PRINT STRING("  ".S.STRSP(16-LENGTH(S)).STRPRINT(SERVN(I),6,0))
      %IF SERVN(I)=0 %THEN NEWLINE %ELSE %START
        SERVTIME=COM_ITINT*SERVIT(I)
        PRINT STRING(STRPRINT(SERVTIME/1000000,6,3). %C
          STRPRINT(SERVTIME/(1000*SERVN(I)),6,3). %C
          STRPRINT(100*SERVTIME/PERIOD,7,1)."%". %C
          STRPRINT(100*SERVTIME/(PERIOD-IDLETIME),6,1)."%". %C
          STRPRINT(100*SERVTIME/(PERIOD-IDLETIME-PROCTIME),6,1)."%". %C
        STRPRINT(SERVIC(I),9,0).STRPRINT(SERVIC(I)/SERVN(I),8,0)."
")
      TOTAL=TOTAL+SERVTIME
      %FINISH
    %FINISH
  %REPEAT
  PRINT STRING("
  INTERRUPT/ACTIVATE ETC.=".STRPRINT((PERIOD-TOTAL)/1000000,1,3). %C
    " SECS (".STRPRINT(100*(PERIOD-TOTAL)/PERIOD,1,1)."%)

DEADLOCKS=".STRINT(DEADLOCKS)."
COMMSALLOC=".STRINT(COMMSALLOC)."
QUEUED STREAMS=".STRINT(QUEUED STREAMS)."
DRUMESIZE=".STRINT(DRUMESIZE)."
AMTSIZE=".STRINT(DDSIZE)."
OVERALLOC=".STRINT(OVERALLOC)."
MAXABT REACHED=".STRINT(MAXABTN)."
RECAPTURES=".STRINT(100*RECAPN//PTURNN)."%
SHARED PAGES=".STRINT(100*PSHAREN//PTURNN)."%
FREE EPAGES=")
  %CYCLE I=0,1,PFREENL
    PRINT STRING(STRINT(PFREEN(I))."  ")
  %REPEAT
  PRINT STRING("


")
  NEWPAGE
  CLEAR TIME
%END
!-----------------------------------------------------------------------
%ROUTINE CLEAR TIME
%INTEGER I
  %CYCLE I=0,1,LOCSN0+2
    SERVIT(I)=0
    SERVIC(I)=0
    SERVN(I)=0
  %REPEAT
  IDLEIT=0
  IDLEN=0
  PTIT=0
  PTIC=0
  DRUMIT=0
  DRUMIC=0
  PDISCIT=0
  PDISCIC=0
  GETIT=0
  GETIC=0
  AMIT=0
  AMIC=0
  PTCALLN=0
  DRUMCALLN=0
  PDISCCALLN=0
  AMCALLN=0
GETCALLN=0
  LCIT=0
  LCIC=0
  LCN=0
  LPIT=0
  LPN=0
  DEADLOCKS=0
  QUEUED STREAMS=0
  MAXABTN=0
  RECAPN=0
  PTURNN=0
  PSHAREN=0
  %CYCLE I=0,1,PFREENL
    PFREEN(I)=0
  %REPEAT
  CLOCK0=CLOCK
%END
!-----------------------------------------------------------------------
%ROUTINE CLEAR EPAGE(%INTEGER STAD)
%INTEGER I,J
  I=X'58000000'!EPAGESIZE<<10
  J=VIRTAD!STAD
  *LDTB_I
  *LDA_J
  *MVL_%L=%DR,0,0
%END
!-----------------------------------------------------------------------
%LONGINTEGERFN CLOCK
%LONGINTEGER L
  *RRTC_0
  *ST_L
  %RESULT=(L>>33<<32!L&X'0FFFFFFFF')<<1
%END
!-----------------------------------------------------------------------
%ROUTINE UPDISP(%INTEGER PROCESS,OFFSET,%STRING(13) S)
%INTEGER I
  %IF PROCESS<=66 %THEN %START
    I=(PROCESS-1)//22
    DISPLAY TEXT(0,PROCESS-I*22+1,I*13+OFFSET,S)
  %FINISH %ELSE %START
    PROCESS=PROCESS-66
    I=(PROCESS-1)//22
    DISPLAY TEXT(0,PROCESS-I*22+25,I*13+OFFSET,S)
  %FINISH
%END
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
%ROUTINE LOCAL CONTROL
!-----------------------------------------------------------------------
! DIRECTOR COMMUNICATIONS RECORDS
%RECORD DIROUTP(PARMF)
%RECORDFORMAT SIGOUTPF(%INTEGER DEST,SRCE,P1,P2,P3,P4,P5,P6, %C
  TYPE,SSN,SSNAD,SUSP)
%RECORD SIGOUTP(SIGOUTPF)
!-----------------------------------------------------------------------
! CLAIMED BLOCK TABLES
%BYTEINTEGERARRAY SST(0:LSTLEN-1)
%RECORDFORMAT CBTF(%INTEGER DA,%BYTEINTEGER ABTX,MASK2,TAGS,LINK)
%RECORDARRAY CBTA(0:254)(CBTF)
%INTEGER CBTASL
%RECORDNAME CBT(CBTF)
%INTEGER CBTP
!-----------------------------------------------------------------------
! SYSTEM CALL TABLE INDEX
%LONGINTEGERARRAY SCTI(-1:15)
!-----------------------------------------------------------------------
! CONSOLE IO RECORDS
%RECORDFORMAT IOSTATF(%INTEGER IAD,%STRING(15) INTMESS)
%RECORDNAME IOSTAT(IOSTATF)
!-----------------------------------------------------------------------
! ACCOUNTING INFORMATION
%RECORDFORMAT ACNTF(%LONGINTEGER LTIME,%INTEGER PTURNS)
%RECORDNAME ACNT(ACNTF)
! INSTRUCTION COUNTER REVS WORD
%INTEGERNAME ICREVS
!-----------------------------------------------------------------------
! ACTIVE BLOCK TABLES
%CONSTINTEGER MAXABT=48
%RECORDFORMAT ABTF(%HALFINTEGER AMTX,%BYTEINTEGER CBTX,SEG,STEP, %C
  PREV,NEXT,LINK)
%RECORDARRAY ABTA(1:MAXABT)(ABTF)
%RECORDNAME ABT(ABTF)
%RECORDFORMAT EPF(%BYTEINTEGER ST,X,LINK)
%RECORDARRAY EPA(1:MAXEPAGES)(EPF)
%RECORDNAME EP(EPF)
%INTEGER ABTT,ABTB,ABTASL,EPASL
%BYTEINTEGER PTP
!-----------------------------------------------------------------------
! LOCAL STACKS INFORMATION
%BYTEINTEGERARRAY LSTKSSN(1:LSTKN)
!-----------------------------------------------------------------------
! CATEGORY INFORMATION
%INTEGER EPLIM,EPN,RTLIM,RTN,ABTN
!-----------------------------------------------------------------------
%ROUTINESPEC CONNECT(%INTEGER SEG,DA,LEN,ACC)
%ROUTINESPEC PUSHEP(%BYTEINTEGERNAME LP,%INTEGER X)
%ROUTINESPEC POPEP(%BYTEINTEGERNAME LP)
%ROUTINESPEC ABTOUT(%INTEGER ABTX)
%ROUTINESPEC STROBE(%INTEGER KEEPUSE)
%ROUTINESPEC WORKSET(%INTEGER MAXWSN)
%ROUTINESPEC RETURN PTS
%INTEGERFNSPEC FIND PROCESS
%INTEGERFNSPEC CURSSN
%ROUTINESPEC VSINT
%ROUTINESPEC PROGERR
%ROUTINESPEC WAIT(%INTEGER DACT,N)
!-----------------------------------------------------------------------
%RECORDNAME PROC(PROCF)
%RECORDNAME SERV0,SERV,SERV3(SERVF)
%RECORD POUT(PARMF)
%RECORDNAME SSNP1(SSNP1F)
%LONGINTEGERARRAYNAME LST
%INTEGERARRAYFORMAT PTF(0:255)    ;! PAGE TABLE FORMAT
%INTEGERARRAYNAME PT
%INTEGER PROCESS,ME,LSN3,PTAD,VSPARM,PEPARM,VSSEG,VSEPAGE,AMTX,EPX,I,J,K
%INTEGER NEWSTK,STOREX,ABTX,CBTX,DEST,SRCE,SUSP,DIROUTPAD
%INTEGER WSN,PPLOAD,STEP,XSTROBE,PLOAD,SEGLEN,PTEPS,ABTDESTROY
%INTEGER PROCSTACK1,PROCSTACK2,HIGHSEG,SCTI0,IT,IC,ITT,ICC
%STRING(8) PROCID
%STRING(15) INTMESS
%SWITCH ACTIVITY(1:14),VSCAUSE(0:4),ASYN0(1:2),AMTXSW(-3:0)
%CONSTINTEGER MAXDIROUT=19
%SWITCH DIROUT(0:19)    ;! (0:MAXDIROUT)
%CONSTBYTEINTEGERARRAY MAXOUTACR(0:19)=X'F'(20)    ;! (0:MAXDIROUT)
%CONSTSTRING(2)%ARRAY EPUSE(0:3)="","W","R","RW"
%BYTEINTEGERNAME EPL
%STRING(3) STRSEG
%CONSTSTRING(10)%ARRAY STRPPLOAD(0:1)=":PRELOAD:",":PARTLOAD:"
!-----------------------------------------------------------------------
! INITIAL PROCESS CREATE ENTRY ONLY
  *LSS_OLDLNB
  *ST_(%LNB+0)    ;! TO FRIG %MONITOR
  PROCESS=P_P1
  PROCID="PROC".STRINT(PROCESS).":"
  PROC==PROCA(PROCESS)
  ME=(PROCESS+LOCSN0)<<16
  LSN3=PROCESS+LOCSN3
  SERV0==SERVA(PROCESS+LOCSN0)
  SERV3==SERVA(LSN3)
!-----------------------------------------------------------------------
! INITIALISE CLAIMED BLOCK TABLES
  %CYCLE I=0,1,LSTLEN-1
    SST(I)=255    ;! ALL SEGMENTS UNCONNECTED
  %REPEAT
  %CYCLE I=0,1,254
    CBTA(I)_LINK=I+1
  %REPEAT
  CBTASL=0
  %CYCLE I=1,1,MAXABT    ;! LAST LINK NOT USED !!
    ABTA(I)_LINK=I+1
  %REPEAT
  ABTASL=1
  ABTT=255
  ABTB=255
  ABTN=0
  %CYCLE I=1,1,MAXEPAGES    ;! LAST LINK NOT USED !!
    EPA(I)_LINK=I+1
  %REPEAT
  EPASL=1
  EPN=0    ;! NO EPAGES USED SO FAR
  PTP=255
  PROCSTACK1=X'28000001'
  PROCSTACK2=ADDR(PROC_STACK)    ;! %INTEGERNAME DESCRIPTOR
  DIROUTPAD=ADDR(DIROUTP)
  SUSP=0
  ABTDESTROY=0
  SCTI0=ADDR(SCTI(0))&X'FFFFFFF8'    ;! DBLE-WORD ALIGNED
!-----------------------------------------------------------------------
  ! INITIALIZE LOCAL STACKS INFO
  LST==ARRAY(0,LSTF)    ;! LOCAL SEG TABLE IN SEG 0
  LSTKSSN(1)=4    ;! DIRECTOR/USER STACK SEGMENT
  LST(5)=LST(1)+X'80'
  LSTKSSN(2)=6    ;! SIGNAL STACK
  LST(7)=LST(1)+X'100'
  %CYCLE I=3,1,LSTKN
    LSTKSSN(I)=0
  %REPEAT
  ! CONNECT DIRECTOR FILES
  CONNECT(2,P_P2,SEGEPSIZE,X'101')    ;! CODE
  CONNECT(3,P_P3,MAXBLOCK,X'11')    ;! GLA
  CONNECT(4,P_P4,SEGEPSIZE-1,X'FF')  ;! STACK
!-----------------------------------------------------------------------
  %IF PROCESS=1 %THEN %START    ;! SET UP IST ENTRIES ONCE ONLY
    ! SET UP DUMMY IST VECTOR
    *STLN_I
    ISTDUM_LNB=I
    ISTDUM_PSR=X'00140001'
    ISTDUM_PC=0
    ISTDUM_SSR=X'01800EFE'    ;! ONLY OUT & SYSERR
    *STSF_I
    ISTDUM_SF=I
    ISTDUM_IT=MAXIT
    ISTDUM_IC=MAXIT
    ISTDUM_SP=0
    ! SET VS ERROR IST ENTRY TO ENTER LOCAL
    ISTP==RECORD(ISTAD+X'80')
    ISTP=ISTDUM
    *JLK_<VSERRI> ; *LSS_%TOS ; *ST_I
    ISTP_PC=I
    ! SET INTERVAL TIMER IST ENTRY TO ENTER LOCAL
    ISTP==RECORD(ISTAD+X'A0')
    ISTP=ISTDUM
    *JLK_<ITIMERI> ; *LSS_%TOS ; *ST_I
    ISTP_PC=I
    ! SET PROG ERROR IST ENTRY TO ENTER LOCAL
    ISTP==RECORD(ISTAD+X'C0')
    ISTP=ISTDUM
    *JLK_<PROGERRI> ; *LSS_%TOS ; *ST_I
    ISTP_PC=I
    ! SET SYSTEM CALL IST ENTRY
    ISTP==RECORD(ISTAD+X'E0')
    ISTP_PSR=X'00140001'
    ISTP_PC=SCASSPC
    ISTP_SF=ADDR(PROCSTACK1)
    ISTP_IT=ADDR(ACTW0)
    ISTP_IC=X'3000000F'    ;! 64 BIT VECTOR DESCRIPTOR TO SCTI
    ISTP_SP=SCTI0
    ! SET UP OUT IST ENTRY
    ISTP==RECORD(ISTAD+X'100')
    ISTP=ISTDUM
    *JLK_<OUTI> ; *LSS_%TOS ; *ST_I
    ISTP_PC=I
    ! SET EVENT PENDING IST ENTRY
    ISTP==RECORD(ISTAD+X'140')
    ISTP=ISTDUM
    *JLK_<EPI> ; *LSS_%TOS ; *ST_I
    ISTP_PC=I
    ! SET INSTRUCTION COUNTER IST ENTRY
    ISTP==RECORD(ISTAD+X'160')
    ISTP=ISTDUM
    *JLK_<ICOUNTERI> ; *LSS_%TOS ; *ST_I
    ISTP_PC=I
    ! SET UP LOCAL CONTROLLER REACTIVATE CONTEXT
    *STLN_I
    LSSNP1_LNB=I
    LSSNP1_PSR=X'00140001'
    *JLK_<ENTERI> ; *LSS_%TOS ; *ST_I
    LSSNP1_PC=I
    LSSNP1_SSR=X'01800FFE'
    *STSF_I
    LSSNP1_SF=I
    LSSNP1_IT=MAXIT
    LSSNP1_IC=MAXIT
    LSSNP1_SP=0
  %FINISH
!-----------------------------------------------------------------------
! SET UP DIRECTOR CONTEXT
  NEWSTK=LSTKSSN(1)<<18
  SSNP1==RECORD(NEWSTK!X'40000')
  SSNP1=0
  SSNP1_LNB=NEWSTK
  SSNP1_PSR=X'00140001'    ;! PROG ERRORS UNMASKED
  SSNP1_PC=X'00080010'     ;! TO M-C CODE DIRLOADER
  SSNP1_SSR=X'01800000'        ;! ALL INTS ALLOWED
  SSNP1_SF=NEWSTK!X'14'     ;! 5 WORDS ON FROM LNB
  SSNP1_IT=0
  SSNP1_IC=MAXIT
  SSNP1_B=DIROUTPAD
  SSNP1_DR0=X'B1000000'    ;! DESCRIPTOR DESCRIPTOR TO ENTRY DESCRIPTOR
  SSNP1_DR1=X'000C0000'    ;!  I.E. START OF GLA
!-----------------------------------------------------------------------
! SET UP IO STATUS & ACCOUNTING RECORDS
  IOSTAT==RECORD(NEWSTK!X'40050')    ;! WORD 20 OF SSN+1
  IOSTAT=0
  ACNT==RECORD(NEWSTK!X'40068')    ;! WORD 26
  ACNT=0
  ICREVS==INTEGER(NEWSTK!X'40064')    ;! WORD 25
  ICREVS=999999
  ! DIRECTOR STACK ON INITIAL ENTRY
  PROC_STACK=NEWSTK
!-----------------------------------------------------------------------
! SET UP SIGNAL CONTEXT
  NEWSTK=LSTKSSN(2)<<18
  SSNP1==RECORD(NEWSTK!X'40000')
  SSNP1=0
  SSNP1_LNB=NEWSTK
  SSNP1_PSR=X'0014FF01'    ;! PROGRAM ERRORS MASKED
  SSNP1_PC=X'00080010'      ;! TO M-C CODE DIRLOADERRY POINT
  SSNP1_SSR=X'01800800'    ;! NO INSTRUCTION COUNTER INTS
  SSNP1_SF=NEWSTK!X'14'
  SSNP1_IT=0
  SSNP1_IC=MAXIT
  SSNP1_B=0        ;! ZERO DISTINGUISHES SIGNAL ENTRY !!!!!
  SSNP1_DR0=X'B1000000'
  SSNP1_DR1=X'000C0000'
!-----------------------------------------------------------------------
  ! INITIALISATIONS FOR DIRECTOR
  STRING(DIROUTPAD)=SUPID
  DIROUTP_SRCE=EPAGESIZE<<16!MAXBLOCK
  DIROUTP_P1=PROCESS
  STRING(ADDR(DIROUTP_P2))=PROC_USER
  DIROUTP_P4=ADDR(SIGOUTP)
  DIROUTP_P5=SCTI0
  DIROUTP_P6=0
  SIGOUTP_DEST=LSTLEN
  SIGOUTP_SRCE=ADDR(SST(0))
  SIGOUTP_P1=ADDR(CBTASL)
  SIGOUTP_P2=ADDR(CBTA(0))
  SIGOUTP_P3=ADDR(ACNT)
  SIGOUTP_P4=ADDR(ICREVS)
  SIGOUTP_P5=ADDR(IOSTAT)
!-----------------------------------------------------------------------
! REPLY TO SCHEDULE
  POUT=0
  POUT_DEST=X'30002'    ;! SCHEDULE/CREATED
  POUT_SRCE=ME
  POUT_P1=PROCESS
  PON(POUT)
!-----------------------------------------------------------------------
RETURN:! OUT BACK TO KERNEL
  KSSNP1P=KSSNP1    ;! KERNEL REACTIVATE CONTEXT
  *LSS_X'01800FFF'    ;! NO SYSTEM ERROR INTS
  *ST_(3)
  LSSNP1P=LSSNP1    ;! LOCAL CONTROLLER REACTIVATE CONTEXT
  ACTW3=KSTACK
  *LSS_(6)
  *ST_IC
  LCIC=LCIC+MAXIT-IC
  *LSS_(5)
  *ST_IT
  LCIT=LCIT+MAXIT-IT
  *ACT_ACTW0    ;! REACTIVATE BACK TO KERNEL
!-----------------------------------------------------------------------
ENTERI:*JLK_%TOS
! NORMAL LOCAL CALLS ENTER HERE
! PARAMETER RECORD P (GLOBAL)
ENTER:%IF KMON&1#0 %THEN PRINT STRING("LOCAL:") %AND PTREC(P)
  ->ACTIVITY(P_DEST&X'FFFF')
!-----------------------------------------------------------------------
ACTIVITY(1):! START RESIDENCE PERIOD
! P_P1=EPAGE LIMIT
! P_P2=RESIDENCE TIME LIMIT
! P_P3=ACTIVE EPAGES LIMIT
  EPLIM=P_P1
  RTLIM=P_P2
  PPLOAD=P_P3    ;! PARTIAL LOAD IF #0
  %IF PROCMON=PROCESS %THEN PRINT STRING(PROCID." EPLIM ". %C
    STRINT(EPLIM)." RTLIM ".STRINT(RTLIM)."
")
  ! SET UP SSN+1 CONTEXT ADDRESSES
  %CYCLE I=1,1,LSTKN
    %IF LSTKSSN(I)#0 %THEN LST(LSTKSSN(I)+1)=LST(1)+I*X'80'
  %REPEAT
  SSNP1==RECORD(PROC_STACK!X'40000')    ;! PROCESS CONTEXT
  %IF SSNP1_IT&X'FF800000'=0 %THEN LPIT=LPIT-SSNP1_IT %AND %C
    ACNT_LTIME=ACNT_LTIME-COM_ITINT*SSNP1_IT    ;! UNUSED TIME
  SSNP1_IT=TIMESLICE    ;! START NEW TIMESLICE
  LPIT=LPIT+TIMESLICE
  ACNT_LTIME=ACNT_LTIME+COM_ITINT*TIMESLICE
  XSTROBE=0
  PTEPS=0
  PLOAD=0
  HIGHSEG=2
  %IF SERV3_P<<1#0 %AND PROC_STACK#LSTKSSN(2)<<18 %THEN ->ASYNCH
PRELOAD:%IF PROCMON=PROCESS %THEN PRINT STRING(PROCID.STRPPLOAD(PPLOAD))
  WSN=EPN
  %IF WSN=0 %THEN ->PLPP    ;! NO PRELOAD
  ! PRELOAD - GET PAGE TABLES FIRST
  ABTX=ABTT
  %WHILE ABTX#255 %CYCLE
    ABT==ABTA(ABTX)
    %IF ABT_LINK=255 %THEN %EXIT
    VSSEG=ABT_SEG
    %IF LST(VSSEG)&X'0FFFFFF8'=0 %THEN %START    ;! NO PT YET
      SEGLEN=LST(VSSEG)>>42&X'FF'//EPAGESIZE+1
      %IF SEGLEN<=PTEPS %THEN ->NEWPTT
      %IF EPN=EPLIM %THEN %START    ;! PAGE TABLES NEED MORE SPACE
        I=ABTB    ;! THROW ONE OF THE WORKING SET AWAY
        %CYCLE
          %IF ABTA(I)_LINK#255 %THEN POPEP(ABTA(I)_LINK) %C
             %AND WSN=WSN-1 %AND %EXIT
          I=ABTA(I)_PREV
        %REPEAT
      %FINISH
      POUT_DEST=X'50001'    ;! LOW PRIORITY
      POUT_SRCE=ME!X'80000003'
      *LSS_(6)
      *ST_IC
      *LSS_(5)
      *ST_IT
      GET EPAGE(POUT)
      *LSS_(5)
      *ST_ITT
      *LSS_(6)
      *ST_ICC
      I=IT-ITT
      GETIT=GETIT+I
      LCIT=LCIT-I
      I=IC-ICC
      GETIC=GETIC+I
      LCIC=LCIC-I
      GETCALLN=GETCALLN+1
      %IF POUT_DEST#0 %THEN STOREX=POUT_P2 %AND ->ACT3 %ELSE ->RETURN
!-----------------------------------------------------------------------
ACTIVITY(3):! REPLY FROM GET EPAGE FOR PT
      STOREX=P_P2
ACT3: PUSHEP(PTP,STOREX)    ;! REMEMBER PAGE TABLE EPAGE STOREX
      PTAD=STORE(STOREX)_REALAD
      CLEAR EPAGE(PTAD)
      PTEPS=256
NEWPTT:! INSERT LST ENTRY TO POINT TO PAGE TABLE
      LST(VSSEG)=LST(VSSEG)!X'0000000080000001'!PTAD
      %IF VSSEG>HIGHSEG %THEN HIGHSEG=VSSEG
      PTEPS=PTEPS-SEGLEN
      PTAD=PTAD+((SEGLEN*EPAGESIZE+1)//2)<<3
    %FINISH
    ABTX=ABT_NEXT
  %REPEAT
  ! PRELOAD - PAGE TURNS
  ABTX=ABTT
  %WHILE ABTX#255 %CYCLE
    ABT==ABTA(ABTX)
    %IF ABT_LINK=255 %THEN %EXIT
    VSSEG=ABT_SEG
    STEP=ABT_STEP
    AMTX=ABT_AMTX
    EPL==ABT_LINK
    %WHILE EPL#255 %CYCLE
      EP==EPA(EPL)
      VSEPAGE=STEP+EP_X
      %IF PROCMON=PROCESS %THEN %START
        STRSEG=STRINT(VSSEG)
        PRINT STRING(" ".STRSEG."/".STRINT(VSEPAGE))
      %FINISH
      ACNT_PTURNS=ACNT_PTURNS+1
      POUT_DEST=X'40001'    ;! PAGETURN/PAGE-IN
      POUT_SRCE=ME!X'80000004'
      POUT_P1=AMTX<<16!EP_X
      POUT_P2=VSSEG<<16!VSEPAGE
      %IF LST(VSSEG)&X'0F00000000000000'=0 %THEN I=X'10001' %ELSE I=1
      POUT_P3=I    ;! LOW PRIORITY
      *LSS_(6)
      *ST_IC
      *LSS_(5)
      *ST_IT
      PAGETURN(POUT)
      *LSS_(5)
      *ST_ITT
      *LSS_(6)
      *ST_ICC
      I=IT-ITT
      PTIT=PTIT+I
      LCIT=LCIT-I
      I=IC-ICC
      PTIC=PTIC+I
      LCIC=LCIC-I
      PTCALLN=PTCALLN+1
      %IF POUT_DEST#0 %THEN %START
        J=X'80000001'!POUT_P2
        !PT==ARRAY(VIRTAD!LST(VSSEG)&X'0FFFFFF8' %C
        !  +VSEPAGE*EPAGESIZE<<2,PTF)
        !%CYCLE I=0,1,EPAGESIZE-1
        !  PT(I)=J+I<<10
        !%REPEAT
        ! ASSUMES EPAGESIZE=4
        I=VIRTAD!LST(VSSEG)&X'0FFFFFF8'+VSEPAGE*16
        *LXN_I
        *LSS_J
        *ST_(%XNB+0)
        *IAD_1024
        *ST_(%XNB+1)
        *IAD_1024
        *ST_(%XNB+2)
        *IAD_1024
        *ST_(%XNB+3)
        WSN=WSN-1
      %FINISH
      EPL==EP_LINK
    %REPEAT
    ABTX=ABT_NEXT
  %REPEAT
  %IF PROCMON=PROCESS %THEN NEWLINE
  %IF WSN=0 %THEN ->PLPP %ELSE ->PLWAIT
!-----------------------------------------------------------------------
ACTIVITY(4):! PRELOAD EPAGE HERE
  VSSEG=P_P1>>16
  VSEPAGE=P_P1&X'FFFF'
PEPH:J=X'80000001'!P_P2
  !PT==ARRAY(VIRTAD!LST(VSSEG)&X'0FFFFFF8'+VSEPAGE*EPAGESIZE<<2,PTF)
  !%CYCLE I=0,1,EPAGESIZE-1
  !  PT(I)=J+I<<10
  !%REPEAT
  ! ASSUMES EPAGESIZE=4
  I=VIRTAD!LST(VSSEG)&X'0FFFFFF8'+VSEPAGE*16
  *LXN_I
  *LSS_J
  *ST_(%XNB+0)
  *IAD_1024
  *ST_(%XNB+1)
  *IAD_1024
  *ST_(%XNB+2)
  *IAD_1024
  *ST_(%XNB+3)
  WSN=WSN-1
  %IF WSN#0 %THEN %START
PLWAIT:%IF SERV0_P>0 %THEN SUPPOFF(SERV0,P) %AND ->ENTER %ELSE ->RETURN
  %FINISH
PLPP:%IF PPLOAD=0 %THEN ->PLEND %ELSE ->PLWAIT
!-----------------------------------------------------------------------
ACTIVITY(5):! PRELOAD PAGE READ FAILURE
  VSSEG=P_P1>>16
  VSEPAGE=P_P1&X'FFFF'
  POUT_DEST=LSN3<<16    ;! SEND RECURSIVE ASYNCH MESSAGE
  POUT_P1=1
  POUT_P2=VSSEG<<18!VSEPAGE*EPAGESIZE<<10
  PON(POUT)
  ->PEPH
!-----------------------------------------------------------------------
ACTIVITY(7):! REST OF ALLOCATION READY
  PPLOAD=0
  %IF WSN#0 %THEN ->PLWAIT
PLEND:PLOAD=1
  MPLEVEL=MPLEVEL+1
  UPDISP(PROCESS,11,"R1")
  RTN=0    ;! TIMESLICES USED SO FAR
  %IF SUSP#0 %THEN ->DIRPONREPLY
ACT:%IF KERNELQ#0 %THEN ->ONFRUNQ    ;! DO ANY KERNEL SERVICES
  LPN=LPN+1    ;! NO OF ACTIVATIONS TO PROCESSES
  ACTW3=PROC_STACK
  *LSS_(6)
  *ST_IC
  LCIC=LCIC+MAXIT-IC
  *LSS_(5)
  *ST_IT
  LCIT=LCIT+MAXIT-IT
  *ACT_ACTW0
!-----------------------------------------------------------------------
ACTIVITY(2):! CONTINUE WITH CORE RESIDENCE
ACTIVATE:! CHECK ASYNCH MESSAGE
  %IF SERV3_P<<1=0 %OR PROC_STACK=LSTKSSN(2)<<18 %THEN ->ACT
!-----------------------------------------------------------------------
ASYNCH:! ASYNCHRONOUS MESSAGE
  SUPPOFF(SERV3,P)
  %IF PROCMON=PROCESS %THEN PRINT STRING(PROCID."ASYNCH:") %C
    %AND PTREC(P)
  I=P_DEST&X'FFFF'
  %IF I=0 %THEN ->ASYN0(P_P1)
  %IF I=X'FFFF' %THEN PRINT STRING(PROCID. %C
  "ASYNCH PROCESS TERMINATION
") %AND ->DIROUT0
  %UNLESS I=1 %THEN ->SIGINT
  INTMESS=STRING(ADDR(P_P3))
  %IF LENGTH(INTMESS)=1 %THEN %START
    %IF P_P2>=0 %AND IOSTAT_IAD#P_P2 %THEN IOSTAT_IAD=P_P2
SIGINT:SIGOUTP<-P
    SIGOUTP_TYPE=3
    SIGOUTP_SSN=CURSSN
    SIGOUTP_SSNAD=PROC_STACK
    SIGOUTP_SUSP=SUSP    ;! PRESERVE SUSPEND STATUS
    SUSP=0
    NEWSTK=LSTKSSN(2)<<18
    INTEGER(NEWSTK!X'40014')=INTEGER(PROC_STACK!X'40014')    ;! SWOP IT
    PROC_STACK=NEWSTK
    SSNP1==RECORD(NEWSTK!X'40000')
    %IF SSNP1_LNB>>18#NEWSTK>>18 %OR SSNP1_LNB>>18#SSNP1_SF>>18 %C
      %OR SSNP1_PSR&3=0 %THEN PRINT STRING("
ACTIVATE CONTEXT INVALID") %AND ->DIROUT0
    %IF PLOAD=0 %THEN ->PRELOAD %ELSE ->ACTIVATE
  %FINISH %ELSE %START
    %IF LENGTH(INTMESS)>1 %THEN IOSTAT_INTMESS=INTMESS
    %IF P_P2>=0 %AND IOSTAT_IAD#P_P2 %THEN %START
      IOSTAT_IAD=P_P2
      %IF SUSP<0 %THEN SUSP=0
    %FINISH
RESUSP:%IF SERV3_P<<1#0 %THEN ->ASYNCH
    %IF SUSP=0 %THEN %START
      %IF PLOAD=0 %THEN ->PRELOAD %ELSE ->ACT
    %FINISH %ELSE %START
      ! AVOID RESUSPENDING IF UNNECESSARY
      %IF SUSP&X'7FFFFFFF'<=LOCSN3 %THEN %START
        SERV==SERVA(SUSP)
        %IF SERV_P<<1#0 %THEN %START
          %IF PLOAD=0 %THEN ->PRELOAD %ELSE ->DPR    ;!  DIRPONREPLY
        %FINISH
      %FINISH
      %IF PLOAD#0 %THEN WORKSET(0) %ELSE %START
        MPLEVEL=MPLEVEL+1
        %IF PPLOAD#0 %THEN %START
          POUT_DEST=X'3000D'    ;! DO NOT WANT REST OF ALLOCATION
          POUT_P1=PROCESS
          SCHEDULE(POUT)
          %IF POUT_DEST=0 %THEN SUPPOFF(SERV0,POUT)  ;! ALREADY ON WAY
          PPLOAD=0
        %FINISH
      %FINISH
      SRCE=SUSP
      ->SUSPEND
    %FINISH
  %FINISH
!-----------------------------------------------------------------------
ASYN0(1):! PAGE TURN READ FAILURE DURING PRELOAD
  PEPARM=P_P2!18
  ->PE    ;! PLOAD=1 !
!-----------------------------------------------------------------------
ASYN0(2):! RELEASE ACTIVE BLOCKS
  I=P_P2    ;! NO OF EPAGES TO BE RELEASED
  %UNTIL I<=0 %CYCLE
    ABT==ABTA(ABTB)
    %IF PLOAD=0 %THEN %START    ;! NOT PRE-LOADED YET
      %WHILE ABT_LINK#255 %THEN POPEP(ABT_LINK)
    %FINISH
    I=I-CBTA(ABT_CBTX)_TAGS&X'F'-1    ;! ACTIVE BLOCK LENGTH
    ABTOUT(ABTB)
  %REPEAT
  ->RESUSP
!-----------------------------------------------------------------------
VSERRI:*JLK_%TOS
! VIRTUAL STORE INTERRUPTS ENTER HERE
  *LSS_%TOS
  *LSS_%TOS        ;! PARAMETER
  *ST_VSPARM
  %IF PROCMON=PROCESS %THEN VSINT
  %IF VSPARM<0 %THEN PEPARM=9 %AND ->PE
  VSSEG=VSPARM>>18
  VSEPAGE=(VSPARM>>10&X'FF')//EPAGESIZE
  ->VSCAUSE(VSPARM&7)
!-----------------------------------------------------------------------
VSCAUSE(0):VSCAUSE(2):VSCAUSE(3):VSE:! VS ERRORS
  SIGOUTP_P1=VSPARM
  SIGOUTP_P2=PROC_STACK
  SIGOUTP_TYPE=1
  SIGOUTP_SSN=CURSSN
  SIGOUTP_SSNAD=PROC_STACK
  SIGOUTP_SUSP=0
  NEWSTK=LSTKSSN(2)<<18
  %IF PROC_STACK=NEWSTK %THEN %START
    VSINT
    PRINT STRING("VS ERROR ON SIGNAL STACK
")
    ->DIROUT0
  %FINISH
  INTEGER(NEWSTK!X'40014')=INTEGER(PROC_STACK!X'40014')
  PROC_STACK=NEWSTK
  SSNP1==RECORD(NEWSTK!X'40000')
  %IF SSNP1_LNB>>18#NEWSTK>>18 %OR SSNP1_LNB>>18#SSNP1_SF>>18 %C
    %OR SSNP1_PSR&3=0 %THEN PRINT STRING("
ACTIVATE CONTEXT INVALID") %AND ->DIROUT0
  ->ACTIVATE
!-----------------------------------------------------------------------
VSCAUSE(1):! SEGMENT NOT AVAILABLE
  %IF SST(VSSEG)=255 %THEN ->VSE    ;! NO CONNECTION
  SEGLEN=LST(VSSEG)>>42&X'FF'//EPAGESIZE+1
  ! FUDGE A PAGE NO>LIMIT ERROR IF NECESSARY
  %IF VSEPAGE>=SEGLEN %THEN VSPARM=VSPARM!3 %AND ->VSE
  %IF SEGLEN<=PTEPS %THEN ->NEWPT
  %IF EPN>=EPLIM-1 %THEN ->NOPAGES    ;! NEED 2 EPAGES !
  POUT_DEST=X'50000'
  POUT_SRCE=ME!X'80000009'
  *LSS_(6)
  *ST_IC
  *LSS_(5)
  *ST_IT
  GET EPAGE(POUT)
  *LSS_(5)
  *ST_ITT
  *LSS_(6)
  *ST_ICC
  I=IT-ITT
  GETIT=GETIT+I
  LCIT=LCIT-I
  I=IC-ICC
  GETIC=GETIC+I
  LCIC=LCIC-I
  GETCALLN=GETCALLN+1
  %IF POUT_DEST#0 %THEN STOREX=POUT_P2 %AND ->ACT9
  ->RETURN
!-----------------------------------------------------------------------
ACTIVITY(9):! REPLY FROM GET EPAGE FOR PT
  STOREX=P_P2
  %IF STOREX=0 %THEN ->DEAD    ;! DEADLY EMBRACE RECOVERY
ACT9:PUSHEP(PTP,STOREX)    ;! REMEMBER PAGE TABLE EPAGE STOREX
  PTAD=STORE(STOREX)_REALAD
  CLEAR EPAGE(PTAD)
  PTEPS=256
NEWPT:LST(VSSEG)=LST(VSSEG)!X'0000000080000001'!PTAD
  %IF VSSEG>HIGHSEG %THEN HIGHSEG=VSSEG
  PTEPS=PTEPS-SEGLEN
  PTAD=PTAD+((SEGLEN*EPAGESIZE+1)//2)<<3
! RUN STRAIGHT ON INTO A VSCAUSE(4)
!-----------------------------------------------------------------------
VSCAUSE(4):! PAGE NOT AVAILABLE
  %IF EPN>=EPLIM %THEN ->NOPAGES
  CBTP=SST(VSSEG)
  CBT==CBTA(CBTP)
  EPX=VSEPAGE
  %WHILE EPX>CBT_TAGS&X'F' %CYCLE
    CBTP=CBT_LINK
    EPX=EPX-CBT_TAGS&X'F'-1
    CBT==CBTA(CBTP)
  %REPEAT
  %IF CBT_TAGS&X'20'=0 %THEN %START    ;! NO ABT SLOT ALLOCATED YET
    %IF ABTN=MAXABT %THEN MAXABTN=MAXABTN+1 %AND ABTOUT(ABTB)
    !GET RID OF LRU ACTIVE BLOCK
    POUT_DEST=X'80001'    ;! GET AMTX
    POUT_SRCE=0
    POUT_P1=PROCESS
    POUT_P2=CBT_DA
    POUT_P3=CBT_ABTX<<24!CBT_MASK2<<16!CBT_TAGS
    %IF PROCMON=PROCESS %THEN %START
      PRINT STRING(PROCID."GET AMTX ".STRHEX(POUT_P2))
      PRINT STRING(" ".STRHEX(POUT_P3))
    %FINISH
    *LSS_(6)
    *ST_IC
    *LSS_(5)
    *ST_IT
    ACTIVE MEM(POUT)
    *LSS_(5)
    *ST_ITT
    *LSS_(6)
    *ST_ICC
    I=IT-ITT
    AMIT=AMIT+I
    LCIT=LCIT-I
    I=IC-ICC
    AMIC=AMIC+I
    LCIC=LCIC-I
    AMCALLN=AMCALLN+1
    AMTX=POUT_P2
    %IF PROCMON=PROCESS %THEN PRINT STRING(" ".STRHEX(AMTX)."
")
    %IF AMTX<=0 %THEN ->AMTXSW(AMTX)
    %IF POUT_P3>0 %THEN %START    ;! OVER ACTIVE MEMORY LIMIT
      I=POUT_P3
      %UNTIL I<=0 %CYCLE
        I=I-CBTA(ABTA(ABTB)_CBTX)_TAGS&X'F'-1
        ABTOUT(ABTB)
      %REPEAT
    %FINISH
    ! PUSHDOWN ABT
    ABTX=ABTASL
    ABT==ABTA(ABTX)
    ABTASL=ABT_LINK
    ABT_LINK=255
    ABT_AMTX=AMTX
    ABT_CBTX=CBTP
    ABT_SEG=VSSEG
    ABT_STEP=VSEPAGE-EPX
    ABT_PREV=255
    ABT_NEXT=ABTT
    %IF ABTT=255 %THEN ABTB=ABTX %ELSE ABTA(ABTT)_PREV=ABTX
    ABTT=ABTX
    ABTN=ABTN+1
    CBT_ABTX=ABTX
    CBT_TAGS=CBT_TAGS!X'20'
  %FINISH %ELSE ABT==ABTA(CBT_ABTX) %AND AMTX=ABT_AMTX
  POUT_DEST=X'40001'    ;! PAGETURN/PAGE-IN
  POUT_SRCE=ME!X'8000000A'    ;! REPLY TO ACTIVITY 10
  POUT_P1=AMTX<<16!EPX
  ! P2 : IDENT NOT USED
  %IF LST(VSSEG)&X'0F00000000000000'=0 %THEN I=X'10000' %ELSE I=0
  POUT_P3=I    ;! WRITE ?/ HIGH PRIORITY
  *LSS_(6)
  *ST_IC
  *LSS_(5)
  *ST_IT
  PAGETURN(POUT)
  *LSS_(5)
  *ST_ITT
  *LSS_(6)
  *ST_ICC
  I=IT-ITT
  PTIT=PTIT+I
  LCIT=LCIT-I
  I=IC-ICC
  PTIC=PTIC+I
  LCIC=LCIC-I
  PTCALLN=PTCALLN+1
  %IF POUT_DEST#0 %THEN J=X'80000001'!POUT_P2 %AND ->ACT10
  ->RETURN
!-----------------------------------------------------------------------
AMTXSW(0):! CHANGE BLOCK SIZE IN SITU ?
DELAY:WAIT(2,1)    ;! TRY AGAIN IN 1 SEC
  ->RETURN
AMTXSW(-1):! NO AMT CELLS AVAILABLE
  %IF ABTB=255 %THEN ->DELAY    ;! NO ACTIVE BLOCKS TO THROW AWAY
  ABTOUT(ABTB)
  ->ACTIVATE
AMTXSW(-2):! NOT ENOUGH GARBAGE
  %WHILE ABTB#255 %THEN ABTOUT(ABTB)
  ->DELAY
AMTXSW(-3):! CHANGE BLOCK SIZE WHEN STILL IN USE
  PEPARM=19
  ->PE
!-----------------------------------------------------------------------
ACTIVITY(10):! EPAGE HERE
! P_P1=RUBBISH IDENT
! P_P2=STORE(EPAGE)_REALAD
! VSSEG & VSEPAGE STILL INTACT !!
EPH:J=X'80000001'!P_P2
ACT10:PUSHEP(ABT_LINK,EPX)
  ACNT_PTURNS=ACNT_PTURNS+1
  !PT==ARRAY(VIRTAD!LST(VSSEG)&X'0FFFFFF8'+VSEPAGE*EPAGESIZE<<2,PTF)
  !%CYCLE I=0,1,EPAGESIZE-1
  !  PT(I)=J+I<<10
  !%REPEAT
  ! ASSUMES EPAGESIZE=4
  I=VIRTAD!LST(VSSEG)&X'0FFFFFF8'+VSEPAGE*16
  *LXN_I
  *LSS_J
  *ST_(%XNB+0)
  *IAD_1024
  *ST_(%XNB+1)
  *IAD_1024
  *ST_(%XNB+2)
  *IAD_1024
  *ST_(%XNB+3)
  ->ACTIVATE
!--------------------------------------------
ACTIVITY(11):! PAGE READ FAILURE
  %IF P_P3<0 %THEN ->DEAD
  POUT_DEST=LSN3<<16
  POUT_P1=1
  POUT_P2=VSSEG<<18!VSEPAGE*EPAGESIZE<<10
  PON(POUT)
  ->EPH
!-----------------------------------------------------------------------
! DEADLOCK RECOVERY
DEAD:WORKSET(EPN-8)    ;! REDUCE WORKING SET A BIT
  POUT_DEST=X'3000E'
  POUT_SRCE=ME!1
  POUT_P1=PROCESS
  PON(POUT)
  ->RETURN
!-----------------------------------------------------------------------
ITIMERI:*JLK_%TOS
! INTERVAL TIMER INTERRUPTS ENTER HERE
  *LSS_%TOS ; *LSS_%TOS
  %IF PROCMON=PROCESS %THEN PRINT STRING(PROCID."TIME-SLICE
")
  RTN=RTN+1
  %IF RTN=1 %THEN PROC_RUNQ=2 %AND UPDISP(PROCESS,11,"R2") %ELSE %START
    %IF RTN=RTLIM %THEN %START
      %IF PROCMON=PROCESS %THEN PRINT STRING(PROCID."RESIDENCE TIME
")
      POUT_DEST=X'3000B'    ;! MORE TIME ON THE FLY ?
      POUT_SRCE=0
      POUT_P1=PROCESS
      POUT_P2=EPN
      SCHEDULE(POUT)
      %IF POUT_P1=0 %THEN %START
        I=EPN
        WORKSET(EPLIM)
        POUT_DEST=X'30004'    ;! OUT OF TIME
        POUT_SRCE=ME!1
        POUT_P1=PROCESS
        POUT_P2=I    ;! EPAGES USED SO FAR
        PON(POUT)
        ->RETURN
      %FINISH
      EPLIM=POUT_P1
      RTLIM=POUT_P2
      %IF PROCMON=PROCESS %THEN PRINT STRING(PROCID." EPLIM ". %C
        STRINT(EPLIM)." RTLIM ".STRINT(RTLIM)." (ON FLY)
")
      RTN=0
    %FINISH %ELSE %START
      %IF (RTN-4)&7=0 %THEN STROBE(0)    ;! 4,12,20,28
    %FINISH
  %FINISH
  SSNP1==RECORD(PROC_STACK!X'40000')
  SSNP1_IT=TIMESLICE
  LPIT=LPIT+TIMESLICE
  ACNT_LTIME=ACNT_LTIME+COM_ITINT*TIMESLICE
  POUT_DEST=ME!2
  PON(POUT)
  ->RETURN
!-----------------------------------------------------------------------
ONFRUNQ:! PUT ON FRONT OF RUNQ
  POUT_DEST=ME!2
ONFRUNQA:I=RUNQ
  PON(POUT)
  %UNLESS I=0 %THEN RUNQ=I
  ->RETURN
!-----------------------------------------------------------------------
NOPAGES:%IF PROCMON=PROCESS %THEN PRINT STRING(PROCID."EPAGES
")
  %IF XSTROBE=0 %THEN %START
    STROBE(1)
    %IF EPN<EPLIM %THEN ->ACTIVATE    ;! GOT SOME BACK !
  %FINISH
  %IF EPLIM=MAXEPAGES %THEN WORKSET(EPLIM//2) %ELSE %START
    POUT_DEST=X'3000A'    ;! MORE EPAGES ON THE FLY ?
    POUT_SRCE=0
    POUT_P1=PROCESS
    POUT_P2=RTN
    SCHEDULE(POUT)
    %IF POUT_P1#0 %THEN %START
      EPLIM=POUT_P1
      RTLIM=POUT_P2
      %IF PROCMON=PROCESS %THEN PRINT STRING(PROCID." EPLIM ". %C
        STRINT(EPLIM)." RTLIM ".STRINT(RTLIM)." (ON FLY)
")
      RTN=0
      ->ACTIVATE
    %FINISH
    WORKSET(EPLIM)
  %FINISH
  POUT_DEST=X'30003'    ;! OUT OF EPAGES
  POUT_SRCE=ME!1
  POUT_P1=PROCESS
  POUT_P2=RTN    ;! TIMESLICES USED SO FAR
  PON(POUT)
  ->RETURN
!-----------------------------------------------------------------------
PROGERRI:*JLK_%TOS
! PROGRAM ERROR INTERRUPTS ENTER HERE
  *LSS_%TOS
  *LSS_%TOS
  *ST_PEPARM
PE:%IF PROCMON=PROCESS %THEN PROGERR
  SIGOUTP_P1=PEPARM
  SIGOUTP_P2=PROC_STACK
  SIGOUTP_TYPE=2
  SIGOUTP_SSN=CURSSN
  SIGOUTP_SSNAD=PROC_STACK
  SIGOUTP_SUSP=0
  NEWSTK=LSTKSSN(2)<<18
  %IF PROC_STACK=NEWSTK %THEN %START
    PROGERR
    PRINT STRING("PROGRAM ERROR ON SIGNAL STACK
")
    ->DIROUT0
  %FINISH
  INTEGER(NEWSTK!X'40014')=INTEGER(PROC_STACK!X'40014')
  PROC_STACK=NEWSTK
  SSNP1==RECORD(NEWSTK!X'40000')
  %IF SSNP1_LNB>>18#NEWSTK>>18 %OR SSNP1_LNB>>18#SSNP1_SF>>18 %C
    %OR SSNP1_PSR&3=0 %THEN PRINT STRING("
ACTIVATE CONTEXT INVALID") %AND ->DIROUT0
  ->ACTIVATE
!-----------------------------------------------------------------------
OUTI:*JLK_%TOS
! LOCAL OUTS ENTER HERE
  *LSS_%TOS
  *ST_J
  *LSS_%TOS
  *ST_I
  %IF 0<=I<=MAXDIROUT %THEN %START
    %IF INTEGER(J!X'40004')>>20&X'F'<=MAXOUTACR(I) %THEN %START
      %IF PROCMON=PROCESS %AND I#1 %THEN PRINT STRING(PROCID. %C
        "DIROUT".STRINT(I).":") %AND PTREC(DIROUTP)
      ->DIROUT(I)
    %FINISH
  %FINISH
FREACT:DIROUTP_DEST=-1    ;! OUT INVALID
  ->ACTIVATE
!-----------------------------------------------------------------------
DIROUT0:! CREATE DUMMY STOPPING MESSAGE TO DIRECT
  DIROUTP_P1=PROCESS
  DIROUTP_P2=PROC_INCAR
  STRING(ADDR(DIROUTP_P3))=PROC_USER
DIROUT(0):%IF PROCMON=PROCESS %THEN PRINT STRING(PROCID. %C
  "STOPPED
")
  %WHILE ABTT#255 %THEN ABTOUT(ABTT)    ;! RETURN ALL ABTS
  RETURN PTS
  DIROUTP_DEST=(LOCSN1+1)<<16!X'17'    ;! DIRECT=PROCESS 1
  ! X'17' NOT YET PARAMETERISED !!!
  PON(DIROUTP)
  POUT_DEST=X'30008'    ;! SCHEDULE/DESTROY
  POUT_SRCE=ME
  POUT_P1=PROCESS
  PON(POUT)
  ->RETURN
!-----------------------------------------------------------------------
DIROUT(1):! PRINT STRING FOR DIRECTOR
  %IF DIROUTP_DEST>>24>31 %THEN ->FREACT
  PRINT STRING(STRING(ADDR(DIROUTP_DEST)))
  DIROUTP_DEST=0
  ->ACTIVATE
!-----------------------------------------------------------------------
DIROUT(2):! INPUT REQUEST MESSAGE
  %IF DIROUTP_P3#IOSTAT_IAD %THEN ->ACTIVATE    ;! INPUT ALREADY HERE
  POUT=DIROUTP
  POUT_DEST=X'00370006'
  POUT_SRCE=LSN3<<16!1
  PON(POUT)
  SRCE=X'80000000'!LSN3    ;! TOP BIT SET FOR INPUT WAIT
  ->SUSPWS
!-----------------------------------------------------------------------
DIROUT(3):! DISCONNECT SEGMENT, DIROUTP_P1=SEG, P2#0 DESTROY
  VSSEG=DIROUTP_P1
  ->FREACT %UNLESS 0<=VSSEG<LSTLEN
  CBTX=SST(VSSEG)
  ->FREACT %IF CBTX=255
  %IF DIROUTP_P2#0 %THEN ABTDESTROY=1
  %UNTIL CBTX=255 %CYCLE
    CBT==CBTA(CBTX)
    %IF CBT_TAGS&X'20'#0 %THEN ABTOUT(CBT_ABTX)
    CBTX=CBT_LINK
  %REPEAT
  ABTDESTROY=0
  LST(VSSEG)=LST(VSSEG)&X'FFFFFFFF00000000'
  DIROUTP_DEST=0
  ->ACTIVATE
!-----------------------------------------------------------------------
DIROUT(4):! DISCONNECT BLOCK, DIROUTP_P1=CBTX
  CBTX=DIROUTP_P1
  ->FREACT %UNLESS 0<=CBTX<=254
  CBT==CBTA(CBTX)
  ->FREACT %UNLESS CBT_TAGS&X'20'#0
  ABTOUT(CBT_ABTX)
  DIROUTP_DEST=0
  ->ACTIVATE
!-----------------------------------------------------------------------
DIROUT(5):! PON FOR DIRECTOR
  SRCE=PROCESS+LOCSN1
  ! USE BYTEINTEGER TO AVOID UNASSIGNED CHECKS
DIRPONS:DEST=BYTEINTEGER(DIROUTPAD)<<8!BYTEINTEGER(DIROUTPAD+1)
  %IF DEST=X'FFFF' %THEN %START    ;! RELAY MESSAGE
    %IF FIND PROCESS=0 %THEN ->ACTIVATE    ;! NOT LOGGED ON
  %FINISH %ELSE %START
    %UNLESS 0<=DEST<=MAXSERV %THEN ->FREACT
  %FINISH
  %IF DEST#0 %THEN %START
    I=BYTE INTEGER(DIROUTPAD+6)<<8!BYTE INTEGER(DIROUTPAD+7)
    %IF SRCE=LSN3 %AND (I=0 %OR I=X'FFFF') %THEN ->FREACT
    DIROUTP_SRCE=SRCE<<16!I
    PON(DIROUTP)
  %FINISH
  POUT_DEST=ME!12
  ->ONFRUNQA
!-----------------------------------------------------------------------
ACTIVITY(12):! RE-ENTRY AFTER DIRECTOR PON
  %IF SRCE>LOCSN3 %THEN %START
    %IF SERV3_P<<1#0 %THEN ->ASYNCH
  %FINISH %ELSE %START
    SERV==SERVA(SRCE)
    %IF SERV_P<<1#0 %THEN SUPPOFF(SERV,DIROUTP) %AND ->ACTIVATE
  %FINISH
SUSPWS:WORKSET(EPLIM)
SUSPEND:%IF PROCMON=PROCESS %THEN PRINT STRING(PROCID."SUSPENDED
")
  POUT_DEST=X'30005'    ;! SUSPEND
  POUT_SRCE=SRCE&X'7FFFFFFF'    ;! TO UNINHIBIT SRCE IN "SCHEDULE"
  POUT_P1=PROCESS
  POUT_P2=PROC_WSN    ;! EPAGES USED SO FAR
  POUT_P3=RTN    ;! TIMESLICES USED SO FAR
  PON(POUT)
  SUSP=SRCE
  %IF PROC_STACK=LSTKSSN(2)<<18 %THEN PRINT STRING("
SUSPENDED WHILE IN SIGNAL STATE ?") %AND ->DIROUT0
  ->RETURN
!-----------------------------------------------------------------------
DIRPONREPLY:! REPLY HAS WOKEN PROCESS UP
  SERV==SERVA(SUSP)
DPR:SUPPOFF(SERV,DIROUTP)
  %IF PROCMON=PROCESS %THEN PRINT STRING(PROCID."DIRPONREPLY:") %C
    %AND PTREC(DIROUTP)
  SUSP=0
  ->ACTIVATE
!-----------------------------------------------------------------------
DIROUT(6):! PON & CONTINUE
  SRCE=PROCESS+LOCSN1
DIRPONC:DEST=BYTEINTEGER(DIROUTPAD)<<8!BYTEINTEGER(DIROUTPAD+1)
  %IF DEST=X'FFFF' %THEN %START
    %IF FIND PROCESS=0 %THEN ->ACTIVATE
  %FINISH %ELSE %START
    %UNLESS 0<=DEST<=MAXSERV %THEN ->FREACT
  %FINISH
  %IF DEST#0 %THEN %START
    %IF DIROUTP_DEST=X'00810017' %THEN ->ACTIVATE    ;! THROW AWAY
    I=BYTE INTEGER(DIROUTPAD+6)<<8!BYTE INTEGER(DIROUTPAD+7)
    %IF SRCE=LSN3 %AND (I=0 %OR I=X'FFFF') %THEN ->FREACT
    DIROUTP_SRCE=SRCE<<16!I
    PON(DIROUTP)
    ->ONFRUNQ
  %FINISH
  ! TOFF
  %IF SRCE>LOCSN3 %THEN %START
    %IF SERV3_P<<1#0 %THEN ->ASYNCH %ELSE DIROUTP_DEST=0
  %FINISH %ELSE %START
    SERV==SERVA(SRCE)
    %IF SERV_P<<1#0 %THEN SUPPOFF(SERV,DIROUTP) %ELSE DIROUTP_DEST=0
  %FINISH
  ->ACTIVATE
!----------------------------------------------------------------------
DIROUT(7):! ALTERNATE PON FOR DIRECTOR
  SRCE=PROCESS+LOCSN2
  ->DIRPONS
!-----------------------------------------------------------------------
DIROUT(8):! ALT PON & CONTINUE
  SRCE=PROCESS+LOCSN2
  ->DIRPONC
!-----------------------------------------------------------------------
DIROUT(9):! ASYNCHRONOUS REPLY PON & SUSPEND
  SRCE=LSN3
  ->DIRPONS
!-----------------------------------------------------------------------
DIROUT(10):! ASYNCHRONOUS REPLY PON & CONTINUE
  SRCE=LSN3
  ->DIRPONC
!-----------------------------------------------------------------------
DIROUT(11):! PON & WAIT
PONWAIT:DEST=BYTE INTEGER(DIROUTPAD)<<8!BYTE INTEGER(DIROUTPAD+1)
  %UNLESS 0<DEST<=LOCSN0 %THEN ->FREACT
  SRCE=DIROUTP_SRCE
  DIROUTP_SRCE=ME!13
  PON(DIROUTP)
  ->RETURN    ;! WAIT IN STORE FOR REPLY
!-----------------------------------------------------------------------
ACTIVITY(13):! PON & WAIT REPLY
  DIROUTP=P
  DIROUTP_DEST=SRCE
  %IF PROCMON=PROCESS %THEN PRINT STRING("PON&WAITREPLY:") %C
    %AND PTREC(DIROUTP)
  ->ACTIVATE
!-----------------------------------------------------------------------
DIROUT(12):! NOMINATE STACK SSN
  I=DIROUTP_P1    ;! STACK NO
  J=DIROUTP_P2    ;! SSN
  %UNLESS 1<=I<=LSTKN %AND LSTKSSN(I)=0 %AND 4<=J<LSTLEN %AND J&1=0 %C
    %AND SST(J!1)=255 %THEN ->FREACT
  LSTKSSN(I)=J
  LST(J!1)=LST(1)+I*X'80'
  DIROUTP_DEST=0
  ->ACTIVATE
!-----------------------------------------------------------------------
DIROUT(13):! DENOMINATE STACK
  I=DIROUTP_P1    ;! STACK NO
  %UNLESS 1<=I<=LSTKN %THEN ->FREACT
  J=LSTKSSN(I)    ;! SSN
  %UNLESS 0#J#PROC_STACK>>18 %THEN ->FREACT
  LST(J!1)=X'1FF3FF8000000000'
  LSTKSSN(I)=0
  DIROUTP_DEST=0
  ->ACTIVATE
!-----------------------------------------------------------------------
DIROUT(14):! SWOP STACK
  I=DIROUTP_P1    ;! NEW LOCAL STACK NO
  K=DIROUTP_P2
SWOPST:%UNLESS 1<=I<=LSTKN %THEN ->FREACT
  J=LSTKSSN(I)
  %UNLESS 0#J#PROC_STACK>>18 %THEN ->FREACT
  SSNP1==RECORD((J!1)<<18)
  %IF SSNP1_LNB>>18#J %OR SSNP1_LNB>>18#SSNP1_SF>>18 %OR %C
    SSNP1_PSR&3=0 %THEN ->FREACT
  NEWSTK=J<<18
  INTEGER(NEWSTK!X'40014')=INTEGER(PROC_STACK!X'40014')    ;! SWOP IT
  PROC_STACK=NEWSTK
  SUSP=K    ;! GO BACK TO CORRECT SUSPEND STATUS
  ->RESUSP
!-----------------------------------------------------------------------
DIROUT(15):! SYSTEM CALL ERROR (AFTER STACK SWITCH)
  PEPARM=INTEGER(PROC_STACK!X'40020')<<6!16    ;! SUB-IDENT. IN OLD XNB
  ->PE
!-----------------------------------------------------------------------
DIROUT(16):! INSTRUCTION COUNTER INTERRUPT (AFTER STACK SWITCH)
  PEPARM=17    ;! TREAT AS PROGRAM ERROR
  ->PE
!-----------------------------------------------------------------------
DIROUT(17):! CHECK FOR ACTIVE BLOCKS ON FILE DESTROY
  J=0
  PA==DIROUTP
  %CYCLE I=0,1,7
RECHECK:K=PA_P(I)
    %IF K=0 %THEN %EXIT
    POUT_DEST=X'80005'
    POUT_P1=K
    ACTIVE MEM(POUT)
    %IF POUT_DEST#0 %THEN %START
      %IF J=10 %THEN MONITOR("BLOCK PAGE-OUTS ?")
      WAIT(14,1)
      ->RETURN
    %FINISH
  %REPEAT
  DIROUTP_DEST=0
  ->ACTIVATE
!-----------------------------------------------------------------------
ACTIVITY(14):! REPLY FROM DESTROY CHECK
  J=J+1
  ->RECHECK
!-----------------------------------------------------------------------
DIROUT(18):! CHECK & FORWARD PRIVATE I-O REQUEST
! P5=WRIT<<31!ACR<<24!LEN
! P6=ADDRESS
  %CYCLE I=DIROUTP_P6>>10,1,(DIROUTP_P6+DIROUTP_P5&X'FFFFFF'-1)>>10
    PT==ARRAY(VIRTAD!LST(I>>8)&X'0FFFFFF8',PTF)
    J=I&X'FF'    ;! PAGE NO
    %IF PT(J)&1=0 %THEN ->FREACT    ;! F BIT NOT PRESENT
    PT(J)=PT(J)!DIROUTP_P5>>31<<28    ;! WRITTEN MARKER
  %REPEAT
  DIROUTP_P5=ACTW0!DIROUTP_P5<<4>>28    ;! LSTBR!ACR
  DIROUTP_P6=ACTW1
  ->PONWAIT
!-------------------------------------------------------------------
DIROUT(19):! SWOP STACK FROM SIGNAL STACK
  I=SIGOUTP_P1
  K=SIGOUTP_P2
  ->SWOPST
!-----------------------------------------------------------------------
EPI:*JLK_%TOS
! EVENT PENDING INTERRUPTS ENTER HERE - FROM 'SYSTEM ERROR'
  PEPARM=20
  ->PE
!-----------------------------------------------------------------------
ICOUNTERI:*JLK_%TOS
! INSTRUCTION COUNTER INTERRUPTS ENTER HERE - STACK NOT SWITCHED YET !!!
! %IF ICREVS=0 %THEN PROGERR(17)
!  ICREVS=ICREVS-1
  *STXN_%TOS    ;! SAVE XNB
  *LXN_X'140064'    ;! ADDR(ICREVS)
  *SLB_(%XNB+0)    ;! SAVE B & LOAD ICREVS
  *CPB_0
  *JCC_8,<OUT16>    ;! JUMP IF B=0
  *SBB_1
  *STB_(%XNB+0)
  *LB_X'7FFFFF'    ;! RESET IC
  *STB_(6)
  *LB_%TOS    ;! RESTORE B & XNB
  *LXN_%TOS
  *EXIT_-1    ;! TO RESTORE PM,CC,ACS ETC.
OUT16:*LB_%TOS    ;! RESTORE B & XNB
  *LXN_%TOS
  *OUT_16    ;! TO SWITCH STACKS
! SIGNAL MECHANISM INVOKED AT DIROUT(16):
!-----------------------------------------------------------------------
%ROUTINE CONNECT(%INTEGER SEG,DA,LEN,ACC)
! FILE ASSUMED "NEW" IF NOT EXECUTE ACCESS !!
%LONGINTEGER LL
%INTEGER CELL,L,X
  SST(SEG)=CBTASL
  LL=X'40000380'!ACC<<20!(LEN*EPAGESIZE-1)<<10
  LST(SEG)=LL<<32
  X=ACC>>8
  %WHILE LEN>0 %CYCLE
    CELL=CBTASL
    CBT==CBTA(CELL)
    CBTASL=CBT_LINK
    CBT_DA=DA
    DA=DA+MAXBLOCK
    %IF LEN>MAXBLOCK %THEN L=MAXBLOCK %ELSE L=LEN
    LEN=LEN-MAXBLOCK
    %IF X=0 %THEN CBT_ABTX=X'FF' %AND CBT_MASK2=X'FF' %C
      %ELSE CBT_ABTX=0 %AND CBT_MASK2=0
    CBT_TAGS=X<<4!(L-1)
    CBT_LINK=CBTASL
  %REPEAT
  CBT_LINK=255
%END
!-----------------------------------------------------------------------
%ROUTINE PUSHEP(%BYTEINTEGERNAME LP,%INTEGER X)
%RECORDNAME EP(EPF)
%INTEGER CELL
  CELL=EPASL
  EP==EPA(CELL)
  EPASL=EP_LINK
  EP_ST=X>>8
  EP_X=X&X'FF'
  EP_LINK=LP
  LP=CELL
  EPN=EPN+1
%END
!-----------------------------------------------------------------------
%ROUTINE POPEP(%BYTEINTEGERNAME LP)
%RECORDNAME EP(EPF)
%INTEGER CELL
  CELL=LP
  EP==EPA(CELL)
  LP=EP_LINK
  EP_LINK=EPASL
  EPASL=CELL
  EPN=EPN-1
%END
!-----------------------------------------------------------------------
%ROUTINE ABTOUT(%INTEGER ABTX)
%RECORDNAME CBT(CBTF)
%RECORDNAME ABT(ABTF)
%RECORDNAME EP(EPF)
%INTEGERARRAYNAME PT
%INTEGER PAGE,MARK,STEP,AMTX,MASK,SEPX,SFEP,POFL,I
%STRING(3) STRSEG,STRU
  %IF PROCMON=PROCESS %THEN PRINT STRING(PROCID."ABTOUT:")
  ABT==ABTA(ABTX)
  PT==ARRAY(VIRTAD!LST(ABT_SEG)&X'0FFFFFF8',PTF)
  %IF ABT_SEG=PROC_STACK>>18 %THEN SFEP=(INTEGER(PROC_STACK!X'40010') %C
    &X'3FFFF'+EPAGESIZE<<10-1)//EPAGESIZE<<10 %ELSE SFEP=9999
  STEP=ABT_STEP
  AMTX=ABT_AMTX
  %WHILE ABT_LINK#255 %CYCLE
    EP==EPA(ABT_LINK)
    SEPX=STEP+EP_X
    PAGE=SEPX*EPAGESIZE
    %IF SEPX>=SFEP %THEN %START
      POFL=2    ;! MAKE "NEW"
      MARK=0
      !%CYCLE I=PAGE,1,PAGE+EPAGESIZE-1
      !  PT(I)=0    ;! MAKE UNAVAILABLE
      !%REPEAT
      ! ASSUMES EPAGESIZE=4
      I=ADDR(PT(PAGE))
      *LDTB_X'38000001'
      *LDA_I
      *LSQ_0
      *ST_(%DR)
    %FINISH %ELSE %START
      !MARK=0
      !%CYCLE I=PAGE,1,PAGE+EPAGESIZE-1
      !  MARK=MARK!PT(I)        ;! GANG MARKERS TOGETHER
      !  PT(I)=0    ;! MARK PAGE AS UNAVAILABLE
      !%REPEAT
      ! ASSUMES EPAGESIZE=4
      I=ADDR(PT(PAGE))
      *LXN_I
      *LSS_(%XNB+0)
      *OR_(%XNB+1)
      *OR_(%XNB+2)
      *OR_(%XNB+3)
      *ST_MARK
      *LDTB_X'38000001'
      *LDA_I
      *LSQ_0
      *ST_(%DR)
      %IF ABTDESTROY=0 %THEN POFL=MARK<<3>>31<<3 %ELSE POFL=0
    %FINISH
    %IF PROCMON=PROCESS %THEN %START
      STRSEG=STRINT(ABT_SEG)
      %IF POFL=2 %THEN STRU=">SF" %ELSE STRU=EPUSE(MARK>>28&3)
      PRINT STRING(" ".STRSEG."/".STRINT(SEPX).STRU)
    %FINISH
    POUT_DEST=X'40002'    ;! PAGETURN/PAGE-OUT
    POUT_P1=AMTX<<16!EP_X
    POUT_P2=POFL
    *LSS_(6)
    *ST_IC
    *LSS_(5)
    *ST_IT
    PAGETURN(POUT)
    *LSS_(5)
    *ST_ITT
    *LSS_(6)
    *ST_ICC
    I=IT-ITT
    PTIT=PTIT+I
    LCIT=LCIT-I
    I=IC-ICC
    PTIC=PTIC+I
    LCIC=LCIC-I
    PTCALLN=PTCALLN+1
    %IF MARK>>28&1#0 %THEN ACNT_PTURNS=ACNT_PTURNS+1
    POPEP(ABT_LINK)
  %REPEAT
  POUT_DEST=X'80002'    ;! RETURN AMTX
  POUT_SRCE=0
  POUT_P1=PROCESS
  POUT_P2=AMTX
  %IF PROCMON=PROCESS %THEN PRINT STRING(" :RETURN AMTX ". %C
    STRHEX(AMTX))
  *LSS_(6)
  *ST_IC
  *LSS_(5)
  *ST_IT
  ACTIVE MEM(POUT)
  *LSS_(5)
  *ST_ITT
  *LSS_(6)
  *ST_ICC
  I=IT-ITT
  AMIT=AMIT+I
  LCIT=LCIT-I
  I=IC-ICC
  AMIC=AMIC+I
  LCIC=LCIC-I
  AMCALLN=AMCALLN+1
  MASK=POUT_P1    ;! RETAIN  "NEW" BIT MASK
  %IF PROCMON=PROCESS %THEN PRINT STRING(" ".STRHEX(MASK)."
")
  CBT==CBTA(ABT_CBTX)
  CBT_ABTX=MASK>>24
  CBT_MASK2=MASK>>16&X'FF'
  CBT_TAGS=CBT_TAGS&X'DF'
  ! REMOVE ABT
  %UNLESS ABT_PREV=255 %THEN ABTA(ABT_PREV)_NEXT=ABT_NEXT %C
    %ELSE ABTT=ABT_NEXT
  %UNLESS ABT_NEXT=255 %THEN ABTA(ABT_NEXT)_PREV=ABT_PREV %C
    %ELSE ABTB=ABT_PREV
  ABT_LINK=ABTASL    ;! RETURN ABT CELL
  ABTASL=ABTX
  ABTN=ABTN-1
%END
!-----------------------------------------------------------------------
%ROUTINE STROBE(%INTEGER KEEPUSE)
%RECORDNAME ABT(ABTF)
%RECORDNAME EP(EPF)
%INTEGERARRAYNAME PT
%INTEGER ABTX,PAGE,STEP,AMTX,MARK,POFL,SEPX,SFEP,USEMASK,I
%STRING(3) STRSEG,STRU
%BYTEINTEGERNAME EPL
  %IF PROCMON=PROCESS %THEN PRINT STRING(PROCID."STROBE-OUT:")
  %IF KEEPUSE=0 %THEN USEMASK=X'DFFFFFFF' %ELSE USEMASK=X'FFFFFFFF'
  ABTX=ABTT
  %WHILE ABTX#255 %CYCLE    ;! FOR EACH ACTIVE BLOCK
    ABT==ABTA(ABTX)
    PT==ARRAY(VIRTAD!LST(ABT_SEG)&X'0FFFFFF8',PTF)
    %IF ABT_SEG=PROC_STACK>>18%THEN SFEP=(INTEGER(PROC_STACK!X'40010')%C
      &X'3FFFF'+EPAGESIZE<<10-1)//EPAGESIZE<<10 %ELSE SFEP=9999
    ! STACK FRONT EPAGE IF STACK SEGMENT
    STEP=ABT_STEP
    AMTX=ABT_AMTX
    EPL==ABT_LINK
    %WHILE EPL#255 %CYCLE    ;! FOR EACH ACTIVE PAGE
      EP==EPA(EPL)
      SEPX=STEP+EP_X
      PAGE=SEPX*EPAGESIZE
      %IF SEPX>=SFEP %THEN POFL=2 %AND MARK=0 %ELSE %START
        !MARK=0
        !%CYCLE I=PAGE,1,PAGE+EPAGESIZE-1
        !  MARK=MARK!PT(I)    ;! GANG MARKERS TOGETHER
        !  PT(I)=PT(I)&USEMASK
        !%REPEAT
        ! ASSUMES EPAGESIZE=4
        I=ADDR(PT(PAGE))
        *LXN_I
        *LSS_(%XNB+0)
        *OR_(%XNB+1)
        *OR_(%XNB+2)
        *OR_(%XNB+3)
        *ST_MARK
        *LSS_(%XNB+0)
        *AND_USEMASK
        *ST_(%XNB+0)
        *LSS_(%XNB+1)
        *AND_USEMASK
        *ST_(%XNB+1)
        *LSS_(%XNB+2)
        *AND_USEMASK
        *ST_(%XNB+2)
        *LSS_(%XNB+3)
        *AND_USEMASK
        *ST_(%XNB+3)
        POFL=MARK<<3>>31<<3!1<<2
      %FINISH
      %IF MARK>>29&1=0 %THEN %START    ;! STROBE OUT
        %IF PROCMON=PROCESS %THEN %START
          STRSEG=STRINT(ABT_SEG)
          %IF POFL=2 %THEN STRU=">SF" %ELSE STRU=EPUSE(MARK>>28&3)
          PRINT STRING(" ".STRSEG."/".STRINT(SEPX).STRU)
        %FINISH
        POUT_DEST=X'40002'    ;! PAGETURN/PAGE-OUT
        POUT_P1=AMTX<<16!EP_X
        POUT_P2=POFL
        *LSS_(6)
        *ST_IC
        *LSS_(5)
        *ST_IT
        PAGETURN(POUT)
        *LSS_(5)
        *ST_ITT
        *LSS_(6)
        *ST_ICC
        I=IT-ITT
        PTIT=PTIT+I
        LCIT=LCIT-I
        I=IC-ICC
        PTIC=PTIC+I
        LCIC=LCIC-I
        PTCALLN=PTCALLN+1
        %IF MARK>>28&1#0 %THEN ACNT_PTURNS=ACNT_PTURNS+1
        !%CYCLE I=PAGE,1,PAGE+EPAGESIZE-1
        !  PT(I)=0
        !%REPEAT
        ! ASSUMES EPAGESIZE=4
        I=ADDR(PT(PAGE))
        *LDTB_X'38000001'
        *LDA_I
        *LSQ_0
        *ST_(%DR)
        POPEP(EPL)
      %FINISH %ELSE EPL==EP_LINK
    %REPEAT
    ABTX=ABT_NEXT
  %REPEAT
  XSTROBE=1
  %IF PROCMON=PROCESS %THEN NEWLINE
%END
!-----------------------------------------------------------------------
%ROUTINE WORKSET(%INTEGER MAXWSN)
%RECORDNAME ABT(ABTF)
%RECORDNAME EP(EPF)
%INTEGERARRAYNAME PT
%INTEGER ABTX,PAGE,MARK,STEP,AMTX,POFL,SEPX,SFEP,I
%STRING(3) STRSEG,STRU
%BYTEINTEGERNAME EPL
  %IF PROCMON=PROCESS %THEN PRINT STRING(PROCID."PAGE-OUT:")
  ABTX=ABTT
  %WHILE ABTX#255 %CYCLE
    ABT==ABTA(ABTX)
    PT==ARRAY(VIRTAD!LST(ABT_SEG)&X'0FFFFFF8',PTF)
    %IF ABT_SEG=PROC_STACK>>18%THEN SFEP=(INTEGER(PROC_STACK!X'40010')%C
      &X'3FFFF'+EPAGESIZE<<10-1)//EPAGESIZE<<10 %ELSE SFEP=9999
    ! STACK FRONT EPAGE IF STACK SEGMENT
    STEP=ABT_STEP
    AMTX=ABT_AMTX
    EPL==ABT_LINK
    %WHILE EPL#255 %CYCLE
      EP==EPA(EPL)
      SEPX=STEP+EP_X
      %IF SEPX>=SFEP %THEN POFL=2 %AND MARK=0 %ELSE %START
        PAGE=SEPX*EPAGESIZE
        !MARK=0
        !%CYCLE I=PAGE,1,PAGE+EPAGESIZE-1
        !  MARK=MARK!PT(I)        ;! GANG MARKERS TOGETHER
        !%REPEAT
        ! ASSUMES EPAGESIZE=4
        I=ADDR(PT(PAGE))
        *LXN_I
        *LSS_(%XNB+0)
        *OR_(%XNB+1)
        *OR_(%XNB+2)
        *OR_(%XNB+3)
        *ST_MARK
        POFL=MARK<<3>>31<<3!1<<2    ;! WRIT & UPDATE DRUM
      %FINISH
      %IF PROCMON=PROCESS %THEN %START
        STRSEG=STRINT(ABT_SEG)
        %IF POFL=2 %THEN STRU=">SF" %ELSE STRU=EPUSE(MARK>>28&3)
        PRINT STRING(" ".STRSEG."/".STRINT(SEPX).STRU)
      %FINISH
      POUT_DEST=X'40002'    ;! PAGETURN/PAGE-OUT
      POUT_P1=AMTX<<16!EP_X
      POUT_P2=POFL
      *LSS_(6)
      *ST_IC
      *LSS_(5)
      *ST_IT
      PAGETURN(POUT)
      *LSS_(5)
      *ST_ITT
      *LSS_(6)
      *ST_ICC
      I=IT-ITT
      PTIT=PTIT+I
      LCIT=LCIT-I
      I=IC-ICC
      PTIC=PTIC+I
      LCIC=LCIC-I
      PTCALLN=PTCALLN+1
      %IF MARK>>28&1#0 %THEN ACNT_PTURNS=ACNT_PTURNS+1
      %IF MARK>>29&1=0 %OR MAXWSN<=0 %THEN POPEP(EPL) %C
        %ELSE EPL==EP_LINK %AND MAXWSN=MAXWSN-1
    %REPEAT
    I=ABT_NEXT
    ! MOVE ABT TO TOP OF LIST IF ANY PAGES IN WS
    %UNLESS ABT_LINK=255 %OR ABT_PREV=255 %THEN %START
      ABTA(ABT_PREV)_NEXT=ABT_NEXT
      %UNLESS ABT_NEXT=255 %THEN ABTA(ABT_NEXT)_PREV=ABT_PREV %C
        %ELSE ABTB=ABT_PREV
      ABT_PREV=255
      ABT_NEXT=ABTT
      ABTA(ABTT)_PREV=ABTX
      ABTT=ABTX
    %FINISH
    ABTX=I
  %REPEAT
  PROC_WSN=EPN    ;! NO OF EPAGES IN WORKING SET
  ! REMOVE PT ADDRS
  !%CYCLE I=2,1,HIGHSEG
  !  LST(I)=LST(I)&X'FFFFFFFF00000000'
  !%REPEAT
  *LD_X'2800000100000014'
  *LSS_0
  *LB_HIGHSEG
  *SBB_1
RPA:*ST_(%DR)
  *INCA_8
  *DEBJ_<RPA>
  RETURN PTS
  %IF PROCMON=PROCESS %THEN NEWLINE
%END
!-----------------------------------------------------------------------
%ROUTINE RETURN PTS
%RECORDNAME EP(EPF)
  %WHILE PTP#255 %CYCLE
    EP==EPA(PTP)
    POUT_P2=(EP_ST<<8!EP_X)&X'FFF'
    RETURN EPAGE(POUT)
    POPEP(PTP)
  %REPEAT
%END
!-----------------------------------------------------------------------
%INTEGERFN FIND PROCESS
%STRING(6) USER
%INTEGER I,J,K,DACT
  USER=STRING(PROC_STACK!X'40030')    ;! IN OLD ACC
  J=INTEGER(PROC_STACK!X'4003C')
  %IF 1<=J<=3 %THEN %START
    %IF J=1 %THEN K=LOCSN1 %ELSE %START
      %IF J=2 %THEN K=LOCSN2 %ELSE K=LOCSN3
    %FINISH
    DACT=BYTE INTEGER(DIROUTPAD+2)<<8!BYTE INTEGER(DIROUTPAD+3)
    %UNLESS J=3 %AND (DACT=0 %OR DACT=X'FFFF') %THEN %START
      %CYCLE I=1,1,MAXPROCS
        %IF USER=PROCA(I)_USER %THEN DIROUTP_DEST=(I+K)<<16!DACT %C
           %AND %RESULT=I
      %REPEAT
    %FINISH
  %FINISH
  DIROUTP_DEST=0
  %RESULT=0
%END
!-----------------------------------------------------------------------
%INTEGERFN CURSSN
%INTEGER I,J
  J=PROC_STACK>>18
  %CYCLE I=1,1,LSTKN
    %IF J=LSTKSSN(I) %THEN %RESULT=I
  %REPEAT
  MONITOR("CURRENT STACK ?")
%END
!-----------------------------------------------------------------------
%ROUTINE VSINT
%CONSTSTRING(1)%ARRAY ACC(0:3)="W"(2),"R","E"
%CONSTSTRING(11)%ARRAY CAUSE(0:7)="SEG>LIMIT ","SEG-FLT ","SEG LIMIT ",
  "PAGE>LIMIT ","PAGE-FLT ","??? "(3)
%CONSTSTRING(4)%ARRAY APF(0:1)=""," APF"
%CONSTSTRING(4)%ARRAY INT(0:1)=""," INT"
  PRINT STRING(PROCID.CAUSE(VSPARM&7).STRINT(VSPARM>>18). %C
    "/".STRINT((VSPARM>>10&X'FF')//EPAGESIZE).ACC(VSPARM>>5&3). %C
    APF(VSPARM>>4&1).INT(VSPARM>>3&1)."
")
%END
!-----------------------------------------------------------------------
%ROUTINE PROGERR
%CONSTSTRING(23)%ARRAY CAUSE(0:20)="FLOATING PT OVERFLOW",
  "FLOATING PT UNDERFLOW","FIXED PT OVERFLOW","DECIMAL OVERFLOW",
  "ZERO DIVIDE","BOUND CHECK","SIZE","B OVERFLOW","STACK","PRIVILEGE",
  "DESCRIPTOR","STRING","INSTRUCTION","ACCUMULATOR","ESR ERRORS","???",
  "SYSTEM CALL","INSTRN COUNTER","DISC READ FAIL","CHANGE BLOCK SIZE",
  "SYSTEM ERROR"
%CONSTSTRING(11)%ARRAY RES(0:1)=""," NO RESTART"
  PRINT STRING(PROCID.CAUSE(PEPARM&X'1F')."/".STRINT(PEPARM>>8&X'FF').%C
    RES(PEPARM>>7&1)."
")
%END
!-----------------------------------------------------------------------
%ROUTINE WAIT(%INTEGER DACT,N)
  POUT_DEST=X'A0002'
  POUT_SRCE=0
  POUT_P1=ME!DACT
  POUT_P2=N
  PON(POUT)
%END
!-----------------------------------------------------------------------
%END
!-----------------------------------------------------------------------
%END
%ENDOFFILE