%EXTERNALSTRING (15) %FNSPEC STRINT(%INTEGER N)
%EXTERNALSTRING (8) %FNSPEC STRHEX(%INTEGER N)
%EXTERNALSTRING(8) %FNSPEC HTOS(%INTEGER VALUE,PLACES)
%EXTERNALROUTINESPEC PTREC(%RECORDNAME P)
%EXTERNALROUTINESPEC OPMESS(%STRING (63) S)
%EXTERNALROUTINESPEC MONITOR(%STRING (63) S)
%EXTERNALROUTINESPEC DUMP TABLE(%INTEGER T, A, L)
%ROUTINESPEC ELAPSED INT(%RECORDNAME P)
%SYSTEMROUTINESPEC ETOI(%INTEGER A, L)
%ROUTINESPEC PDISC(%RECORDNAME P)
%EXTERNALINTEGERFNSPEC HANDKEYS
%EXTERNALROUTINESPEC DCU(%RECORDNAME P)
!* COMMUNICATIONS RECORD FORMAT - EXTANT FROM CHOPSUPE 18D ONWARDS *
! Alterations from above-mentioned record format, for the S-series, are
! as follows:
!     GPCTABSIZE  ->   DCUTABSIZE
!     GPCA        ->   DCUA
!     SMACS       ->   SCUS
!     GPCCONFA    ->   DCUCONFA
%RECORDFORMAT COMF(%INTEGER OCPTYPE,IPLDEV,SBLKS,SEPGS,NDISCS,  %C
         DDTADDR,DCUTABSIZE,DCUA,SFCTABSIZE,SFCA,SFCK,DIRSITE,  %C
         DCODEDA,SUPLVN,KLOKCORRECT,DATE0,DATE1,DATE2,  %C
         TIME0,TIME1,TIME2,EPAGESIZE,USERS,PROCMON,DQADDR,  %C
         SACPORT,OCPPORT,ITINT,CONTYPEA,DCUCONFA,FPCCONFA,SFCCONFA, %C
         BLKADDR,DPTADDR,SCUS,TRANS,%LONGINTEGER KMON,  %C
         %INTEGER SPDRQ,SMACPOS,SUPVSN,PSTVA,SECSFRMN,SECSTOCD, %C
         SYNC1DEST,SYNC2DEST,ASYNCDEST,MAXPROCS,INSPERSEC,ELAPHEAD, %C
         COMMSRECA,STOREAAD,PROCAAD,SFCCTAD,DRUMTAD,SP0,SP1,SP2,SP3, %C
            SP4,SP5,SP6,SP7,SP8,SP9,  %C
         LSTL,LSTB,PSTL,PSTB,HKEYS,HOOT,SIM,CLKX,CLKY,CLKZ,  %C
         HBIT,SLAVEOFF,INHSSR,SDR1,SDR2,SDR3,  %C
         SDR4,SESR,HOFFBIT,S2,S3,S4,END)
!-----------------------------------------------------------------------
! PON & POFF ETC. DECLARATIONS
%RECORDFORMAT PARMF(%INTEGER DEST, SRCE, P1, P2, P3, P4, P5,  %C
         P6)
%CONSTINTEGER PSTVA=X'80040000'
%CONSTINTEGER PPSEG=20
%CONSTINTEGER PCELLSIZE=36;             ! NO OF BYTES FOR 1 PARAM CELL
%CONSTINTEGER MARGIN=48;                ! MARGIN OF UNFORMATTED CELLS
%RECORDFORMAT PDOPEF(%INTEGER CURRMAX, MAXMAX, FIRST UNALLOC,  %C
         LAST UNALLOC, NEXTPAGE, S1, S2, S3, S4)
%OWNRECORDNAME PARMDOPE(PDOPEF)
%EXTERNALINTEGER PARMASL=0,PARMSEMA=-1,SERVSEMA=-1
%RECORDFORMAT PARMXF(%INTEGER DEST, SRCE, P1, P2, P3, P4, P5,  %C
         P6, LINK)
%OWNRECORDARRAYFORMAT PARMSPF(0:2015)(PARMXF)
%OWNRECORDARRAYNAME PARM(PARMXF)
%EXTERNALLONGINTEGER PARMDES
%OWNLONGLONGREAL GETNEWPAGE
%OWNRECORDNAME COM(COMF)
%RECORDFORMAT STOREF(%INTEGER FLAGLINK,BFLINK,REALAD)
%OWNRECORDARRAYFORMAT STOREAF(0:2047)(STOREF)
%OWNRECORDARRAYNAME STORE(STOREF)
%OWNINTEGERNAME STORESEMA
%CONSTSTRINGNAME DATE=X'80C0003F'
%CONSTSTRINGNAME TIME=X'80C0004B'
%CONSTINTEGER MAXPROCS=32;      ! ASSUMED TO BE 2**N BY ELAPSED INT!
%CONSTINTEGER LOCSN0=64
%CONSTINTEGER LOCSN1=LOCSN0+MAXPROCS
%CONSTINTEGER MAXSERV=LOCSN0+4*MAXPROCS
%RECORDFORMAT SERVF(%INTEGER P, L)
%EXTERNALRECORDARRAY SERVA(0:MAXSERV)(SERVF)
! LOCAL CONTROLLERS & USER SERVICES INHIBITED INITIALLY
%EXTERNALINTEGER KERNELQ=0, RUNQ1=0, RUNQ2=0
%RECORDFORMAT PROCF(%STRING (6) USER,  %C
         %BYTEINTEGER INCAR,CATEGORY, WSN, RUNQ, ACTIVE,  %C
         %INTEGER LAMTX, LSTAD, STACK, STATUS)
%EXTRINSICRECORDARRAY PROCA(0:MAXPROCS)(PROCF)
?%EXTRINSICLONGINTEGER KMON
!-----------------------------------------------------------------------
%ROUTINE PUTONQ(%INTEGER SERVICE)
%RECORDNAME SERV, SERVQ(SERVF)
%INTEGERNAME RUNQ
      SERV==SERVA(SERVICE)
      %IF LOCSN0<SERVICE<=LOCSN1 %THEN %START
         %IF PROCA(SERVICE-LOCSN0)_RUNQ=1 %C
            %THEN RUNQ==RUNQ1 %ELSE RUNQ==RUNQ2
         %IF RUNQ=0 %THEN SERV_L=SERVICE %ELSE %START
            SERVQ==SERVA(RUNQ)
            SERV_L=SERVQ_L
            SERVQ_L=SERVICE
         %FINISH
         RUNQ=SERVICE
      %FINISH %ELSE %START
         %IF KERNELQ=0 %THEN SERV_L=SERVICE %ELSE %START
            SERVQ==SERVA(KERNELQ)
            SERV_L=SERVQ_L
            SERVQ_L=SERVICE
         %FINISH
         KERNELQ=SERVICE
      %FINISH
%END
!-----------------------------------------------------------------------
%EXTERNALINTEGERFN PPINIT(%INTEGERFN NEW EPAGE)
%INTEGERFNSPEC NEW EPAGE
%CONSTINTEGER PTSIZE=72;                ! ALLOW 72K FOR PARM SPACE
%INTEGER I, J, CELLS, PARMAD
%LONGINTEGER L
      *LSQ_(%LNB+5)
      *ST_GETNEWPAGE;                   ! STORE AWAY FN PARAM
      COM==RECORD(X'80C00000');         ! FOR OTHER RTS TOO!
      I=NEW EPAGE
      STORE==ARRAY(COM_STOREAAD,STOREAF)
      STORESEMA==INTEGER(COM_STOREAAD+8);! USE STORE(0)_REALAD AS SEMA
      %IF MAXPROCS#COM_MAXPROCS  %THEN %C
         PRINTSTRING("INCOMPATIBE COMPONENTS!!!!!!!
")
      L=PTSIZE*8-1
                                        ! PAGE TABLE AT BEGINNING OF PPSEG
      LONG INTEGER(PSTVA+8*PPSEG)=X'4110000080000001'!L<<39!I
      %CYCLE J=0,1,COM_EPAGESIZE-1
         INTEGER(X'81000000'!I+4*J)=X'80000001'!I+1024*J
      %REPEAT
      PARMAD=X'80000000'!PPSEG<<18+PTSIZE*4
      PARM==ARRAY(PARMAD,PARMSPF);      ! MAP ARRAY ONTO PARM SEGMNT
      PARMDOPE==PARM(0);                ! USE FIRST CELL FOR INFO
      PARMDOPE_CURRMAX=1024*COM_EPAGESIZE-PTSIZE*4
      PARMDOPE_MAXMAX=1024*PTSIZE-PTSIZE*4
      CELLS=PARMDOPE_CURRMAX//PCELLSIZE-1;   ! NO OF CELLS NOW AVAIABLE
      PARMDOPE_FIRSTUNALLOC=CELLS-MARGIN+1
      PARMDOPE_LAST UNALLOC=CELLS
      PARMDOPE_NEXTPAGE=COM_EPAGESIZE
      CELLS=CELLS-MARGIN;               ! MARGIN OF "MARGIN" CELLS FOR TRYING
                                        ! TO OBTAIN FURTHER EPAGE
      %CYCLE I=1,1,CELLS-1
         PARM(I)_LINK=I+1
      %REPEAT
      PARM(CELLS)_LINK=1
      PARMASL=CELLS
      J=PARMAD
      I=PARMDOPE_CURRMAX!X'18000000'
      PARMDES=LONGINTEGER(ADDR(I));     ! DESCRPTR TO PP AREA
      %RESULT =PARMAD
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE SEMALOOP(%INTEGERNAME SEMA)
!***********************************************************************
!*    LOOP TILL A SEMA COMES FREE. MAXCOUNT IS LARGE ENOUGH SO THAT    *
!*    IT IS ONLY INVOKED WHEN ANOTHER OCP HAS GONE DOWN HOLDING A SEMA *
!***********************************************************************
%CONSTINTEGER MAXCOUNT=32000
%INTEGER I
   %CYCLE I=1,1,MAXCOUNT
      *INCT_(SEMA)
      *JCC_7,<ON>
      %RETURN
ON: %REPEAT
   PRINTSTRING("
SEMA FORCED FREE AT ".STRHEX(ADDR(SEMA)))
   SEMA=0
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE MORE PPSPACE
!***********************************************************************
!*    CALLED WHEN PARM ASL IS EMPTY AND ATTEMPS TO GRAB A FREE EPAGE   *
!*    AND USE TO EXTEND THE (PAGED) PARAMETER PASSING AREA             *
!*    IF NO PAGE AVAILABLE IT TRIES TO USE ONE OF THE SMALL NO OF CELLS*
!*    NOT FORMATTED INTO THE ORIGINAL LIST. THIS GIVES US A FAIR       *
!*    CHANCE OF FINDING A FREE EPAGE BEFORE DISASTER STRIKES           *
!***********************************************************************
%INTEGER I, J, REALAD, PTAD, CELLS, FIRST, CMAX
%LONGLONGREAL X
   CMAX=PARMDOPE_CURRMAX
   %IF CMAX>=PARMDOPE_MAXMAX %THEN ->FAIL
   X=GET NEW PAGE;                      ! 4 WORD RT PARAMETER !!
   *PRCL_4
   *LD_X
   *LXN_X+12
   *RALN_5
   *CALL_(%DR)
   *ST_I;                               ! 0 IF NO PAGE AVAIALBE
   %IF I=-1 %THEN ->TRY MARGIN
   REALAD=I!X'80000001'
   PTAD=X'80000000'!PPSEG<<18+4*PARMDOPE_NEXTPAGE
                                        ! EXTEND PARM AREA BY 1 EPAGE BY ADDING ENTRIES INTO PAGE TABLE
   %CYCLE I=0,1,COM_EPAGESIZE-1
      INTEGER(PTAD+4*I)=REALAD+1024*I
   %REPEAT
                                        ! ADJUST PARAM AREA DESCRIPTOR AND FORMAT UP NEW BIT OF PARMLIST
   CMAX=CMAX+COM_EPAGESIZE*1024
   PARMDOPE_CURRMAX=CMAX
   CELLS=CMAX//PCELLSIZE-1
   FIRST=PARMDOPE_FIRST UNALLOC
   PARMDOPE_FIRST UNALLOC=CELLS-MARGIN+1
   PARMDOPE_LAST UNALLOC=CELLS
   PARMDOPE_NEXTPAGE=PARMDOPE_NEXTPAGE+COM_EPAGESIZE
   CELLS=CELLS-MARGIN
   %CYCLE I=FIRST,1,CELLS-1
      PARM(I)_LINK=I+1
   %REPEAT
   PARM(CELLS)_LINK=FIRST
   PARMASL=CELLS
   INTEGER(ADDR(PARMDES))=X'18000000'!CMAX
   PRINTSTRING("
MORE PP SPACE PROVIDED OK")
   %RETURN
TRY MARGIN:                             ! NO EPAGE AVAILABLE JUST NOW, USE ONE OF MARGIN CELLS
   I=PARMDOPE_FIRST UNALLOC
   %IF I>PARMDOPE_LAST UNALLOC %THEN ->FAIL
   PARMDOPE_FIRST UNALLOC=I+1
   PARM(I)_LINK=I
   PARMASL=I
   %RETURN
FAIL:

   MONITOR("PARM ASL EMPTY")
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE PON(%RECORDNAME P)
%RECORDSPEC P(PARMF)
%RECORDNAME SERV(SERVF)
%RECORDNAME ACELL, SCELL, NCELL(PARMXF)
%INTEGER SERVICE, NEWCELL, SERVP
   SERVICE=P_DEST>>16
   %UNLESS SERVICE<=MAXSERV %C
      %THEN PRINT STRING('INVALID PON:') %AND PTREC(P) %C
      %AND %RETURN
!*SEM   *INCT_PARMSEMA
!*SEM   *JCC_8,<PSEMAGOT>
!*SEM   SEMALOOP(PARMSEMA)
!*SEMPSEMAGOT:

   %IF PARMASL=0 %THEN MORE PPSPACE
   ACELL==PARM(PARMASL);                ! ACELL =ASL HEADCELL
   NEWCELL=ACELL_LINK
   NCELL==PARM(NEWCELL);                ! NCELL MAPPED ONTO NEWCELL
   %IF NEWCELL=PARMASL %THEN PARMASL=0 %C
      %ELSE ACELL_LINK=NCELL_LINK
   NCELL<-P;                            ! COPY PARAMETERS IN
   PARMSEMA=-1
!*SEM   *INCT_SERVSEMA
!*SEM   *JCC_8,<SSEMAGOT>
!*SEM   SEMALOOP(SERVSEMA)
!*SEMSSEMAGOT:
   SERV==SERVA(SERVICE)
   SERVP=SERV_P&X'7FFFFFFF'
   %IF SERVP=0 %THEN NCELL_LINK=NEWCELL %ELSE %START
      SCELL==PARM(SERVP)
      NCELL_LINK=SCELL_LINK
      SCELL_LINK=NEWCELL
   %FINISH
   SERV_P=SERV_P&X'80000000'!NEWCELL
   %IF SERV_P>0 %AND SERV_L=0 %THEN PUTONQ(SERVICE)
   SERVSEMA=-1
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE FASTPON(%INTEGER CELL)
!***********************************************************************
!*    CAN BE USED WHEN RECORD ALREADY IN PARAM TABLE TO AVOID COPY     *
!*    CELL IS NO OF ENTRY IN PARM HOLDING THE RECORD                   *
!***********************************************************************
%INTEGER SERVICE, SERVP
%RECORDNAME SERV(SERVF)
%RECORDNAME CCELL, SCELL(PARMXF)
   CCELL==PARM(CELL)
   SERVICE=CCELL_DEST>>16
!*SEM   *INCT_SERVSEMA
!*SEM   *JCC_8,<SSEMAGOT>
!*SEM   SEMALOOP(SERVSEMA)
!*SEMSSEMAGOT:

   SERV==SERVA(SERVICE)
   SERVP=SERV_P&X'7FFFFFFF'
   %IF SERVP=0 %THEN CCELL_LINK=CELL %ELSE %START
      SCELL==PARM(SERVP)
      CCELL_LINK=SCELL_LINK
      SCELL_LINK=CELL
   %FINISH
   SERV_P=SERV_P&X'80000000'!CELL
   %IF SERV_P>0 %AND SERV_L=0 %THEN PUTONQ(SERVICE)
   SERVSEMA=-1
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE DPON(%RECORDNAME P, %INTEGER DELAY)
%RECORDSPEC P(PARMF)
%RECORD POUT(PARMF)
%RECORDNAME ACELL, NCELL(PARMXF)
%INTEGER SERVICE, NEWCELL
   SERVICE=P_DEST>>16
   %UNLESS SERVICE<=MAXSERV %C
      %THEN PRINT STRING('INVALID DPON:') %AND PTREC(P) %C
      %AND WRITE(DELAY,4) %AND %RETURN
!*SEM   *INCT_PARMSEMA
!*SEM   *JCC_8,<PSEMAGOT>
!*SEM   SEMALOOP(PARMSEMA)
!*SEMPSEMAGOT:

   %IF PARMASL=0 %THEN MORE PPSPACE
   ACELL==PARM(PARMASL)
   NEWCELL=ACELL_LINK
   NCELL==PARM(NEWCELL);                ! ONTO CELL IN FREELIST
   %IF NEWCELL=PARMASL %THEN PARMASL=0 %C
      %ELSE ACELL_LINK=NCELL_LINK
   NCELL<-P
   PARMSEMA=-1
   POUT_DEST=X'A0002'
   POUT_SRCE=0
   POUT_P1=X'C0000'!NEWCELL
   POUT_P2=DELAY
   ELAPSED INT(POUT)
%END
!-----------------------------------------------------------------------
%EXTERNALINTEGERFN NEWPPCELL
!***********************************************************************
!*    PROVIDE A PP CELL FOR USE ELSEWHERE THAN IN PON-POFF AREA        *
!***********************************************************************
%INTEGER NEWCELL
%RECORDNAME ACELL(PARMXF)
!*SEM   *INCT_PARMSEMA
!*SEM   *JCC_8,<PSEMAGOT>
!*SEM   SEMALOOP(PARMSEMA)
!*SEMPSEMAGOT:

   %IF PARMASL=0 %THEN MORE PPSPACE
   ACELL==PARM(PARMASL)
   NEWCELL=ACELL_LINK
   %IF NEWCELL=PARMASL %THEN PARMASL=0 %C
      %ELSE ACELL_LINK=PARM(NEWCELL)_LINK
   PARMSEMA=-1
   %RESULT =NEWCELL
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE DPONPUTONQ(%RECORDNAME P)
%RECORDSPEC P(PARMF)
%RECORDNAME SERV(SERVF)
%RECORDNAME SCELL, CCELL(PARMXF)
%INTEGER SERVICE, CELL, SERVP
?   %IF KMON&1<<12#0 %THEN PRINT STRING('DPONPUTONQ:') %C
      %AND PTREC(P)
   CELL=P_DEST&X'FFFF'
   CCELL==PARM(CELL)
   SERVICE=CCELL_DEST>>16
!*SEM   *INCT_SERVSEMA
!*SEM   *JCC_8,<SSEMAGOT>
!*SEM   SEMALOOP(SERVSEMA)
!*SEMSSEMAGOT:
   SERV==SERVA(SERVICE)
   SERVP=SERV_P&X'7FFFFFFF'
   %IF SERVP=0 %THEN CCELL_LINK=CELL %ELSE %START
      SCELL==PARM(SERVP)
      CCELL_LINK=PARM(SERVP)_LINK
      PARM(SERVP)_LINK=CELL
   %FINISH
   SERV_P=SERV_P&X'80000000'!CELL
   %IF SERV_P>0 %AND SERV_L=0 %THEN PUTONQ(SERVICE)
   SERVSEMA=-1
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE POFF(%RECORDNAME P)
%RECORDSPEC P(PARMF)
%RECORDNAME SERV(SERVF)
%RECORDNAME ACELL, CCELL, SCELL(PARMXF)
%INTEGER SERVICE, CELL, SERVP
   SERVICE=P_DEST>>16
   %UNLESS 0<SERVICE<=MAXSERV %C
      %THEN PRINT STRING('INVALID POFF:') %AND PTREC(P) %C
      %AND P_DEST=0 %AND %RETURN
!*SEM   *INCT_SERVSEMA
!*SEM   *JCC_8,<SSEMAGOT>
!*SEM   SEMALOOP(SERVSEMA)
!*SEMSSEMAGOT:
   SERV==SERVA(SERVICE)
   SERVP=SERV_P
   %IF SERVP<=0 %THEN P_DEST=0 %AND SERVSEMA=-1 %AND %RETURN
   SCELL==PARM(SERVP)
   CELL=SCELL_LINK
   CCELL==PARM(CELL)
   P<-CCELL;                            ! COPY PARAMETERS OUT
   %IF CELL=SERV_P %THEN SERV_P=0 %ELSE SCELL_LINK=CCELL_LINK
   SERVSEMA=-1
!*SEM   *INCT_PARMSEMA
!*SEM   *JCC_8,<PSEMAGOT>
!*SEM   SEMALOOP(PARMSEMA)
!*SEMPSEMAGOT:
   %IF PARMASL=0 %THEN CCELL_LINK=CELL %ELSE %START
      ACELL==PARM(PARMASL)
      CCELL_LINK=ACELL_LINK
      ACELL_LINK=CELL
   %FINISH
   PARMASL=CELL
   PARMSEMA=-1
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE RETURN PPCELL(%INTEGER CELL)
!***********************************************************************
!*    RETURNS A CELL SUPLIED FOR OTHER PURPOSES VIA NEWPPCELL          *
!***********************************************************************
%RECORDNAME ACELL, CCELL(PARMXF)
!*SEM   *INCT_PARMSEMA
!*SEM   *JCC_8,<PSEMAGOT>
!*SEM   SEMALOOP(PARMSEMA)
!*SEMPSEMAGOT:
   CCELL==PARM(CELL)
   %IF PARMASL=0 %THEN CCELL_LINK=CELL %ELSE %START
      ACELL==PARM(PARMASL)
      CCELL_LINK=ACELL_LINK
      ACELL_LINK=CELL
   %FINISH
   PARMASL=CELL
   PARMSEMA=-1
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE SUPPOFF(%RECORDNAME SERV, P)
!***********************************************************************
!*    A MORE EFFICIENT POFF FOR SUPERVISOR                             *
!*    ASSUMES VITAL CHECKS HAVE BEEN DONE AND ALSO THAT CURRENT OCP    *
!*    HAS OBTAINED SERVSEMA !                                          *
!***********************************************************************
%RECORDSPEC SERV(SERVF)
%RECORDSPEC P(PARMF)
%RECORDNAME ACELL, CCELL, SCELL(PARMXF)
%INTEGER CELL, SERVP
   SERVP=SERV_P&X'7FFFFFFF'
   SCELL==PARM(SERVP)
   CELL=SCELL_LINK
   CCELL==PARM(CELL)
   P<-CCELL
   %IF CELL=SERVP %THEN SERV_P=SERV_P&X'80000000' %C
      %ELSE SCELL_LINK=CCELL_LINK
   SERVSEMA=-1
!*SEM   *INCT_PARMSEMA
!*SEM   *JCC_8,<PSEMAGOT>
!*SEM   SEMALOOP(PARMSEMA)
!*SEMPSEMAGOT:
   %IF PARMASL=0 %THEN CCELL_LINK=CELL %ELSE %START
      ACELL==PARM(PARMASL)
      CCELL_LINK=ACELL_LINK
      ACELL_LINK=CELL
   %FINISH
   PARMASL=CELL
   PARMSEMA=-1
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE INHIBIT(%INTEGER SERVICE)
%RECORDNAME SERV(SERVF)
   %UNLESS 0<SERVICE<=MAXSERV %C
      %THEN PRINT STRING('INVALID INHIBIT: '.STRINT(SERVICE)."
") %C
      %AND %RETURN
!*SEM   *INCT_SERVSEMA
!*SEM   *JCC_8,<SSEMAGOT>
!*SEM   SEMALOOP(SERVSEMA)
!*SEMSSEMAGOT:
   SERV==SERVA(SERVICE)
   SERV_P=SERV_P!X'80000000'
   SERVSEMA=-1
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE UNINHIBIT(%INTEGER SERVICE)
%RECORDNAME SERV(SERVF)
   %UNLESS 0<SERVICE<=MAXSERV %C
      %THEN PRINT STRING('INVALID UNINHIBIT: '.STRINT(SERVICE). %C
      "
") %AND %RETURN
!*SEM   *INCT_SERVSEMA
!*SEM   *JCC_8,<SSEMAGOT>
!*SEM   SEMALOOP(SERVSEMA)
!*SEMSSEMAGOT:
   SERV==SERVA(SERVICE)
   SERV_P=SERV_P&X'7FFFFFFF'
   %IF SERV_L=0 %AND SERV_P#0 %THEN PUTONQ(SERVICE)
   SERVSEMA=-1
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE CLEAR PARMS(%INTEGER SERVICE)
%RECORDNAME SERV(SERVF)
%INTEGER CELL, SERVP
!*SEM   *INCT_SERVSEMA
!*SEM   *JCC_8,<SSEMAGOT>
!*SEM   SEMALOOP(SERVSEMA)
!*SEMSSEMAGOT:
   SERV==SERVA(SERVICE)
   SERVP=SERV_P&X'7FFFFFFF'
   %IF SERVP=0 %THEN SERVSEMA=-1 %AND %RETURN
   CELL=SERVP
   %UNTIL CELL=SERVP %CYCLE
      CELL=PARM(CELL)_LINK
      PRINT STRING('PARM CLEARED:')
      PTREC(PARM(CELL))
   %REPEAT
   SERV_P=SERV_P&X'80000000'
   SERVSEMA=-1
!*SEM   *INCT_PARMSEMA
!*SEM   *JCC_8,<PSEMAGOT>
!*SEM   SEMALOOP(PARMSEMA)
!*SEMPSEMAGOT:
   %IF PARMASL#0 %THEN CELL=PARM(SERVP)_LINK %C
      %AND PARM(SERVP)_LINK=PARM(PARMASL)_LINK %C
      %AND PARM(PARMASL)_LINK=CELL
   PARMASL=SERVP
   PARMSEMA=-1
%END
!-----------------------------------------------------------------------

%OWNINTEGER RETRY COUNT=0, WAIT COUNT=1, RFLAGS
%EXTERNALROUTINE TURN ON ER(%RECORDNAME P)
!***********************************************************************
!*    TURNS ON ERROR REPORTING AFTER TIME LAPSE                        *
!***********************************************************************
%INTEGER I, J
%RECORDSPEC P(PARMF)
%CONSTINTEGER LAPSED MINS=2
   %IF RFLAGS#0 %START
      %IF RFLAGS&1#0 %THEN OPMESS("RETRY:-NO DMP IN SSN+1")
      %IF RFLAGS&2#0 %THEN %START
         OPMESS("ERROR REPORTING OFF")
         WAIT COUNT=10*LAPSED MINS
         RFLAGS=0
         %RETURN
      %FINISH
      RFLAGS=0
   %FINISH
   %IF WAITCOUNT#0 %THEN %START
      %IF P_DEST&15=1 %THEN WAITCOUNT=WAITCOUNT-1 %C
         %ELSE WAITCOUNT=0
      %IF WAITCOUNT=0 %START
         OPMESS("ERROR REPORTING ON")
         RETRY COUNT=0
         I=COM_INHSSR
         J=I>>16;  I=I&X'FFFF'
         J=J!!(-1)
         *LB_I;  *LSS_(0+%B)
         *AND_J;  *ST_(0+%B)
      %FINISH
   %FINISH
%END
%EXTERNALROUTINE ELAPSED INT(%RECORDNAME P)
!**********************************************************************
!*                                                                     *
!*   ELAPSED INTERVAL TIMER                                            *
!*                                                                     *
!* ACT 0 = CALL FROM RTC INTERRUPT HANDLER (CURRENTLY ONCE PER SEC)    *
!* ACT 1 = Q/UNQ NOMINEE FOR KICK EVERY N SECONDS                      *
!* ACT 2 = Q NOMINEE FOR ONCE-OFF KICK IN N SECONDS                    *
!*                                                                     *
!* WHERE : P_P1 IS ROUTINE TO BE KICKED                                *
!*       : P_P2 IS (A) SECONDS TO ELAPSE BEFORE KICK (0<P_P2<X8000)    *
!*              OR (B) UNQ NOMINEE (P_P2 = -1,ACT 1 ONLY)              *
!*       : P_P3 IS PARAMETER RETURNED TO KICKED ROUTINE IN P_P1        *
!***********************************************************************
%ROUTINESPEC QUEUE
%ROUTINESPEC UNQUEUE(%INTEGER N)
%INTEGERFNSPEC SLOT(%INTEGER N)
%RECORDSPEC P(PARMF)
%RECORDFORMAT QF(%INTEGER DEST,KLOKTIKS,PARM,PROCNO,%STRING(7)USER, %C
               %INTEGER P5,P6,LINK)
%RECORDNAME Q(QF)
%SWITCH ACT(0:2)
%INTEGER I, SRCE, PROCNO
%INTEGERNAME HEAD
      HEAD==COM_ELAP HEAD
      SRCE=P_SRCE
      I=P_DEST&X'FFFF'
      ->ACT(I) %IF 0<=I<=2
      PRINTSTRING("ELAPSED ITN REJECTS: ")
      PTREC(P)
      %RETURN
ACT(0):                                 !RTC INTERRUPT
      P_SRCE=P_DEST
      P_P5=M'ELAP'
      P_P6=M' INT'
      I=HEAD
      %WHILE I>0 %CYCLE
         Q==PARM(I)
         I=Q_LINK
         %IF Q_DEST#0 %START
            Q_KLOKTIKS=Q_KLOKTIKS-1
            %IF Q_KLOKTIKS&X'FFFF'=0 %START
               P_DEST=Q_DEST
               P_P1=Q_PARM
!
! CHECK USER PROCESS HAS NOT LOGGED OFF AND IF SO CANCELL REQUEST
!
               PROCNO=Q_PROCNO
               %IF PROCNO=0 %OR Q_USER=PROCA(PROCNO)_USER %THEN %C
                  PON(P) %ELSE Q_KLOKTIKS=0
               %IF Q_KLOKTIKS=0 %THEN UNQUEUE(Q_DEST) %C
                  %ELSE Q_KLOKTIKS=Q_KLOKTIKS!Q_KLOKTIKS>>16
            %FINISH
         %FINISH
      %REPEAT
      %RETURN
ACT(1):                                 !REQUEST TIMER INTERRUPT
      %IF P_P2<0 %THEN UNQUEUE(P_P1) %AND %RETURN
ACT(2):                                 !ONE TIME ONLY
      %RETURN %IF X'7FFF'<P_P2<1
      %IF I=1 %THEN P_P2=P_P2<<16+P_P2
      QUEUE
      %RETURN
%ROUTINE QUEUE
%INTEGER CELL,PROCNO
      %RETURN %IF SLOT(P_P1)#0;         !ALREADY Q'D
      CELL=NEWPPCELL
      Q==PARM(CELL)
      Q_P6=0
      Q_LINK=HEAD
      PARM(HEAD)_P6=CELL
      HEAD=CELL
      Q_DEST=P_P1
      Q_KLOKTIKS=P_P2
      Q_PARM=P_P3
      PROCNO=P_P1>>16-LOCSN0
      %IF PROCNO<0 %THEN PROCNO=0 %ELSE PROCNO=PROCNO&(MAXPROCS-1)
      Q_PROCNO=PROCNO
      Q_USER=PROCA(PROCNO)_USER %IF PROCNO>0
%END
%ROUTINE UNQUEUE(%INTEGER N)
%INTEGER I
%RECORDNAME Q(QF)
      I=SLOT(N)
      %RETURN %IF I=0;                  !NOT Q'D
      Q==PARM(I)
      %IF Q_P6=0 %THEN HEAD=Q_LINK %ELSE PARM(Q_P6)_LINK=Q_LINK
      %IF Q_LINK#0 %THEN PARM(Q_LINK)_P6=Q_P6
      RETURN PPCELL(I)
%END
%INTEGERFN SLOT(%INTEGER DEST)
%INTEGER I, J
      I=HEAD
      %WHILE I>0 %CYCLE
         Q==PARM(I)
         %RESULT =I %IF Q_DEST=DEST
         I=Q_LINK
      %REPEAT
      %RESULT =0
%END
%END
%EXTERNALROUTINE SYSERR(%INTEGER STK, IP)
!***********************************************************************
!*    CALLED AFTER RECOVERED AND UNRECOVERED SYSTEM ERRORS             *
!*    IP=SYTEM ERROR INTERUPT PARAMETER. STACK =INTERUPTED SSN         *
!***********************************************************************
%ROUTINESPEC PRINT PHOTO
%CONSTSTRING(19)%ARRAY FCODE(0:3)="SOFTWARE ERROR",
  "IRRECOVERABLE ERROR","SUCCESSFUL RETRY","UNSUCCESSFUL RETRY"
%CONSTSTRING(31)%ARRAY S70(5:15)= %C
  "HANDKEY GEN. SYS. ERR. INT.","ACS=0 ON ACTIVATE",
  "SOFTWARE GEN. SYS. ERR. INT.","TABLE SEARCH > 4",
  "SSN ERROR","MASKED EXTRACODE INT.","MASKED OUT INT.",
  "MASKED SYS. CALL INT.","MASKED PROG. ERR. INT.",
  "MASKED VIRTUAL STORE INT.","ILLEGAL VIRTUAL STORE INT."
%CONSTSTRING(31)%ARRAY H70(0:15)="POWER SUPPLY MON.",""(5),
  "MULTIEQUIVALENCE (ATU)","MISS AFTER TABLE SEARCH",
  "MICROPROGRAM STORE","OCP FAIL","INSTR. FETCH UNIT FAIL",
  "TIME OUT","SLAVE FAIL","ATU FAIL","HAMMING","STORE FAIL"
%INTEGER I, J, K, FC, FPN, SACREG, TRUNK, ACT0, ACT1, ACT2,  %C
         ACT3, DR, AD
%RECORD Q(PARMF)
%OWNINTEGER DEPTH=0
%CONSTINTEGER STORE ERR COUNT=8
%CONSTINTEGER UNDUMPSEG=X'80280000',SUPSTACK=X'80100000',LCSTACK=0,%C
              RESTACK=X'80180000'
      ->RECURSIVE %IF DEPTH#0
      DEPTH=1
      FC=IP>>27&3
      FPN=IP>>29
!
! 2980 HAS DIFFERENT FAILURE CODE TO 2970&2960. TRANSPOSE FC TO 70 MODE
!
      %IF COM_OCPTYPE=4 %OR COM_OCPTYPE=6 %THEN FC=(X'1320'>>(4*FC))&15
      SACREG=0
      TRUNK=0
      I=COM_LSTL
      *LB_I ;  *LSS_(0+%B)
      *ST_ACT0
      I=COM_LSTB
      *LB_I ;  *LSS_(0+%B)
      *ST_ACT1
         ACT2=0
         ACT3=STK
      PRINT STRING("
SYSTEM ERROR INTERRUPT OCCURRED
 PARAMETER ".STRHEX(IP)."
 FAILING PORT NUMBER ".STRINT(FPN)."
 ".FCODE(FC)."
 ACR LEVEL ".STRINT(IP>>20&15))
      PRINTSTRING("
 OLD STACK=".STRHEX(STK)."
")
      %IF IP&X'20000'#0 %THEN PRINT STRING(" *****NO")
      PRINT STRING(" DUMP IN SSN+1
")
      %IF IP&X'40000'#0 %THEN PRINTSTRING("NO PHOTOGRAPH
")       %ELSE PRINTSTRING("PHOTO SMAC".STRINT(IP>>16&1)."
")
      PRINT PHOTO
!
! IF THE OLD STACK WAS SUPERVISOR OR LOCAL CONTROLLER THEN FAULT WAS
! EITHER UNRECOVERABLE HARDWARE ERROR OF MASKED PROGRAM ERROR. IN
! NEITHER CASE CAN WE CONTINIUE SO FORCE DIAGNOSTICS AND A CRAPOUT
! IF THE OLD STACK WAS A USER STACK THEN IT MUST HAVE BEEN A H-W ERROR
! SINCE PROGRAM ERRORS ARE UNMASKED. IN THIS CASE USE EVENT PENDING
! TO PASS CONTROL TO THE LOCAL CONTROLLER. BEFORE DOING THIS REMOVE
! 'INSTRUCTION INCOMPLETE' FROM OLD SSR SINCE INSTRUCTION IS COMPLETED
! BEFORE EVENT PENDING IS TAKEN AND THIS MIGHT CAUSE A FURTHER H-W ERROR
! AND HENCE A LOOP
!
      %UNLESS STK=SUPSTACK %OR STK=LCSTACK %START
         ACT0=ACT0!1;                   ! THIS BIT CAUSE E-P
         I=STK+X'40003';                ! ADDR OF SSR IN DUMP SEG
         INTEGER(I)=INTEGER(I)&X'7FFFFFFF';! REMOVE II BIT
         DEPTH=0
         *ACT_ACT0;                     ! TO LC VIA EVENT PENDING
      %FINISH
      INTEGER(UNDUMPSEG)=IP
      INTEGER(UNDUMPSEG+4)=STK
      INTEGER(UNDUMPSEG+8)=ACT0
      INTEGER(UNDUMPSEG+12)=ACT1
      I=INTEGER(STK!X'40000');          ! OLD LNB
      *LSS_I
      *ST_(%LNB+0)    ;                 ! TO FRIG %MONITOR
      PRINTSTRING("DISASTER
")
      %MONITOR
      %IF HANDKEYS&X'FFFF'#0 %START
         ACT3=RESTACK
         *ACT_ACT0
      %FINISH
RECURSIVE:
      *IDLE_X'DEAD'
%ROUTINE PRINT PHOTO
!***********************************************************************
!*       PRINTS THE PHOTOGRAPH AND OTHER BITS NOT REQUIRED             *
!*        IN SINGLE BITE ERROR REPORTIN                                *
!***********************************************************************
%CONSTSTRING(7)%ARRAY CONT(0:3)="NOTHING"," SFC "," FPC2 "," GPC ";
%INTEGER I,J,CONTYPE
      %IF FC=0 %THEN %START;            ! SOFTWARE ERROR
         %CYCLE I=5,1,15
            %IF IP&1<<I#0 %THEN PRINT STRING(S70(I))
         %REPEAT
      %FINISH %ELSE %START;             ! HARDWARE ERRORS
         %CYCLE I=0,1,15
            %IF IP&1<<I#0 %THEN PRINT STRING(H70(I))
         %REPEAT
      %FINISH
      %IF IP&X'40000'#0 %THEN %RETURN;  ! NO PHOTO TAKEN
      PRINTSTRING("PHOTOGRAPH AREA
")
      DUMP TABLE(0,X'81000100',X'700')
%END
%END
!-----------------------------------------------------------------------

%OWNLONGINTEGER VSN=X'5344495343205631';     ! M'SDISC V1'
! DRIVING DISCS VIA DCU WRITTEN BY PDS JAN 79
!
%RECORDFORMAT TCBF(%INTEGER CMD,STE,DATA LEN,DATA AD,NEXT TCB, %C
   RESP,PRE0,PRE1,PRE2,PRE3,POST0,POST1,POST2,POST3,POST4,POST5, %C
      POST6,POST7)
%RECORDFORMAT INITF(%BYTEINTEGER MECH,CMASK,SMASK,MODE,FN,SEG, %C
      %HALFINTEGER CYL, %BYTEINTEGER HEAD,HDLIMIT, %HALFINTEGER SCYL, %C
      SHEAD, %BYTEINTEGER SECT,OFFSET,%HALFINTEGER DL)
%RECORDFORMAT DDTFORM(%INTEGER SER,PTS,PROPADDR,STATUS, %C
      CCA,GRCBAD,LASTT,LAST TCBAD,STATE,PAW,IW2,SENSE1,SENSE2,SENSE3,%C
      SENSE4,UASTE,BASE,ID,DLVN,MNEMONIC,%STRING(6)LAB, %BYTEINTEGER %C
      HWCODE,%INTEGER ENTSIZE,URCB AD,SENSDAT AD,LOGMASK,STATS,%C
      UA SIZE,UA AD,TIMEOUT,PROPS0,PROPS1)
!
%RECORDFORMAT PROPFORM(%INTEGER TRACKS,CYLS,PPERTRK,BLKSIZE,TOTPAGES,%C
      RQBLKSIZE,LBLKSIZE,ALISTSIZE,KEYLEN,SECTINDX)
!
%RECORDFORMAT LABFORM(%BYTEINTEGERARRAY VOL(0:5),%BYTEINTEGER S1,%C
      S2,S3,S4,ACCESS,%BYTEINTEGERARRAY RES(1:20),%BYTEINTEGER C1,C2,%C
      AC1,AC2,TPC1,TPC2,BF1,BF2,%BYTEINTEGERARRAY POINTER(0:3), %C
      IDENT(1:14))
!
%RECORDFORMAT QFORM(%BYTEINTEGER QSLOT,STATE,SP1,SP2, %INTEGER %C
         CYLEPS,REQLINK,CURRPOS,PROPADDR,DDTADDR,SEMA,TRLINK)
%RECORDFORMAT REQFORM(%INTEGER DEST, FAULTS, IDENT, DADDR,  %C
      COREADDR, CTS, %BYTEINTEGER SECT, TRNO, SPARE, REQTYPE,  %C
      %INTEGER STOREX, REQLINK)
%CONSTINTEGER DCU SERV=X'300000',%C
      DISCMSNO=X'00200000', TCB SIZE=4*18,IDATASIZE=18,%C
      PDISCSNO=X'210000'
%OWNINTEGER EPAGESIZE,TRANSIZE
%OWNBYTEINTEGERARRAY LVN(0:99)=254(100)
%OWNRECORDARRAYFORMAT QSPACEF(1:512)(QFORM)
%OWNRECORDARRAYNAME QSPACE(QFORM)
!
%CONSTLONGINTEGER LONGONE=1
%OWNINTEGER DDT ADDR,NDISCS
%STRING(4)%FN MTOS(%INTEGER M)
%INTEGER I,J
      I=4; J=M
      %RESULT=STRING(ADDR(I)+3)
%END
%EXTERNALROUTINE DISCMINDER(%RECORDNAME P)
%RECORDSPEC P(PARMF)
%ROUTINESPEC READ DLABEL(%RECORDNAME DDT)
%ROUTINESPEC UNLOAD(%RECORDNAME DDT)
%ROUTINESPEC SENSE(%RECORDNAME DDT,%INTEGER VAL)
%RECORDNAME DDT(DDTFORM)
%RECORDNAME LABEL(LABFORM)
%RECORDNAME COM(COMF)
%RECORDNAME TCB(TCBF)
%RECORD Q(PARMF)
%OWNINTEGER INITINH,LABREADS
%INTEGER ACT,I,J,SLOT
%STRING(40)S
%SWITCH INACT(0:7),AINT,FINT,NINT(0:11)
      ACT=P_DEST&X'FFFF'
?      %IF KMON&(LONGONE<<(DISCMSNO>>16))#0 %THEN PRINTSTRING("
DISCM: ") %AND PTREC(P)
      *LXN_P+4
      *LSQ_(%XNB+0)
      *LB_X'D15C'
      ->INACT(ACT)
INACT(0):                               ! INITIALISATION
                                        ! NOW NO PARAMETERS!
      COM==RECORD(X'80C00000');         ! ONTO COMMS SEGMENT
      EPAGESIZE=COM_EPAGESIZE
      TRANSIZE=EPAGESIZE*1024
      NDISCS=COM_NDISCS
      DDTADDR=COM_DDTADDR
      QSPACE==ARRAY(COM_DQADDR,QSPACEF)
      INITINH=1
      INHIBIT(PDISCSNO>>16)
      %CYCLE J=0,1,NDISCS-1
         DDT==RECORD(INTEGER(DDTADDR+4*J))
         DDT_UASTE=INTEGER(PSTVA+4+DDT_UAAD<<1>>19<<3)
         SENSE(DDT,0)
         DDT_STATE=1;               ! READ VOL LABELS
      %REPEAT
      P_DEST=PDISCSNO
      PDISC(P)
      %RETURN
INACT(1):                               ! ALLOCATE AS PER DCU
                                        ! REQUEST FORWARDED TO DCU
                                        ! THE DISC FIRST BEING DEALLOCATED
                                        ! IF NECESSARY
      %CYCLE I=0,1,NDISCS-1
         DDT==RECORD(INTEGER(DDTADDR+4*I))
         %IF P_P1=DDT_MNEMONIC %THEN ->HIT
         %REPEAT
ONTODCU:
      P_DEST=DCU SERV+4
      PON(P)
      %RETURN
HIT:
      Q_DEST=DCU SERV+5
      Q_SRCE=X'80000000'!DISCMSNO
      Q_P1=P_P1
      %IF DDT_STATE=4 %OR DDT_STATE=5 %START
         DDT_STATE=11
         DCU(Q)
      %FINISH
      ->ONTODCU
INACT(6):                               ! PCI(??) OR LOGGING REQUEST
      OPMESS("DISC MINDER ACT 6??")
      P_DEST=P_SRCE
      P_SRCE=DISCMSNO!6
      P_P1=-1
      PON(P)
      %RETURN
INACT(7):                               ! REPLY FROM DCU START DEV
      %IF P_P1#0 %THEN OPMESS("DISCM STARTDEV FAILS ".STRINT(P_P1))
      %RETURN
!
! A DISC MAY BE IN ANY ONE OF THE FOLLOWING STATES(HELD IN DDT_STATE):-
!     0 = DEAD (NOT ON LINE OR UNLOADED)
!     1 = CONNECT INTERFACE & SENSE ISSUED
!     2 = READ LABEL ISSUED
!     3 = DISCONNECT (IE UNLOAD) ISSUED. MUST RECONNECT ON TERMNTN
!
! IF THE LABEL WAS VALID  THE STATES THEN GO:=
!     4 = AVAILABLE FOR PAGED OR PRIVATE USE
!     5 = PAGED TRANSFER ISSUED
!     6-9 RESERVED FOR POSSIBLE ERROR RECOVERY
!
!     NONEXISTENT OR INVALD LABELS THEN GO
!     10 = AVAILABLE FOR PRIVATE USE
!     11 = CLAIMED FOR PRIVATE USE BY SER=DDT_STATUS
!     12 = PRIVATE CHAIN ISSUED
!
! NB ONLY STATES 0-3 & 10 CONCERN DISCMINDER. OTHERS ARE PDISC OR DCU
!
INACT(4):                               ! NOTE LVN P_P1 NOW CHECKED
      I=P_P1; J=LVN(I)
      %IF J>=NDISCS %THEN %RETURN;      ! CRAP LVN
      DDT==RECORD(INTEGER(DDTADDR+J*4))
      DDT_DLVN=DDT_DLVN&255
      %RETURN
!***********************************************************************
!*    DISC INTERRUPT HANDLING SEQUENCE                                 *
!***********************************************************************
INACT(2):                               ! NORMAL TERMINATION
      DDT==RECORD(P_P3)
      ->NINT(DDT_STATE)
INACT(3):                               ! ATTENTION
      DDT==RECORD(P_P3)
      ->AINT(DDT_STATE)
INACT(5):                               ! ABNORMAL TERMINATION
      DDT==RECORD(P_P3)
      ->FINT(DDT_STATE)
NINT(4):FINT(4):
NINT(10):FINT(10):
NINT(11):FINT(11):
NINT(0):FINT(0):                        ! DEAD DISC TERINATES?
      PRINTSTRING('INT STATE '.STRINT(DDT_STATE).' ?????
')
      %RETURN
NINT(1):                                ! SENSE TERMINATES
      TCB==RECORD(DDT_UAAD)
      DDT_SENSE1=TCB_POST0
      DDT_SENSE2=TCB_POST1
      DDT_SENSE3=TCB_POST2
      DDT_SENSE4=TCB_POST6
      %IF DDT_SENSE4<0 %THEN %START;    ! DISC IN AUTO
         READ DLABEL(DDT)
         LABREADS=LABREADS+1
         DDT_STATE=2
      %FINISH %ELSE DDT_STATE=0
      %RETURN
NINT(2):                                ! LABEL READ SUCCESSFULLY
      LABREADS=LABREADS-1
      %IF INITINH=1 %AND LABREADS=0 %THEN %C
         INITINH=0 %AND UNINHIBIT(PDISCSNO>>16)
      LABEL==RECORD(DDT_UA AD+2*TCB SIZE)
      ETOI(ADDR(LABEL),6)
      DDT_DLVN=-1
      %CYCLE I=0,1,5
         BYTEINTEGER(ADDR(DDT_LAB)+1+I)=LABEL_VOL(I)
      %REPEAT
      LENGTH(DDT_LAB)=6
      %IF LABEL_ACCESS= X'C5' %THEN %START
         %CYCLE I=0,1,3
            BYTEINTEGER(ADDR(DDT_BASE)+I)=LABEL_POINTER(I)
         %REPEAT
         S=' EMAS'
         DDT_STATE=4
!
! ARRAY LVN STORE SLOT NO INSTEAD OF ADDRESS TO SAVE SPACE
! SLOT NOT NOW NEEDED ELSEWHERE. SET UP HERE PRO TEM
!
         %CYCLE SLOT=0,1,NDISCS-1
            %IF INTEGER(DDTADDR+4*SLOT)=ADDR(DDT) %THEN %EXIT
         %REPEAT
         %IF '0'<=LABEL_VOL(4)<='9' %AND '0'<=LABEL_VOL(5)<='9' %START
            I=(LABEL_VOL(4)&X'F')*10+LABEL_VOL(5)&X'F'
            %IF LVN(I)>=254 %OR LVN(I)=SLOT %THEN %START
               LVN(I)=SLOT
               DDT_DLVN=I!X'80000000'
            %FINISH %ELSE %START
               OPMESS("DUPLICATE DISC LVN!")
               UNLOAD(DDT)
               DDT_STATE=3; %RETURN
            %FINISH
!
! CLAIM THE DISC FROM DCU ON BEHALF OF PDISC
!
            P_DEST=DCU SERV+7;          ! SPECIAL ALLOCATE
            P_SRCE=PDISCSNO+10
            P_P1=DDT_MNEMONIC
            P_P2=0;                     ! CALL NOT PON
            P_P3=10;                    ! ADD 10 TO STANDARD ACTS
            P_P4=PDISCSNO>>16;          ! FOR ATTENS
            PON(P)
         %FINISH
      %FINISH %ELSE %START
         DDT_BASE=0
         S=' FRGN'
         DDT_STATE=10
      %FINISH
      OPMESS(MTOS(DDT_MNEMONIC).' LOADED '.DDT_LAB.S)
      %RETURN
FINT(1):                                !SENSE FAILS
      DDT_STATE=0; %RETURN
FINT(2):                                ! READ LABEL FAILS
      LABREADS=LABREADS-1
      DDT_LAB='NOLABL'
      DDT_DLVN=-1
      DDT_STATE=10
      OPMESS(MTOS(DDT_MNEMONIC).' LOADED NO LABEL')
      DDT_BASE=0
      %RETURN
NINT(3):FINT(3):                        ! UNLOAD COMPLETE
      DDT_STATE=0
      OPMESS(MTOS(DDT_MNEMONIC).' UNLOADED')
      %IF DDT_DLVN#-1 %THEN LVN(DDT_DLVN&255)=255
      %RETURN
AINT(2):
      LABREADS=LABREADS-1
AINT(0):AINT(1):                        ! ATTENTION WHILE INITIALISING
      PRINTSTRING('ATTNTN WHILE INITNG '.MTOS(DDT_MNEMONIC))
      DDT_STATE=1
      SENSE(DDT,1);                     ! START SEQUENCE AGAIN
AINT(3):                                ! EXTRA ATTENTION CAUSED BY UNLOAD
      %RETURN
AINT(4):                                ! ATTENTION WHILE CLAIMED BY PDISC
      Q_DEST=DCU SERV+5
      Q_SRCE=DISCMSNO!X'80000000'
      Q_P1=DDT_MNEMONIC
      DCU(Q)
AINT(10):                               ! ATTENTION WHILE IDLE
                                        ! ATTENTION <<8 IN P_P1
      %IF P_P1>>8&1#0 %START;           ! HOLD BIT SET
         UNLOAD(DDT)
         DDT_STATE=3
         %RETURN
      %FINISH
      DDT_STATE=1
      SENSE(DDT,0)
      %RETURN
AINT(11):                               ! ATTENTION WHEN HANDING DISC
                                        ! BACK TO DCU FOR PRIVATE USE
      DDT_STATE=0; %RETURN
%ROUTINE UNLOAD(%RECORDNAME DDT)
!***********************************************************************
!*    PERFORMS A DISCONNECT INTERFACE WHICH UNLOADS THE DISC           *
!***********************************************************************
%RECORDSPEC DDT(DDTFORM)
%RECORDNAME TCB(TCBF)
      TCB==RECORD(DDT_UA AD)
      TCB_CMD=X'2C004008';              ! UNLOAD IGNORE SHRT & LONG
      TCB_STE=DDT_UASTE
      TCB_DATA LEN=4
      TCB_DATA AD=ADDR(TCB_PRE0)
      TCB_NEXT TCB=0
      TCB_RESP=0
      P_DEST=DCU SERV+10
      P_SRCE=DISCMSNO+7
      P_P1=ADDR(TCB)
      P_P2=DDT_SER
      P_P4=M'UNLD'
      PON(P)
%END
%ROUTINE READ DLABEL(%RECORDNAME DDT)
!***********************************************************************
!*    READS SECTOR 0 HEAD 0 CYL 0 WHICH SHOULD BE 80 BYTE VOL LABEL    *
!***********************************************************************
%RECORDSPEC DDT(DDTFORM)
%RECORDNAME INIT TCB,TCB(TCBF)
%RECORDNAME INIT DATA(INITF)
%INTEGER I
      INIT TCB==RECORD(DDT_UA AD)
      TCB==RECORD(ADDR(INIT TCB)+TCB SIZE)
      INIT DATA==RECORD(ADDR(TCB)-IDATASIZE)
      INIT TCB=0
      TCB=0
      INIT TCB_CMD=X'2C404081'
      INIT TCB_NEXT TCB=ADDR(TCB)
      I=DDT_UASTE
      INIT TCB_STE=I
      TCB_STE=I
      INIT TCB_DATA LEN=IDATASIZE
      INIT TCB_DATA AD=ADDR(INIT DATA)
      INIT DATA_SMASK=X'FE';            ! MASK NOWT
      INIT DATA_FN=X'20';               ! RESTORE
      TCB_CMD=X'20404012'
      TCB_DATA LEN=80
      TCB_DATA AD=DDT_UA AD+2*TCBSIZE
      P_DEST=DCUSERV+10
      P_SRCE=DISCMSNO+7
      P_P1=ADDR(INIT TCB)
      P_P2=DDT_SER
      P_P4=M'RLAB'
      PON(P)
%END
%ROUTINE SENSE(%RECORDNAME DDT,%INTEGER VAL)
!***********************************************************************
!*    PERFORM A SENSE ON DEVICE WHOSE DDT SLOT IS DDT.VAL=0 FOR INITIAL*
!*    SENSE SENSE TO BE PRECEEDED BY A CONNECT STREAM                  *
!***********************************************************************
%RECORDSPEC DDT(DDTFORM)
%RECORDNAME TCB(TCBF)
      TCB==RECORD(DDT_UA AD)
      TCB_CMD=X'2C004004';              ! SENSE IGNORE SHRT & LONG
      TCB_STE=DDT_UASTE
      TCB_DATA LEN=32
      TCB_DATA AD=ADDR(TCB_POST0)
      TCB_NEXT TCB=0
      TCB_RESP=0
      P_DEST=DCU SERV+10
      P_SRCE=DISCMSNO+7
      P_P1=ADDR(TCB)
      P_P2=DDT_SER
      P_P4=M'SNSE'
      PON(P)
%END
%END
%ROUTINE DREPORT(%RECORDNAME DDT,FTCB)
!***********************************************************************
!*    PRINTS OUT A FAILURE REPORT IN A READABLE FORM                   *
!***********************************************************************
%CONSTINTEGER TCBPSIZE=40;              ! BYTES OF TCB TO BE DUMPED
%RECORDSPEC DDT(DDTFORM)
%CONSTSTRING(8)%ARRAY SENSEM(0:7)="S0T1T2T3","T4T5T6T7",
                  "T8T9TAC0","C1C2C3C4","C5C6M0M1",
                  "M2M3M4M5","M6M7M8M9","MAXXXXXX";
%RECORDSPEC FTCB(TCBF)
%INTEGER I,J,N
      PRINTSTRING("DISC TRANSFER ".DDT_LAB." ON ". %C
         MTOS(DDT_MNEMONIC)." (".HTOS(DDT_PTS,6).") FAILS "%C
         .DATE." ".TIME)
      PRINTSTRING("
TCB RESPONSE =".HTOS(FTCB_RESP,8)."
SENSE DATA
")
      %CYCLE I=0,1,7
         PRINTSTRING(SENSEM(I)." ".STRHEX(INTEGER(DDT_SENSDAT AD+4*I)))
         NEWLINE
      %REPEAT
      PRINTSTRING("
COMPLETE CHAIN OF TCBS BEFORE FAILURE
")
      N=(ADDR(FTCB)-DDT_UA AD)//TCBSIZE
      %CYCLE J=0,4,TCBPSIZE-4
         %CYCLE I=0,1,N
            PRINTSTRING(HTOS(INTEGER(DDT_UAAD+I*TCBSIZE+J),8))
            %IF J=0 %AND I#N %THEN PRINTSTRING("->") %ELSE SPACES(2)
         %REPEAT
         NEWLINE
      %REPEAT
      NEWLINE
%END
%EXTERNALROUTINE PDISC(%RECORDNAME P)
!***********************************************************************
!*    RECEIVES PAGED DISC TRANSFERS. ORGANISES ALL QUEUING AND         *
!*    GENERATES THE TCBS WHICH ARE THE PASSED TO DCU FOR EXECUITION    *
!***********************************************************************
%RECORDSPEC P(PARMF)
%RECORDNAME DDT(DDTFORM)
%RECORDNAME PROP(PROPFORM)
%RECORDNAME INIT TCB,TCB(TCBF)
%RECORDNAME INIT DATA(INITF)
%RECORDNAME QHEAD(QFORM)
%RECORDNAME REQ(REQFORM)
%RECORDNAME ACELL(PARMXF)
%CONSTINTEGERARRAY CMD(1:5)=X'20404012',
                  X'20400413'(2),X'20404212',X'20404012';
%CONSTINTEGER PDISCSNO=X'210000';          ! PDISC SERVICE NO(33)
%CONSTINTEGER RETRIES=21,MAXTRANS=7
%CONSTINTEGER TRANOK=0, TRANWITHERR=1, TRANREJECT=2,  %C
      NOTTRANNED=3, PTACT=5
%ROUTINESPEC PTREPLY(%RECORDNAME REQ,%INTEGER FAIL)
%ROUTINESPEC QUEUE(%RECORDNAME QHEAD,%INTEGER REQ)
!
! ERROR RECOVERY CONSISTS OF MAKING RETRIES WITH STROBE NORMAL,EARLY
! AND LATE AND THE FOLLOWING HEAD OFFSETS:-
!           0,+12,-12,+24,-24,+36,-36
! THIS GIVES 21 ADDITIONAL READS. THE FIRST RETRY IN NORMAL AS ADVISED
! THE ARRAY CORRN CONTAINS MODE,FUNCTION&OFFSET BYTES IN BTM 24 BITS
!
%CONSTINTEGERARRAY CORRN(0:22)=0,
                                        X'001C00',X'204C00',X'104C00',
                                        X'004C0C',X'204C0C',X'104C0C',
                                        X'004C8C',X'204C8C',X'104C8C',
                                        X'004C18',X'204C18',X'104C18',
                                        X'004C98',X'204C98',X'104C98',
                                        X'004C24',X'204C24',X'104C24',
                                        X'004CA4',X'204CA4',X'104CA4',
                                        X'008C00';
%SWITCH PDA(0:15)
%OWNINTEGER INIT
%INTEGER I,ACT,J,TCBA,UNIT,LUNIT,CYL,TRACK,SECT,CELL,FTRNO,K,FAIL, %C
         NEXT SEEK, SRCE
      ACT=P_DEST&X'FFFF'
?      %IF KMON&(LONGONE<<(PDISCSNO>>16))#0 %THEN PRINTSTRING("
PDISC: ") %AND PTREC(P)
      ->PDA(ACT)
PDA(0):                                 ! INITIALISE
      %IF INIT#0 %THEN %RETURN;         ! IN CASE !
      %CYCLE I=0,1,NDISCS-1
         QHEAD==QSPACE(I+1)
         DDT==RECORD(INTEGER(DDTADDR+I*4))
         QHEAD=0;                       ! ZERO WHOLE RECORD
         QHEAD_QSLOT=I+1
         QHEAD_PROPADDR=DDT_PROPADDR
         PROP==RECORD(QHEAD_PROPADDR)
         QHEAD_CYLEPS=PROP_PPERTRK*PROP_TRACKS
         QHEAD_DDTADDR=ADDR(DDT)
         QHEAD_SEMA=-1
      %REPEAT
      INIT=1
      %RETURN
PDA(5):                                 ! PAGETURN REQUEST(IE READ)
                                        ! P_P1=AMTX/EPX
                                        ! P_P2=DISCADDR
                                        ! P_P3=STOREX
                                        ! P_P4=PRIOITY 0=HIGH,1=LOW
      P_P6=P_P3;                        ! SAVE STOREX
      P_P3=STORE(P_P3)_REALAD!X'81000000';    ! TURN INTO PDA(1) FORM
PDA(1):                                 ! READ REQUEST
PDA(2):                                 ! WRITE REQUEST
PDA(3):                                 ! WRITE + CHECK(TREATED AS WRITE)
PDA(4):                                 ! CHECK READ
                                        ! ALL HAVE _P2=DISCADDR AND
                                        ! _P3 =COREADDR
      SRCE=P_SRCE&X'7FFFFFFF'
      UNIT=P_P2>>24
      J=P_P2&X'FFFFFF';                 ! FSYS RELATIVE PAGE
      LUNIT=LVN(UNIT)
      ->REJECT %IF LUNIT>=NDISCS
      QHEAD==QSPACE(LUNIT+1)
!      PROP==RECORD(QHEAD_PROPADDR)
!      I=J//PROP_PPERTRK
!      SECT=J-I*PROP_PPERTRK+1
!      CYL=I//PROP_TRACKS
!      TRACK=I-CYL*PROP_TRACKS
      *LCT_QHEAD+4
      *LXN_(%CTB+4);                    ! XNB TO PROPS RECORD
      *LSS_J
      *IMDV_(%XNB+2);                   ! _PPERTRK
      *IMDV_(%XNB+0);                   ! PROP_TRACKS
      *ST_CYL
      *LB_%TOS
      *STB_TRACK
      *LB_%TOS
      *ADB_1
      *STB_SECT
      *ICP_(%XNB+1);                    ! PROP_CYLS
      *JCC_2,<REJECT>
!      DDT==RECORD(QHEAD_DDTADDR)
!      CYL=CYL+DDT_BASE
!      %IF CYL>PROP_CYLS %THEN ->REJECT
!
!*SEM      *INCT_PARMSEMA
!*SEM      *JCC_8,<PSEMAGOT>
!*SEM      SEMALOOP(PARMSEMA)
!*SEMPSEMAGOT:
      %IF PARMASL=0 %THEN MORE PPSPACE
      ACELL==PARM(PARMASL)
      CELL=ACELL_LINK
      REQ==PARM(CELL)
      %IF CELL=PARMASL %THEN PARMASL=0 %ELSE %C
         ACELL_LINK=REQ_REQLINK
      PARMSEMA=-1
      REQ<-P
      REQ_DEST=SRCE
      REQ_FAULTS=0
      REQ_CTS=CYL<<16!TRACK
      REQ_SECT=SECT
      REQ_REQTYPE=ACT
!*SEM      *LXN_QHEAD+4
!*SEM      *INCT_(%XNB+6);                   ! QHEAD_SEMA
!*SEM      *JCC_8,<QSEMAGOT1>
!*SEM      SEMALOOP(QHEAD_SEMA)
!*SEMQSEMAGOT1:
      QUEUE(QHEAD,CELL)
      ->INIT TRANSFER %IF QHEAD_STATE=0; ! UNIT IDLE
      QHEAD_SEMA=-1
      %RETURN
REJECT:                                 ! REQUEST INVALID
      PRINTSTRING('*** PDISC REJECTS ')
      PTREC(P)
      P_DEST=SRCE
      P_SRCE=PDISCSNO+ACT
      P_P2=TRANREJECT;                  ! REJECTED
      %IF ACT=PTACT %THEN PTREPLY(P,2) %ELSE PON(P)
      %RETURN
PDA(10):                                ! REPLY FROM DCU CLAIMDISC
      %RETURN
INIT TRANSFER:                          ! SET UP CHAIN AND HAND TO DISC
      DDT==RECORD(QHEAD_DDTADDR)
      REQ==PARM(QHEAD_REQLINK)
      CYL=REQ_CTS>>16
      J=CYL*QHEAD_CYLEPS
      %IF J=QHEAD_CURRPOS %THEN NEXT SEEK=X'C' %ELSE NEXT SEEK=X'1C'
      QHEAD_CURRPOS=J
      TCBA=DDT_UA AD
      %CYCLE I=1,1,MAXTRANS
         INIT TCB==RECORD(TCBA)
         TCBA=TCBA+TCBSIZE
         TCB==RECORD(TCBA)
         INIT DATA==RECORD(TCBA-IDATASIZE)
         TCBA=TCBA+TCBSIZE
         INIT TCB=0; TCB=0;             ! CLEAR ALL(INCLD INIT DATA)
         INIT DATA_SMASK=X'FE';         ! MASK NO 2NDRY STATUS
         INIT DATA_FN=NEXT SEEK;        ! SEEK CYL HD &SEG
         J=REQ_SECT
         INIT DATA_SECT=J
         INIT DATA_SEG=20*EPAGESIZE*(J-1)
         J=REQ_CTS&255
         INIT DATA_HEAD=J
         INIT DATA_SHEAD=J
         INIT DATA_CYL=CYL
         INIT DATA_SCYL=CYL
         %IF REQ_FAULTS#0 %START;       ! ARE RETRYING NOT TRANSFERING
            J=CORRN(REQ_FAULTS)
            INIT DATA_MODE<-J>>16
            INIT DATA_FN<-J>>8
            INIT DATA_OFFSET<-J
            NEXT SEEK=X'8C';            ! CLEAR OFFSET
         %FINISH
         INIT TCB_CMD=X'2C404081'
         INIT TCB_STE=DDT_UASTE
         INIT TCB_NEXT TCB=ADDR(TCB)
         INIT TCB_DATA AD=ADDR(INIT DATA)
         INIT TCB_DATA LEN=IDATASIZE
         TCB_CMD=CMD(REQ_REQTYPE&255)
         TCB_STE=INTEGER(PST VA+4+REQ_COREADDR<<1>>19<<3)
         TCB_NEXT TCB=TCBA
         TCB_DATA AD=REQ_CORE ADDR
         TCB_DATA LEN=TRANSIZE
!
! MOVE THE CELL FROM THE REQUEST QUEU TO TRANSFERINPROGRESS QUEU
!
         J=REQ_REQLINK
         REQ_REQLINK=QHEAD_TRLINK
         REQ_TRNO=I
         QHEAD_TRLINK=QHEAD_REQLINK
         QHEAD_REQLINK=J
!
! SEE IF THERE ANY MORE TRANSFERS AND IF THE ARE ON THE SAME CYL
!
         %IF J=0 %THEN %EXIT
         CELL=J
         REQ==PARM(CELL)
         %IF REQ_CTS>>16#CYL %THEN %EXIT
      %REPEAT
      TCB_NEXT TCB=0;                   ! DE CHAIN TCBS
      TCB_CMD=TCB_CMD&X'FFBFFFFF';      ! INT ON LAST TCB
      P_DEST=DCU SERV+10
      P_SRCE=PDISCSNO+X'8000000B'
      P_P1=DDT_UA AD
      P_P2=DDT_SER
      P_P4=QHEAD_QSLOT
      QHEAD_STATE=1
      QHEAD_SEMA=-1
      DDT_STATE=5
      DCU(P)
PDA(11):                                ! REPLY FROM DCU IF PONNED
                                        ! DEVICE STARTED OK
      %RETURN %UNLESS P_P1#0
      OPMESS("PDISC STARTDEV FAILS ".STRINT(P_P1))
      %RETURN
PDA(12):                                ! REPLY FORM DCU NORMAL TERMNTN
      QHEAD==QSPACE(P_P6)
      DDT==RECORD(P_P3)
      ->NOT BUSY %UNLESS DDT_STATE=5
!*SEM      *LXN_QHEAD+4
!*SEM      *INCT_(%XNB+6);                   ! QHEAD_SEMA
!*SEM      *JCC_8,<QSEMAGOT2>
!*SEM      SEMALOOP(QHEAD_SEMA)
!*SEMQSEMAGOT2:
      CELL=QHEAD_TRLINK
      %WHILE CELL#0 %CYCLE
         REQ==PARM(CELL)
         J=REQ_REQLINK
         %IF REQ_REQTYPE=PTACT %THEN PTREPLY(REQ,0) %ELSE %START
            REQ_FAULTS=PDISCSNO;        ! P_SRCE
            REQ_DADDR=0;                ! P_P2== 0 FOR OK
            FASTPON(CELL)
         %FINISH
         CELL=J
      %REPEAT
      QHEAD_TRLINK=0;                ! NO TRANSFERS IN PROGRESS
      ->INIT TRANSFER %IF QHEAD_REQLINK#0
      QHEAD_STATE=0; QHEAD_SEMA=-1
      DDT_STATE=4
      %RETURN
PDA(13):                                ! ATTENTIONS
      DDT==RECORD(P_P3)
      %IF DDT_STATE=5 %THEN %START
         OPMESS(MTOS(DDT_MNEMONIC)." IS STILL IN USE!")
         %RETURN
      %FINISH
      P_DEST=3
      DISC MINDER(P);                         ! PASS TO DISC MINDER
      %RETURN
PDA(15):                                ! ABNORMAL TERMNTN
      QHEAD==QSPACE(P_P6)
      DDT==RECORD(P_P3)
      ->NOT BUSY %UNLESS DDT_STATE=5
      DDT_STATS=DDT_STATS+X'00400000';  ! UPDATE FAILURE COUNT
      TCB==RECORD(P_P5)
      DREPORT(DDT,TCB);                 ! FOR ERA
      FTRNO=(P_P5-DDT_UA AD)//(2*TCBSIZE)+1
      FAIL=NOT TRANNED
      %IF TCB_POST0=X'10000000' %AND TCB_POST1>>24=X'80' %C
         %THEN FAIL=TRANWITH ERR;       ! CYCLIC CHECK ONLY
!*SEM      *LXN_QHEAD+4
!*SEM      *INCT_(%XNB+6)
!*SEM      *JCC_8,<QSEMAGOT3>
!*SEM      SEMALOOP(QHEAD_SEMA)
!*SEMQSEMAGOT3:
      CELL=QHEAD_TRLINK
      %WHILE CELL#0 %CYCLE
         REQ==PARM(CELL)
         QHEAD_TRLINK=REQ_REQLINK
         %IF REQ_TRNO<FTRNO %OR REQ_FAULTS>RETRIES %START
            REQ_FAULTS=PDISCSNO;         ! P_SRCE=PDISC
            %IF REQ_TRNO<FTRNO %THEN REQ_DADDR=TRAN OK %C
                               %ELSE REQ_DADDR=FAIL
            %IF REQ_DADDR#TRAN OK %THEN %START
               PRINTSTRING("PDISC TRANSFER FAILS :-")
               PTREC(REQ)
            %FINISH
            %IF REQ_REQTYPE=PTACT %THEN PTREPLY(REQ,REQ_DADDR) %ELSE %C
               FASTPON(CELL)
         %FINISH %ELSE %START
            REQ_FAULTS=REQ_FAULTS+1 %IF REQ_TRNO=FTRNO
            QUEUE(QHEAD,CELL);             ! REQUEUE FAULTY ONE  & LATERS
         %FINISH
         CELL=QHEAD_TRLINK
      %REPEAT
      ->INIT TRANSFER %IF QHEAD_REQLINK#0
      QHEAD_STATE=0
      QHEAD_SEMA=-1
      DDT_STATE=4
      %RETURN
NOT BUSY:
      OPMESS("SPUR INT ON ".MTOS(DDT_MNEMONIC))
      %RETURN
%ROUTINE PTREPLY(%RECORDNAME REQ,%INTEGER FAIL)
!***********************************************************************
!*    REPLIES TO ALL LOCAL CONTROLLERS WAITING FOR A PAGE TRANSFER     *
!*    USUALLY ONE ONLY BUT POSSIBLY SEVERAL. THIS CODE WILL GO INLINE  *
!*    FOR THE NORMAL CASE WHEN ALLTRANSFERS IN CHAIN ARE ERRORFREE     *
!***********************************************************************
%RECORDNAME REP(PARMXF)
%RECORDSPEC REQ(REQFORM)
%INTEGER L,J,STOREX
      STOREX=REQ_STOREX
      %IF FAIL>1 %THEN %START;          ! CLEAR THE PAGE
         J=REQ_COREADDR
         *LDTB_X'18000000'
         *LDB_EPAGESIZE
         *LDA_J
         *MVL_%L=%DR,0,0
      %FINISH
!*SEM      *INCT_(STORESEMA)
!*SEM      *JCC_8,<SSEMAGOT>
!*SEM      SEMALOOP(STORESEMA)
!*SEMSSEMAGOT:
      L=STORE(STOREX)_FLAGLINK
      STORE(STOREX)_FLAGLINK=L&X'3FFF0000'; ! CLEAR OUT FLAGS& LINK
      STORESEMA=-1;                     ! FREE AS SOON AS POSS
      L=L&X'FFFF'
      %UNTIL L=0 %CYCLE
         REP==PARM(L)
         %IF FAIL#0 %THEN REP_DEST=REP_DEST!1 %AND REP_P3=FAIL
         J=REP_LINK
         FASTPON(L)
         L=J
      %REPEAT
      RETURN PPCELL(CELL) %IF FAIL#2;   ! HEADCELL BACK TO FREELIST
%END
%ROUTINE QUEUE(%RECORDNAME QHEAD,%INTEGER NEWREQ)
!***********************************************************************
!*    QUEUES REQUEST IN ASCENDING PAGE(IE CYL) ORDER SO SEEK TIMES     *
!*    ARE MINIMISED                                                    *
!***********************************************************************
%RECORDSPEC QHEAD(QFORM)
%RECORDNAME NEW,ENTRY,NEXT(REQFORM)
%CONSTINTEGER QSIZE=36
%INTEGER POSN,CELL,NEXTCELL,AD
      NEW==PARM(NEWREQ)
      POSN=NEW_DADDR;                   ! PAGE ADDR OF NEW REQUEST
      CELL=QHEAD_REQLINK
      %IF CELL=0 %OR QHEAD_CURRPOS<=POSN<PARM(CELL)_P2 %START
         QHEAD_REQLINK=NEWREQ
         NEW_REQLINK=CELL
         %RETURN
      %FINISH
!      ENTRY==PARM(CELL);              ! FIRST ON THE QUEUE
!      NEXTCELL=ENTRY_REQLINK
!
!      %WHILE NEXTCELL#0 %CYCLE
!         NEXT==PARM(NEXTCELL)
!         %EXIT %IF ENTRY_DADDR<=POSN<=NEXT_DADDR
!         ENTRY==NEXT
!         NEXTCELL=ENTRY_REQLINK
!      %REPEAT
!
!      ENTRY_REQLINK=NEWREQ
      *LSS_PARM+4; *ST_AD;             ! KEEP ADDR(PARM(0))
      *LSS_POSN;                        ! POSN IN ACC THRO LOOP
      *LB_CELL; *MYB_QSIZE
      *ADB_AD; *LXN_%B;                 ! B TO RECORD ENTRY
      *LB_(%XNB+8); *STB_NEXTCELL
      *JAT_12,<XIT>;                    ! JUMP ON ZERO B
AGN:  *MYB_QSIZE; *ADB_AD; *LCT_%B;     ! CTB TO RECORD NEXT
      *ICP_(%XNB+3);                    ! POSN IN ACC (STILL)
      *JCC_4,<ON>;                      ! POSN < ENTRY_DADDR
      *ICP_(%CTB+3); *JCC_12,<XIT>;     ! POSN <= NEXT_DADDR
ON:   *LXN_%B;                          ! ENTRY==NEXT
      *LB_(%XNB+8); *STB_NEXTCELL
      *JAF_12,<AGN>
XIT:  *LSS_NEWREQ; *ST_(%XNB+8);        ! ENTRY_REQLINK=NEWREQ
      NEW_REQLINK=NEXTCELL
%END
%END
%EXTERNALROUTINE DRUM(%RECORDNAME P)
%END;                                   ! OF DRUM !!!!!!!!!
! BULK MOVER WRITTEN BY PDS 18TH NOV 76
! ADDED FEATURE FOR VOLUMES TAPES 6TH SEP 78
%EXTERNALROUTINE MOVE(%RECORDNAME P)
!***********************************************************************
!*       CALLED ON SERVICE 36 TO TRANSFERS GROUPS OF PAGES BETWEEN     *
!*       FAST DEVICES. REPLIES ARE ON SERVICE 37.                      *
!*       FAST DEVICE TYPES ARE:-                                       *
!*       DEV=1 DRUM     (SPECIFIED AS SERVICE & PAGE IN AMEM )         *
!*       DEV=2 DISCFILE (SPECIFIED AS [MNEMONIC OR LVN] & PAGE)        *
!*       DEV=3 ARCHTAPE (SPECIFIED AS SERVICE(PREPOSND BY VOLUMS))     *
!*       DEV=4 TAPE     (SPECIFIED AS STRING(6)LAB,BYTE CHAP NO)       *
!*       DEV=5 FUNNY    (READS GIVE ZERO PAGE,WRITES IN HEX TO LP)     *
!*       DEV=6 SINK       (THROWS AWAY INPUT FOR TAPE CHECKING)        *
!*                                                                     *
!*       CAN HANDLE UP TO FOUR MOVES AT A TIME. EACH MOVE USES         *
!*       ONE BUFFER AND APART FROM CLEARS ONLY HAS ONE TRANSFER        *
!*       OUTSTANDING AT ANY ONE TIME TIME.                             *
!*       ALL WRITES ARE CHECKED BY RE-READING                          *
!***********************************************************************
%INTEGERFNSPEC CHECK(%INTEGERNAME MNEM, PAGE, %INTEGER RTYEP)
%RECORDFORMAT BME(%INTEGER DEST, SRCE, STEP, COUNT, FDEV,  %C
      TODEV, L, FDINF1, FDINF2, TODINF1, TODINF2, IDENT, CORE %C
      , READ, CDEX, UFAIL, WTRANS, FVL1, FVL2, TVL1, TVL2)
%OWNRECORDARRAY BMS(1:4)(BME)
%RECORDNAME BM(BME)
%RECORDSPEC P(PARMF)
%OWNINTEGER MASK
%CONSTINTEGER TAPE POSN=9, FILE POSN=8, WRITE=2, READ PAGE=1
%CONSTINTEGER WRITETM=10, MAX TRANS=16, REWIND=17, BACK READ=6
%CONSTINTEGER REQSNO=X'240000', PRIVSNO=X'250000', MAXMASK= %C
      X'1E', GETPAGE=X'50000', RETURNPAGE=X'60000',  %C
      CLAIM TAPE=X'31000C', RELEASE TAPE=X'310007', COMREP= %C
      X'3E0001'
%INTEGER I, INDEX, PAGE, FILE, SNO, FAIL
%SWITCH STEP(1:12)
!
?      %IF KMON&(LONGONE<<(P_DEST>>16))#0 %THEN PRINTSTRING("
MOVE: ") %AND PTREC(P)
      %IF P_DEST>>16=PRIVSNO>>16 %START;   !NAME MNEM,PAGEREPLY
         INDEX=P_DEST&255
         %IF 1<<INDEX&MASK=0 %THEN %START;   ! THIS SLOT NOT IN USE!
            PRINTSTRING('MOVE REJECTS :- ')
            PTREC(P); %RETURN
         %FINISH
         BM==BMS(INDEX)
         FAIL=P_P2
         ->STEP(BM_STEP)
      %FINISH
!
! THIS THE THE ENTRY FOR A NEW REQUEST
!
      %CYCLE INDEX=1,1,4
        %IF MASK&1<<INDEX=0 %THEN %EXIT
      %REPEAT
      BM==BMS(INDEX)
      MASK=MASK!1<<INDEX
      %IF MASK=MAXMASK %THEN INHIBIT(REQSNO>>16);! ALL BUFFERS IN USE
      BM_DEST=P_DEST
      BM_SRCE=P_SRCE
      BM_FDEV=P_P1>>24
      BM_TODEV=P_P1>>16&255
      BM_READ=READ PAGE
      %IF P_P1&X'8000'#0 %THEN BM_READ=BACK READ
      BM_L=P_P1&X'7FFF'
      BM_FDINF1=P_P2
      BM_FDINF2=P_P3
      BM_TODINF1=P_P4
      BM_TODINF2=P_P5
      BM_IDENT=P_P6
      BM_COUNT=0; BM_STEP=0
      BM_UFAIL=0; BM_FVL1=0; BM_FVL2=0
      BM_WTRANS=0; BM_TVL1=0; BM_TVL2=0
      %IF BM_FDEV=2 %AND CHECK(BM_FDINF1,BM_FDINF2,READPAGE)#0 %C
         %THEN ->REQFAIL
      %IF BM_TODEV=2 %AND CHECK(BM_TODINF1,BM_TODINF2,WRITE)#0%C
         %THEN ->REQFAIL
      %IF BM_TODEV=3 %AND (BM_TODINF2>2 %OR BM_TODINF2<0) %C
            %THEN ->REQFAIL;            ! 0,1,OR 2 TMARKS ONLY ALLOWED
      P_DEST=GETPAGE;                  ! REQUEST ONE (EXTENDED) PAGE
      BM_STEP=0
PONIT:P_SRCE=PRIVSNO!INDEX
      BM_STEP=BM_STEP+1
      PON(P)
      %RETURN
STEP(1):                               ! CORE PAGE FROM CORE ALLOT
      BM_CDEX=P_P2;                     ! CORE INDEX NO(FOR RETURNING)
      BM_CORE=P_P4
      %IF BM_FDEV>=5 %THEN %START
         I=BM_CORE
         *LDA_I; *LDTB_X'18000000'
         *LDB_TRANSIZE; *MVL_%L=%DR,0,0
      %FINISH
CORE GOT:                              ! BY HOOK OR BY CROOK
      ->FDEVPOSD %UNLESS BM_FDEV=4; ! UNLESS A MAG TAPE
!
! CODE HERE TO CLAIM THE INPUT TAPE AND PUT ITS SERVICE NO IN INF1
!
      %IF BM_FDINF1>>24#0 %START;       ! TAPE LABEL NOT SERVICE NO
         P_DEST=CLAIM TAPE
         P_P2=X'00040001';              ! TAPE FOR READING
         P_P3=BM_FDINF1; P_P4=BM_FDINF2
         BM_FVL1=BM_FDINF1; BM_FVL2=BM_FDINF2;! REMEMBER FOR RELEASE
         BM_STEP=1; ->PONIT
STEP(2):                                ! REPLY FROM CLAIM TAPE
         %IF P_P2#0 %THEN ->POSFAIL
         BM_FDINF1=P_P3;                ! SERVICE NO FOR TAPE
         BM_FDINF2=BM_FDINF2&255;       ! CHAPTER NO OF FILE
      %FINISH
      SNO=BM_FDINF1
      BM_STEP=2
      FILE=BM_FDINF2&255
TAPEPOS:                               ! TAPE POSITION TO 'FILE' 
      P_DEST=SNO
      P_P1=FILE;                       ! IDENT FOR LATER
      P_P2=REWIND
      ->PONIT;                      ! SKIP BACK TO BT
STEP(3):                               ! FROM TAPE AT BT
STEP(6):                               ! TO TAPE AT BT
      ->POSFAIL %UNLESS FAIL=4 %OR FAIL=0
      P_DEST=P_SRCE
      P_P2=P_P1<<16!1<<8!TAPE POSN
      ->PONIT;                      ! SKIP FORWARD N FILES
STEP(4):                               ! FROMTAPE AT RIGHT FILE
      ->POSFAIL %UNLESS FAIL=0
!
! THIS BULK MOVER MOVES TAPE CHAPTERS ONLY
!
FDEVPOSD:
      ->POSCOMPLETE %UNLESS BM_TODEV=4;     ! OPUT TAPE NEEDS POSITIONING
!
! CODE HERE TO CLAIM THE OUTPUT TAPE
!
      %IF BM_TODINF1>>24#0 %START;      ! TAPE GIVEN AS LABEL NOT SNO
         P_DEST=CLAIM TAPE
         P_P2=X'00040002';              ! TAPE FOR WRITING
         P_P3=BM_TODINF1; P_P4=BM_TODINF2
         BM_TVL1=BM_TODINF1; BM_TVL2=BM_TODINF2
         BM_STEP=4; ->PONIT
STEP(5):                                ! REPLY FROM CLAIM OUTPUT TAPE
         %IF P_P2#0 %THEN ->POSFAIL
         BM_TODINF1=P_P3
         BM_TODINF2=BM_TODINF2&255;     ! CHAPTER NO
      %FINISH
      SNO=BM_TODINF1
      FILE=BM_TODINF2&255
      BM_STEP=5
      ->TAPEPOS
STEP(7):                               ! BOTH DEVICES POSITONED
      ->POSFAIL %UNLESS FAIL=0
POSCOMPLETE:
READ PG:
      BM_COUNT=BM_COUNT+1
      %IF BM_FDEV<5 %THEN %START;   ! NOT FROM A ZERO PAGE
         P_DEST=BM_FDINF1
         P_P3=BM_CORE
         %IF BM_FDEV=3 %OR BM_FDEV=4 %THEN %START
            P_P2=TRANSIZE<<16!BM_READ
         %FINISH %ELSE %START
            P_P2=BM_FDINF2-1+BM_COUNT
         %FINISH
         BM_STEP=7
         P_P1=BM_COUNT
         ->PONIT
      %FINISH %ELSE FAIL=0
STEP(8):                               ! PAGE READ
      ->READ FAIL %UNLESS FAIL=0
      %IF BM_TODEV<5 %THEN %START
         %CYCLE
            P_DEST=BM_TODINF1
            P_SRCE=PRIVSNO!INDEX
            BM_STEP=8
            P_P3=BM_CORE
            %IF BM_TODEV=4 %OR BM_TODEV=3 %THEN %START
                  P_P2=TRANSIZE<<16!WRITE
            %FINISH %ELSE %START
               P_P2=BM_TODINF2-1+BM_COUNT
            %FINISH
            P_P1=BM_COUNT
            PON(P)
            BM_STEP=9
            BM_WTRANS=BM_WTRANS+1
            %RETURN %IF BM_FDEV<5 %OR BM_WTRANS>=MAX TRANS %OR %C
               BM_COUNT>=BM_L
            BM_COUNT=BM_COUNT+1
         %REPEAT
      %FINISH %ELSE %START
         BM_WTRANS=BM_WTRANS+1
         DUMPTABLE(34,BM_CORE,TRANSIZE)%IF BM_TODEV=5
      %FINISH
STEP(9):                               ! PAGE WRITTEN
      BM_WTRANS=BM_WTRANS-1
      ->WRITEFAIL %UNLESS FAIL=0
      ->READ PG %IF BM_COUNT<BM_L %AND BM_UFAIL=0
      %RETURN %UNLESS BM_WTRANS=0
!
STEP(10):                              !FIRST TM WRITE
      ->TMFAIL %UNLESS FAIL=0
      P_DEST=BM_TODINF1
      P_P1=M'BMTM'
      P_P2=WRITE TM
      %IF BM_TODEV=3 %AND BM_TODINF2#0 %START;! ARCH TAPE NEEDS TM?
         BM_STEP=BM_STEP+2-BM_TODINF2;  ! ONE OR TWO TMS
         ->PONIT
      %FINISH
      ->PONIT %IF BM_TODEV=4
STEP(11):                              !BOTH TMS WRITTEN
      ->TMFAIL %UNLESS FAIL=0
WAYOUT:                                !DEALLOCATE CORE
      %RETURN %UNLESS BM_WTRANS=0
      P_DEST=RETURN PAGE
      P_SRCE=0;                        ! REPLY NOT WANTED
      P_P2=BM_CDEX
      PON(P);                       !RETURN CORE
      P_DEST=RELEASE TAPE
      P_SRCE=COMREP
      %IF BM_FDEV=4 %AND BM_FVL1#0 %START
         P_P2=X'00040000'!BM_FDINF1&X'FFFF'
         P_P3=BM_FVL1; P_P4=BM_FVL2; P_P5=1
         PON(P);                        ! RELEASE FROM TAPE
      %FINISH
      %IF BM_TODEV=4 %AND BM_TVL1#0 %START
         P_P2=X'00040000'!BM_TODINF1&X'FFFF'
         P_P3=BM_TVL1; P_P4=BM_TVL2; P_P5=1
         PON(P);                        ! RELEASE OUTPUT TAPE
      %FINISH
REPLY:                                 !SET UP REPLY
      P_DEST=BM_SRCE
      P_SRCE=REQSNO
      P_P1=BM_UFAIL
      P_P2=BM_IDENT
      PON(P);                       !REPLY TO REQUEST
      %IF MASK=MAXMASK %THEN UNINHIBIT(REQSNO>>16)
      MASK=MASK!!1<<INDEX
      %RETURN
REQFAIL:                               ! FAULT WITH REQUEST
      BM_UFAIL=-2
      ->REPLY
POSFAIL:                               ! UNABLE TO POS TAPE
      BM_UFAIL=-3
      ->WAYOUT
TMFAIL:                                 ! TAPE MARK DID NOT WRITE!
      ->ETWONTM %IF FAIL=4
      BM_UFAIL=-4 %IF BM_UFAIL=0
      ->WAYOUT
ETWONTM:                                ! END OF TAPE WARNING
      BM_UFAIL=-5
      ->WAYOUT
READFAIL:                              ! UNABLE TO READ
      %IF BM_UFAIL=0 %THEN %C
         BM_UFAIL=READPAGE<<24!P_P1!FAIL<<16
      ->WAYOUT
WRITEFAIL:                             ! UNABLE TO WRITE PAGE
      %IF BM_UFAIL=0 %THEN %C
         BM_UFAIL=WRITE<<24!P_P1!FAIL<<16
      ->WAYOUT
!
%INTEGERFN CHECK(%INTEGERNAME MNEM,PAGE,%INTEGER RTYPE)
!***********************************************************************
!*    CHECKS A DISC ID VOR VALIDITY & AVAILABILITY                     *
!***********************************************************************
%RECORDNAME DDT(DDTFORM)
%INTEGER I,L,V1,V2
      L=6; V1=MNEM; V2=PAGE
      %CYCLE I=0,1,NDISCS-1
         DDT==RECORD(INTEGER(DDTADDR+I*4))
         %IF (DDT_MNEMONIC=MNEM %OR STRING(ADDR(L)+3)=DDT_LAB%OR %C
            MNEM=DDT_DLVN) %AND 4<=DDT_STATE<=7 %THEN %START
            MNEM=PDISCSNO!RTYPE
            %IF STRING(ADDR(L)+3)=DDT_LAB %THEN PAGE=PAGE&X'FFFF'
            PAGE=PAGE!DDT_DLVN<<24
            %RESULT=0
         %FINISH
      %REPEAT
      %RESULT=1
      %END
%END
%EXTERNALROUTINE SEMAPHORE(%RECORDNAME P)
%RECORDSPEC P(PARMF)
%RECORDFORMAT SEMAF(%INTEGER DEST,SRCE,TOP,BTM,SEMA,P4,P5,P6,LINK)
%RECORDNAME SEMACELL(SEMAF)
%RECORDNAME WAITCELL(PARMXF)
%OWNINTEGERARRAY HASH(0:31)=0(32)
%INTEGERFNSPEC NEWSCELL
%INTEGERFNSPEC NEWWCELL
%INTEGER SEMA, HASHP, NCELL, I, WCELL
%INTEGERNAME CELLP
%SWITCH ACT(1:3)
?      %IF KMON&1<<7#0 %THEN PRINT STRING('SEMAPHORE:') %C
         %AND PTREC(P)
      SEMA=P_P1
      %IF P_DEST&15<3 %THEN HASHP=SEMA-SEMA//31*31 %AND %C
         CELLP==HASH(HASHP)
      ->ACT(P_DEST&3)
!-----------------------------------------------------------------------
ACT(1):                                 ! P OPERATION
      %WHILE CELLP#0 %CYCLE
         SEMACELL==PARM(CELLP)
         %IF SEMA=SEMACELL_SEMA %THEN %START
            I=SEMACELL_BTM
            %IF I=0 %THEN %START;       ! ALREADY HAD V OPERATION
               SEMACELL_DEST=P_SRCE
               SEMACELL_SRCE=X'70001'
               FASTPON(CELLP)
               CELLP=0
            %FINISH %ELSE %START;       ! ADD TO BTM OF QUEUE
               WCELL=NEWWCELL
               PARM(I)_LINK=WCELL
               SEMACELL_BTM=WCELL
            %FINISH
            %RETURN
         %FINISH
         CELLP==SEMACELL_LINK
      %REPEAT
!
! NO QUEUE YET
!
      NCELL=NEWSCELL
      CELLP=NCELL
      WCELL=NEWWCELL
      SEMACELL_TOP=WCELL
      SEMACELL_BTM=WCELL
      %RETURN
!-----------------------------------------------------------------------
ACT(2):                                 ! V OPERATION
      %WHILE CELLP#0 %CYCLE
         SEMACELL==PARM(CELLP)
         %IF SEMA=SEMACELL_SEMA %THEN %START
            I=SEMACELL_TOP
            SEMACELL_TOP=PARM(I)_LINK
            FASTPON(I)
            %IF SEMACELL_TOP=0 %THEN %START;! RETURN HEADCELL
               I=SEMACELL_LINK
               RETURN PP CELL(CELLP)
               CELLP=I
            %FINISH
            %RETURN
         %FINISH
         CELLP==SEMACELL_LINK
      %REPEAT
!
! P OPERATION NOT HERE YET
!
      NCELL=NEWSCELL
      CELLP=NCELL
      %RETURN
!-----------------------------------------------------------------------
ACT(3):                                 ! DISPLAY SEMAPHORE QUEUES
?      %CYCLE HASHP=0,1,31
?         %IF HASH(HASHP)#0 %THEN %START
?            CELLP==HASH(HASHP)
?              SEMACELL==PARM(CELLP)
?             %WHILE CELLP#0 %CYCLE
?               SEMA=SEMACELL_SEMA
?               I=SEMACELL_TOP
?               %WHILE I#0 %THEN OPMESS("SEMA ".STRINT(SEMA). %C
                  " QUEUE :".HTOS(PARM(I)_DEST>>16,2)) %C
                  %AND I=PARM(I)_LINK
?               CELLP==SEMACELL_LINK
?            %REPEAT
?         %FINISH
?      %REPEAT
      %RETURN
!-----------------------------------------------------------------------
%INTEGERFN NEWWCELL
%INTEGER I
      I=NEWPPCELL
      WAITCELL==PARM(I)
      WAITCELL_DEST=P_SRCE
      WAITCELL_SRCE=X'70001'
      WAITCELL_LINK=0
?      WAITCELL_P5=M'SEMA'
?      WAITCELL_P6=M'WAIT'
      %RESULT =I
%END
!-----------------------------------------------------------------------
%INTEGERFN NEWSCELL
%INTEGER I
      I=NEWPPCELL
      SEMACELL==PARM(I)
      SEMACELL=0
      SEMACELL_SEMA=SEMA
?      SEMACELL_P5=M'SEMA'
?      SEMACELL_P6=M'HEAD'
      %RESULT=I
%END
%END
%ENDOFFILE
%ENDOFFILE