%OWNLONGINTEGER VSN=X'4449534320563137';     ! M'DISC V17'
! DRIVING FPC2S WRITTEN BY PDS OCT 76
!
%RECORDFORMAT PARMF(%INTEGER DEST,SRCE,P1,P2,P3,P4,P5,P6)
%RECORDFORMAT DDTFORM(%INTEGER SER,PTS,PROPADDR,STICK, %C
      CCA,RQA,LBA,ALA,STATE,IW1,IW2,SENSE1,SENSE2,SENSE3,SENSE4,%C
      REPSNO,BASE,ID,DLVN,MNEMONIC,%STRING(6)LAB,%BYTEINTEGER MECH)
!
%RECORDFORMAT PROPFORM(%INTEGER TRACKS,CYLS,PPERTRK,BLKSIZE,TOTPAGES,%C
      RQBLKSIZE,LBLKSIZE,ALISTSIZE,KEYLEN,SECTINDX)
!
%RECORDFORMAT CCAFORM(%INTEGER MARK,PAW,PIW1,PIW2,CSAW1,CSAW2,%C
      CRESP1,CRESP2,%LONGLONGREALARRAY STRMS(0:15))
!
%RECORDFORMAT RQBFORM(%INTEGER LSEGPROP,LSEGADDR,LBPROP,LBADDR,ALPROP,%C
      ALADDR,W6,W7,W8)
!
%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(%INTEGER QSLOT,STATE,REQLINK,CURRPOS,%C
      PROPADDR,DDTADDR,DDTSLOT,TRLINK)
%RECORDFORMAT REQFORM(%INTEGER FAULTS,SRCE,IDENT,DADDR,COREADDR,%C
      CTS,%BYTEINTEGER SECT,FLB,LLB,REQTYPE,%INTEGER REQLINK)
%CONSTINTEGER DDTSIZE=88,NORMALT=X'800000',%C
      ERRT=X'400000',ATTNT=X'100000',DISCSNO=X'00200000', %C
      PDISCSNO=X'210000'
%OWNINTEGER EPAGESIZE,TRANSIZE
%OWNBYTEINTEGERARRAY LVN(0:99)=254(100)
%OWNRECORDARRAYFORMAT QSPACEF(1:512)(QFORM)
%OWNRECORDARRAYNAME QSPACE(QFORM)
!
%EXTRINSICLONGINTEGER KMON
%CONSTLONGINTEGER LONGONE=1
%OWNINTEGER DDT ADDR,NDISCS,NCONTROLERS
%EXTERNALROUTINESPEC DUMPTABLE (%INTEGER T,A,L)
%EXTERNALROUTINESPEC OPMESS(%STRING(63) S)
%SYSTEMROUTINESPEC ETOI(%INTEGER A,L)
%EXTERNALSTRING(8)%FNSPEC STRHEX(%INTEGER N)
%EXTERNALSTRING(8)%FNSPEC STRINT(%INTEGER N)
%EXTERNALROUTINESPEC PON(%RECORDNAME P)
%ROUTINESPEC PDISC(%RECORDNAME P)
%EXTERNALROUTINESPEC INHIBIT(%INTEGER SERV)
%EXTERNALROUTINESPEC UNINHIBIT(%INTEGER SERV)
%EXTERNALROUTINESPEC PTREC(%RECORDNAME P)
%EXTERNALROUTINESPEC WAIT(%INTEGER MSECS)
%EXTERNALINTEGERFNSPEC REALISE(%INTEGER PUBVIRTADDR)
%EXTERNALROUTINE DISC(%RECORDNAME P)
%RECORDSPEC P(PARMF)
%ROUTINESPEC SET PAW(%RECORDNAME CCA,%INTEGER PAW,PTS,SAW,SRTM)
%ROUTINESPEC READ DLABEL(%RECORDNAME DDT)
%ROUTINESPEC REINIT DFC(%RECORDNAME DDT)
%ROUTINESPEC UNLOAD(%RECORDNAME DDT)
%STRING(4)%FNSPEC MTOS(%INTEGER M)
%ROUTINESPEC SENSE(%RECORDNAME DDT,%INTEGER VAL)
%ROUTINESPEC STREAM LOG(%RECORDNAME DDT)
%ROUTINESPEC DREPORT(%RECORDNAME DDT,P)
%RECORDNAME DDT(DDTFORM)
%RECORDNAME RQB(RQBFORM)
%RECORDNAME LABEL(LABFORM)
%RECORDNAME CCA(CCAFORM)
%OWNINTEGER INITINH,LABREADS,CURRTICK
%OWNBYTEINTEGERARRAY PTCA(0:63);       ! MAX=PORT3,TRUNK F
%OWNBYTEINTEGERARRAY PTDSLOT(0:63)=255(64)
%INTEGER ACT,I,J,PTR,STRM,PIW,SIW1,SIW2,PT,SLOT,PTS
%STRING(40)S
%SWITCH INACT(0:6),AINT,FINT,NINT(0:15)
      ACT=P_DEST&X'FFFF'
      %IF KMON&(LONGONE<<(DISCSNO>>16))#0 %THEN PRINTSTRING("
DISC: ") %AND PTREC(P)
      %IF ACT>=64 %THEN ->ACT64
      ->INACT(ACT)
INACT(0):                               ! INITIALISATION
                                        ! P_P1=EPAGESIZE
                                        ! P_P2=ADDR(CONTROLLER LIST)
                                        ! P_P3=ADDR(DDT)
                                        ! P_P4=NO OF DISCS
      EPAGESIZE=P_P1
      TRANSIZE=EPAGESIZE*1024
      NDISCS=P_P4
      DDTADDR=P_P3
      NCONTROLERS=INTEGER(P_P2)
      QSPACE==ARRAY(P_P6,QSPACEF)
      INITINH=1
      INHIBIT(PDISCSNO>>16)
!
! SET UP TWO ARRAYS TO AVOID SEARCHING THE DDT
! PTCA HAS THE COMMNCTNS AREA PUBLIC SEG NO FOR EACH CONTROLLER(AS P/T)
! PTDSLOT HAS THE SLOT NO OF STREAM 0 OF A GIVEN P/T SO THAT THE
! SLOT OF STREAM S CAN BE FOUND BY INDEXING. IF THERE ARE MISSING STREAMS 
! ON A FPC2 THEN THERE WILL BE MORE THAN ONE VALUE FOR PTDSLOT AND THE
! LOWEST IC CHOSEN. THIS WILL INVOLVE SEARCHING AND IS LESS EFFICIENT
!
      %CYCLE J=0,1,NDISCS-1
         DDT==RECORD(DDTADDR+J*DDTSIZE)
         PT=DDT_PTS>>4
         STRM=DDT_PTS&15
         PTCA(PT)<-DDT_CCA>>18;               ! TO ASSOCIATE INTS
         I=J-STRM;                      ! STRM 0 POSN
         %IF I<0 %THEN I=0;             ! IN CASE VERY PECULIAR CONFIGN
         %IF PTDSLOT(PT)>I %THEN PTDSLOT(PT)=J
         SENSE(DDT,0)
         DDT_STATE=1;               ! READ VOL LABELS
      %REPEAT
      P_DEST=PDISCSNO
      PDISC(P)
      CURRTICK=0
      P_DEST=X'A0001'; P_SRCE=0
      P_P1=DISCSNO+5; P_P2=3;           ! INT ON ACT 5 EVERY 3 SECS
      PON(P)
      %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 = PAGED TRANSFER HAS FAILED & A SENSE ISSUED
!     7-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
!     13 = PRIVATE CHAIN HAS FAILED & A SENSE ISUUED
!
INACT(1):                               ! CLAIM FOR DEDICATED USE
!
! INPUT REQUEST
!     P_P1 = RETURNABLE
!     P_P2 = SERVICE NO FOR REPLIES (O=RELEASE -1=UNLOAD--NO REPLY)
!     P_P3 = SLOT NO OR MNEMONIC OR %STRING(6) VOL LABEL
!
! REPLIES
!     P_P2 = 0 CLAIM FAILS ELSE SERVICE NO FOR PRIVATE REQUESTS
!     P_P3 = SLOT NO
!     P_P4 = MNEMONIC
!     P_P5& 6 = %STRING(6) VOL LABEL
!
      PTR=P_P3; I=PTR
      %UNLESS 0<=PTR<NDISCS %START
         %CYCLE I=0,1,NDISCS-1
            DDT==RECORD(DDTADDR+I*DDTSIZE)
            ->HIT %IF PTR=DDT_MNEMONIC %OR DDT_LAB=STRING(ADDR(P_P3))
         %REPEAT
         ->CLAIM FAILS
      %FINISH %ELSE DDT==RECORD(DDTADDR+I*DDTSIZE)
HIT:                                    ! DDT MAPED ON RIGHT SLOT
      %IF P_P2>0 %START
         %IF DDT_STATE=10 %OR (DDT_STATE=4 %AND DDT_DLVN<0) %START
            DDT_STATE=11
            DDT_BASE=P_P2
            ->REPLY
         %FINISH %ELSE ->CLAIM FAILS
      %FINISH %ELSE %START
         %IF DDT_STATE #11 %THEN OPMESS('BUM DEV RETURNED') %AND %RETURN
         DDT_STATE=10; DDT_REPSNO=0
         OPMESS(MTOS(DDT_MNEMONIC).' UNUSED')
         %IF P_P2<0 %THEN SENSE(DDT,0) %AND DDT_STATE=1
         %RETURN
      %FINISH
REPLY:                                  ! REPLY TO CLAIMS ONLY
      P_P2=DISCSNO+64+I
      P_P3=I
      P_P4=DDT_MNEMONIC
      STRING(ADDR(P_P5))=DDT_LAB
SEND: P_DEST=P_SRCE
      P_SRCE=DISCSNO+1
      PON(P)
      %RETURN
CLAIM FAILS:
      P_P2=0; ->SEND
INACT(4):                               ! NOTE LVN P_P1 NOW CHECKED
      I=P_P1; J=LVN(I)
      %IF J>=NDISCS %THEN %RETURN;      ! CRAP LVN
      DDT==RECORD(DDTADDR+J*DDTSIZE)
      DDT_DLVN=DDT_DLVN&255
      %RETURN
INACT(5):                               ! CLOCKTICK
      CURRTICK=CURRTICK+1
      %CYCLE J=0,1,NDISCS-1
         DDT==RECORD(DDTADDR+J*DDTSIZE)
         %IF CURRTICK-DDT_STICK>2 %AND X'306E'&1<<DDT_STATE#0 %C
            %THEN ->TOUT
      %REPEAT
      %RETURN
TOUT:                                   ! DEVICES TIMES OUT
      OPMESS(MTOS(DDT_MNEMONIC)." TIMED OUT")
      CCA==RECORD(DDT_CCA)
      STRM=DDT_PTS&15
      %IF CCA_PIW1&X'80000000'>>STRM#0 %THEN %START
         OPMESS(MTOS(DDT_MNEMONIC)." MISSING INT PONNED")
         P_DEST=DISCSNO+3; P_SRCE=0
         P_P1=DDT_PTS>>4
         PON(P)
         %RETURN
      %FINISH
      DUMPTABLE(60,DDT_CCA,4096)
      CCA_PAW=0; CCA_MARK=-1
      SET PAW(CCA,X'01000000'+STRM,DDT_PTS,X'10000024',STRM)
      WAIT(10)
      %IF CCA_PAW=0 %THEN OPMESS("TRANSFER RETRIED") %C
                     %ELSE REINIT DFC(DDT)
      %RETURN
INACT(6):                               ! READ STREAM LOG
      PRINTSTRING("
                       DISC LOGGING INFORMATION
STR  RESPONSE BYTES TRNFRD SEEKS SRNH WOFF SKER STER CORRN")
      PRINTSTRING(" STRBE HDOFF MEDIA")
      %CYCLE J=0,1,NDISCS-1
         DDT==RECORD(DDTADDR+J*DDTSIZE)
         %IF DDT_STATE=4 %THEN STREAM LOG(DDT)
      %REPEAT
      NEWLINE
      P_DEST=P_SRCE; P_SRCE=DISCSNO!6; P_P1=0
      PON(P) %IF P_DEST>0
      %RETURN
INACT(3):                               ! INTERRUPTS
!***********************************************************************
!*    DISC INTERRUPT HANDLING SEQUENCE                                 *
!***********************************************************************
      PT=P_P1;                          ! EXTRACT PORT & TRUNK FROM INT
      PTR=PTCA(PT)
      %IF PTR=0 %THEN PRINTSTRING('NO DISC ON PT '.STRHEX(PT).'?
') %AND %RETURN
      CCA==RECORD(X'80000000'+PTR<<18)
MORE INTS:                                   ! SEE IF ANY MORE INTS
      *LXN_CCA+4
GRAB: *INCT_(%XNB+0)
      *JCC_7,<GRAB>;                 ! GET SEMAPHORE
      *LSS_(%XNB+2); *ST_PIW
      *JAT_4,<CONTINT>
      *SHZ_STRM;                        ! FIND INTERUPTING STREAM
      CCA_PIW1=PIW!!X'80000000'>>STRM
!      SIW1=INTEGER(ADDR(CCA_STRMS(STRM))+8)
!      INTEGER(ADDR(CCA_STRMS(STRM))+8)=0
!      SIW2=INTEGER(ADDR(CCA_STRMS(STRM))+12)
      *LB_STRM; *MYB_16; *ADB_CCA+4; *LXN_%B
      *LSD_(%XNB+10); *ST_SIW1
      *LSS_0; *ST_(%XNB+10)
      CCA_MARK=-1
      I=PTDSLOT(PT)+STRM;            ! SLOT FOR THIS DEV IF ALL STRMS PRESENT
      PTS=PT<<4+STRM
      DDT==RECORD(DDTADDR+I*DDTSIZE)
      %IF I>=NDISCS %OR DDT_PTS#PTS %START;   ! DISCS DISCONTINUOUS ON THIS CNTRLR
         %IF I>=NDISCS %OR DDT_PTS>PTS %THEN I=-1
         %CYCLE
            I=I+1
            %IF I>NDISCS %THEN ->SPURINT
            DDT==RECORD(DDTADDR+I*DDTSIZE)
            %IF DDT_PTS=PTS %THEN %EXIT
         %REPEAT;                    ! SEARCH FOR DISCONTINUOS DISC
      %FINISH
      SLOT=I
      %IF SIW1&NORMALT#0 %THEN ->NINT(DDT_STATE)
      %IF SIW1&ERRT#0 %THEN ->FINT(DDT_STATE)
      %IF SIW1&ATTNT#0 %AND SIW1&X'1000'=0 %THEN ->AINT(DDT_STATE)
CHINT:%IF CCA_PIW1#0 %THEN ->MORE INTS
      %RETURN
CONTINT:                                ! INT FROM CONTOLLER OR SPURIOUS
      SIW1=CCA_CRESP1; SIW2=CCA_CRESP2
      CCA_CRESP1=0; CCA_MARK=-1
      %IF SIW1#0 %THEN PRINTSTRING('DISC CONTROLERS INT :'. %C
         STRHEX(SIW1)." ".STRHEX(SIW2).'??')
      %RETURN
SPUR INT:
      PRINTSTRING('SPUR DISC INT ON '.STRHEX(PT<<4+STRM)."
")
      ->CHINT
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).' ?????
')
      ->CHINT
NINT(1):                                ! SENSE TERMINATES
      I=DDT_ALA+128
      DDT_SENSE1=INTEGER(I)
      DDT_SENSE2=INTEGER(I+4)
      DDT_SENSE3=INTEGER(I+8)
      DDT_SENSE4=INTEGER(I+40)
!
! RESET THE RQB SO THAT THE POINTERS POINT ABOVE THE FALSE FLOOR
! OF THE LOGIC BLOCK AND ADDRESS LIST. THE FALSE FLOOR CONCEALS A
! SENSE WHICH IS ALWAYS SET UP
!
      RQB==RECORD(DDT_RQA)
      RQB_LBADDR=DDT_LBA
      RQB_ALADDR=DDT_ALA
      %IF DDT_SENSE4<0 %THEN %START;    ! DISC IN AUTO
         READ DLABEL(DDT)
         LABREADS=LABREADS+1
         DDT_STATE=2
      %FINISH %ELSE DDT_STATE=0
      ->CHINT
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_ALA+72)
      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
         %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; ->CHINT
            %FINISH
         %FINISH
      %FINISH %ELSE %START
         DDT_BASE=0
         S=' FRGN'
         DDT_STATE=10
      %FINISH
      OPMESS(MTOS(DDT_MNEMONIC).' LOADED '.DDT_LAB.S)
      ->CHINT
FINT(1):                                !SENSE FAILS
      DDT_STATE=0; ->CHINT
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
      ->CHINT
NINT(3):FINT(3):                        ! UNLOAD COMPLETE
      SENSE(DDT,0);                     ! RECONNECT INTERFACE
         DDT_STATE=1
      ->UNLDED
AINT(2):
      LABREADS=LABREADS-1
AINT(0):AINT(1):                        ! ATTENTION WHILE INITIALISING
      PRINTSTRING('ATTNTN WHILE INITNG '.STRHEX(PTS)." ". %C
               STRHEX(SIW1).STRHEX(SIW2)."
")
      %CYCLE I=1,1,5000
         %IF CCA_PIW1&(X'80000000'>>STRM)#0 %THEN ->CHINT
      %REPEAT
      DDT_STATE=1
      SENSE(DDT,1);                     ! START SEQUENCE AGAIN
AINT(3):                                ! EXTRA ATTENTION CAUSED BY UNLOAD
      ->CHINT
AINT(4):AINT(10):                       ! ATTENTION WHILE IDLE
      %IF SIW1&X'800'#0 %THEN %START;   ! ATTENTION WHILE IDLE
         UNLOAD(DDT)
         DDT_STATE=3
         ->CHINT
      %FINISH
      DDT_STATE=0
UNLDED:OPMESS(MTOS(DDT_MNEMONIC).' UNLOADED')
      %IF DDT_DLVN#-1 %THEN LVN(DDT_DLVN&255)=255
      ->CHINT
ACT64:                                  ! PRIVATE CHAINS
      STRM=ACT&63
      DDT==RECORD(DDTADDR+STRM*DDTSIZE)
      %IF DDT_STATE#11 %THEN ->REJECT
!
      DDT_REPSNO=P_SRCE
      DDT_ID=P_P1;                  ! SAVE PRIVATE ID
      DDT_STATE=12
      CCA==RECORD(DDT_CCA)
      STRM=DDT_PTS&15
      DDT_STICK=CURRTICK
      SET PAW(CCA,X'01000000'+STRM,DDT_PTS,X'10000024',STRM)
      %RETURN
REJECT:                                 ! DISC REQUESTED REJECTED
      PRINTSTRING('*** DISC REJECTS ')
      PTREC(P)
      P_DEST=P_SRCE
      P_P2=-1
      P_SRCE=DISCSNO+64+STRM
      PON(P)
      %RETURN
INACT(2):                               ! PAGED REQUEST(_P1=ID,_P2=SLOT)
      STRM=P_P2;                        ! DDT SLOT NO
      DDT==RECORD(DDTADDR+STRM*DDTSIZE)
      %IF DDT_STATE#4 %OR P_SRCE&X'FFFF0000'#PDISCSNO %THEN ->REJECT
      DDT_STATE=5; DDT_ID=P_P1
      PT=DDT_PTS
      DDT_STICK=CURRTICK
      CCA==RECORD(DDT_CCA)
      STRM=PT&15;                       ! REAL STREAM NO
!      SET PAW(CCA,X'01000000'+STRM,DDT_PTS,X'10000024',STRM)
GETS: *LXN_CCA+4
      *INCT_(%XNB+0)
      *JCC_7,<WAITM>
      *LSS_(%XNB+1); *JAF_4,<WAITM>;    ! LAST PAW NOT CLEARED
      *LSS_X'01000000'; *OR_STRM; *ST_(%XNB+1)
      *LB_STRM; *MYB_16; *ADB_CCA+4; *LXN_%B
      *LSS_X'10000024'; *ST_(%XNB+8)
      *LSS_-1; *LXN_CCA+4; *ST_(%XNB+0)
      *LSS_PT; *USH_-4; *USH_16; *OR_X'40000800'
      *ST_%B; *LSS_1; *ST_(0+%B)
      %RETURN
WAITM:   CCA_MARK=-1
      %CYCLE I=1,1,500; %REPEAT
      ->GETS
NINT(12):                               ! PRIVATE CHAIN OK
      P_DEST=DDT_REPSNO
      P_SRCE=DISCSNO+64+DDT_PTS&15
      P_P1=DDT_ID
      P_P2=0;                           ! FLAG FOR NORMAL TERMINATION
      P_P3=SIW1; P_P4=SIW2
      PON(P)
      DDT_STATE=11
      ->CHINT
FINT(5):                                ! PAGED REQUEST FAILS
FINT(12):                               ! PRIVATE CHAIN FAILS
      DDT_IW1=SIW1
      DDT_IW2=SIW2
      DDT_STATE=DDT_STATE+1
      SENSE(DDT,1)
      ->CHINT
NINT(5):                                ! PAGED TRANSFER OK
      P_DEST=PDISCSNO+10
      P_SRCE=DISCSNO+2
      P_P1=DDT_ID
      P_P2=0
      DDT_STATE=4
      PDISC(P);                        ! CALL NOT PON FOR EFFICIENCY
      ->CHINT
NINT(6):                                ! PAGED SENSE OK
FINT(6):                                ! PAGED SENSE FAILS
      P_DEST=PDISCSNO+10
      P_SRCE=DISCSNO+2
      DDT_STATE=4
      ->COM1
NINT(13):                               ! PRIVATE SENSE OK
FINT(13):                               ! PRIVATE SENSE FAILS (!???)
      P_DEST=DDT_REPSNO
      P_SRCE=DISCSNO+64+DDT_PTS&15
      DDT_STATE=11
COM1:
      I=DDT_ALA+128
      DDT_SENSE1=INTEGER(I)
      DDT_SENSE2=INTEGER(I+4)
      DDT_SENSE3=INTEGER(I+8)
      DDT_SENSE4=INTEGER(I+40)
!
! RESET THE RQB SO THAT THE POINTERS POINT ABOVE THE FALSE FLOOR
! OF THE LOGIC BLOCK AND ADDRESS LIST. THE FALSE FLOOR CONCEALS A
! SENSE WHICH IS ALWAYS SET UP
!
      RQB==RECORD(DDT_RQA)
      RQB_LBADDR=DDT_LBA
      RQB_ALADDR=DDT_ALA
      P_P1=DDT_ID
      P_P2=1;                           ! TRANSFER FAILS
      P_P3=DDT_IW1
      P_P4=DDT_IW2
      P_P5=SIW1;                        ! SENSE TERMINATION
      P_P6=ADDR(DDT_SENSE1)
      DREPORT(DDT,P)
      %IF DDT_SENSE2<0 %START;          ! INOP IN SECONDARY STATUS
         DDT_STATE=0
         OPMESS(MTOS(DDT_MNEMONIC)." INOPERABLE")
      %FINISH
      %IF P_DEST=PDISCSNO+10 %THEN PDISC(P) %ELSE PON(P)
      ->CHINT
AINT(11):AINT(12):AINT(13):             ! PRIVATE ATTENTIONS
      P_DEST=DDT_BASE; P_SRCE=DDT_SER+64
      P_P1=0; P_P2=0
      P_P3=SIW1; P_P4=SIW2
      PON(P) %UNLESS P_DEST=0
      %RETURN
%STRING(4)%FN MTOS(%INTEGER M)
%INTEGER I,J
      I=4; J=M
      %RESULT=STRING(ADDR(I)+3)
%END
%ROUTINE UNLOAD(%RECORDNAME DDT)
!***********************************************************************
!*    PERFORMS A DISCONNECT INTERFACE WHICH UNLOADS THE DISC           *
!***********************************************************************
%RECORDSPEC DDT(DDTFORM)
%RECORDNAME RQB(RQBFORM)
%RECORDNAME CCA(CCAFORM)
%INTEGER STRM
      STRM=DDT_PTS&15
      RQB==RECORD(DDT_RQA)
      CCA==RECORD(DDT_CCA)
      RQB_W7=X'80001300'
      RQB_W8=0
      SET PAW(CCA,X'01000000'+STRM,DDT_PTS,X'10000024',STRM)
%END
%ROUTINE READ DLABEL(%RECORDNAME DDT)
!***********************************************************************
!*    READS SECTOR 0 HEAD 0 CYL 0 WHICH SHOULD BE 80 BYTE VOL LABEL    *
!***********************************************************************
%RECORDSPEC DDT(DDTFORM)
%RECORDNAME RQB(RQBFORM)
%RECORDNAME CCA(CCAFORM)
%INTEGER LBA,ALA,STRM
      LBA=DDT_LBA
      ALA=DDT_ALA
      STRM=DDT_PTS&15
      DDT_STICK=CURRTICK
      RQB==RECORD(DDT_RQA)
      CCA==RECORD(DDT_CCA)
!
      INTEGER(LBA)=X'86000000';         ! CHAIN CWW,LIT AND SELECTHD
      INTEGER(LBA+4)=X'00000A00';       ! READ S0
      INTEGER(ALA)=X'58000058';         ! 88 BYTESOF KEY+DATA
      INTEGER(ALA+4)=ALA+64;            ! READ INTO ADDRESS LIST SPACE
      RQB_W7=X'12001300';               ! SEEK CYL 0 & DO CHAIN
      RQB_W8=0;                         ! SEEK DATA (HOPEFULLY IGNORED)
      SET PAW(CCA,X'01000000'+STRM,DDT_PTS,X'10000024',STRM)
%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                  *
!*    A SENSE IS ALWAYS KEPT BELOW THE FALSE FLOOR IN LBLOACK &ALIST   *
!***********************************************************************
%RECORDNAME RQB(RQBFORM)
%RECORDSPEC DDT(DDTFORM)
%RECORDNAME CCA(CCAFORM)
%INTEGER LBA,ALA,STRM
      LBA=DDT_LBA-8+4*VAL
      ALA=DDT_ALA-8
      STRM=DDT_PTS&15
      DDT_STICK=CURRTICK
      CCA==RECORD(DDT_CCA)
      RQB==RECORD(DDT_RQA)
      RQB_LBADDR=LBA
      RQB_ALADDR=ALA
      RQB_W7=X'02001300';               ! DO CHAIN
      SET PAW(CCA,X'01000000'+STRM,DDT_PTS,X'10000024',STRM)
%END
%ROUTINE SET PAW(%RECORDNAME CCA,%INTEGER PAW,PTS,SAW,STRM)
!***********************************************************************
!*    GRAB SEMA AND SET ACTIVATION WORDS. THEN FIRE IO                 *
!***********************************************************************
%RECORDSPEC CCA(CCAFORM)
%INTEGER W
GETSEMA:
      *LXN_CCA+4
      *INCT_(%XNB+0)
      *JCC_7,<WAIT>
      %IF CCA_PAW#0 %THEN CCA_MARK=-1 %AND ->WAIT
      CCA_PAW=PAW
      INTEGER(ADDR(CCA)+32+16*STRM)=SAW
      CCA_MARK=-1
!      FIRE IO(PTS,1)
      *LSS_PTS; *USH_-4; *USH_16; *OR_X'40000800'
      *ST_%B; *LSS_1; *ST_(0+%B)
      %RETURN
WAIT: %CYCLE W=1,1,500
      %REPEAT
      ->GET SEMA
%END
%ROUTINE REINIT DFC(%RECORDNAME DDT)
!***********************************************************************
!*    DFC IS DEAD. MASTERCLEAR AND MOVE ITS COMMSAREA FROM 0 TO        *
!*    THE PLACE SPECIFIED IN DDT. THEN FIRE THE CHAIN AGAIN            *
!***********************************************************************
%RECORDSPEC DDT(DDTFORM)
%RECORDFORMAT INITFORM(%INTEGER W0,W1,W2,W3,W4)
%OWNRECORD INIT(INITFORM)
%RECORDNAME CCA0(CCAFORM)
%CONSTINTEGER REAL0ADDR=X'81000000'
%INTEGER ISA
      ISA=X'40000800'!(DDT_PTS>>4<<16); ! FOR CHANNEL FLAGS
      *LB_ISA; *LSS_2; *ST_(0+%B);      ! MASTER CLEAR
      WAIT(500);                        ! HALF A SEC TO SETTLE DOWN
      INIT_W0=((INTEGER(X'80040008')&X'FFFC')//8-1)<<18!X'80000000'
      INIT_W1=INTEGER(X'8004000C')&X'0FFFFFF80'
      INIT_W2=DDT_CCA
!
! INIT W0&W1 HAVE SIZE&BASE 0F PST. NOW SET UP REAL0 AS COMMAREA
!
      CCA0==RECORD(REAL0ADDR)
      CCA0_MARK=-1
      CCA0_PAW=X'04000000';             ! DO CONTROLLER REQ
      CCA0_CSAW1=X'12000014';           ! 20 BYTES OF INIT INFO
      CCA0_CSAW2=REALISE(ADDR(INIT))
      *LB_ISA; *LSS_1; *ST_(0+%B)
      OPMESS("DFC REINITIALISED")
      WAIT(5)
      DUMPTABLE(64,REAL0ADDR,127)
      DUMPTABLE(65,DDT_CCA,127)
      *LB_ISA; *LSS_1; *ST_(0+%B)
%END
%ROUTINE STREAM LOG(%RECORDNAME DDT)
!***********************************************************************
!*    READ THE STREAM LOG FOR EACH STREAM IN TURN. WAITS FOR RESPONSE  *
!***********************************************************************
%RECORDNAME RQB(RQBFORM)
%RECORDNAME CCA(CCAFORM)
%RECORDSPEC DDT(DDTFORM)
%INTEGER LBA,ALA,STRM,I,J
      LBA=DDT_LBA; ALA=DDT_ALA
      STRM=DDT_PTS&15
      CCA==RECORD(DDT_CCA)
      RQB==RECORD(DDT_RQA)
!
      INTEGER(LBA)=X'00410200';         ! READ STREAM LOG
      INTEGER(ALA)=X'5800000C';         ! 12 BYTES
      INTEGER(ALA+4)=ALA+16;            ! DATA INTO ADDRESS LIST
      RQB_W7=X'02001300';               ! DO STREAM REQUEST
      SET PAW(CCA,X'01000000'+STRM,DDT_PTS,X'01000024',STRM)
!
      I=0
      %WHILE I<32000 %CYCLE
         J=ADDR(CCA_STRMS(STRM))+8
         %EXIT %IF CCA_MARK=-1 %AND INTEGER(J)#0
         I=I+1
      %REPEAT;                          ! UNTIL RESPONSE
!
      I=INTEGER(J)
      INTEGER(J)=0;                     ! CLEAR RESPONSE WORD
      NEWLINE; WRITE(STRM,2)
      PRINTSTRING("  ".STRHEX(I))
      ALA=ALA+16;                       ! TO STREAM DATA
      WRITE(INTEGER(ALA),10);           ! BYTES TRANSFERED
      WRITE(BYTEINTEGER(ALA+4)<<8!BYTEINTEGER(ALA+5),7);! SEEKS
      J=BYTEINTEGER(ALA+6)
      WRITE(J>>4,4);                    ! SRNHS
      WRITE(J&15,4);                    ! WOFFS
      J=BYTEINTEGER(ALA+7)
      WRITE(J>>4,4);                    ! SEEK ERRORS
      WRITE(J&15,4);                    ! SMAC ERRS
      WRITE(BYTEINTEGER(ALA+8),5);      ! DATA CORRNS
      WRITE(BYTEINTEGER(ALA+9),5);      ! STROBE OFFSETS
      WRITE(BYTEINTEGER(ALA+10),5);     ! HD OFFSETS
      WRITE(BYTEINTEGER(ALA+11),5);     ! MEDIA ERRORS
%END
%ROUTINE DREPORT(%RECORDNAME DDT,P)
!***********************************************************************
!*    PRINTS OUT A FAILURE REPORT IN A READABLE FORM                   *
!***********************************************************************
%RECORDSPEC DDT(DDTFORM)
%RECORDSPEC P(PARMF)
%RECORDNAME PROP(PROPFORM)
%INTEGER I,J
      PROP==RECORD(DDT_PROPADDR)
      PRINTSTRING('DISC TRANSFER ON '.DDT_LAB." FAILS ")
      PTREC(P)
      PRINTSTRING('SENSE DATA
C0C1C2C3  S0T0T1T2  T3T4T5T6  M0M1M2M3
')
      %CYCLE I=0,4,12
         PRINTSTRING(STRHEX(INTEGER(P_P6+I)).'  ')
      %REPEAT
      PRINTSTRING('
  RQB       LBLOCK     ADDRESS LIST
')
      I=P_P3&255+2
      %IF I<8 %THEN I=8
      %CYCLE J=0,4,4*I
         %IF J<=32 %THEN PRINTSTRING(STRHEX(INTEGER(DDT_RQA+J)).'  ') %C
                  %ELSE PRINTSTRING('          ')
         PRINTSTRING(STRHEX(INTEGER(DDT_LBA+J)).'  ')
         %IF 2*J>=PROP_ALISTSIZE %THEN NEWLINE %ELSE %C
            PRINTSTRING(STRHEX(INTEGER(DDT_ALA+2*J)) %C
            .STRHEX(INTEGER(DDT_ALA+2*J+4))."
")
      %REPEAT
      NEWLINE
%END
%END
%EXTERNALROUTINE PDISC(%RECORDNAME P)
!***********************************************************************
!*    RECEIVES PAGED DISC TRANSFERS. ORGANISES ALL QUEUING AND         *
!*    GENERATES THE CCWS WHICH ARE THE PASSED TO DISC FOR EXECUITION   *
!***********************************************************************
%RECORDSPEC P(PARMF)
%RECORDNAME DDT(DDTFORM)
%RECORDNAME PROP(PROPFORM)
%RECORDNAME RQB(RQBFORM)
%RECORDNAME QHEAD(QFORM)
%RECORDNAME REQ,NEXTREQ(REQFORM)
%CONSTINTEGERARRAY CCW(1:4)=X'04002204',
                  X'84002304',X'84002304',X'24002204';
%CONSTINTEGER PDISCSNO=X'210000';          ! PDISC SERVICE NO(33)
%CONSTINTEGER SD=X'58000000';           ! STRING DESRCPTR FOR ADDRSS LIST
%CONSTINTEGER RETRIES=7,MAXTRANS=8
%CONSTINTEGER IGNORELB=X'400000'
%CONSTINTEGER TRANOK=0,TRANWITHERR=1,TRANREJECT=2,NOTTRANNED=3
%OWNINTEGER NEXT
%OWNINTEGER EMAS=M'EMAS'
%INTEGERFNSPEC GETREC
%ROUTINESPEC PUTREC(%INTEGER REC)
%ROUTINESPEC QUEUE(%RECORDNAME QHEAD,%INTEGER REQ)
%SWITCH PDA(0:10)
%OWNINTEGER INIT
%INTEGER I,ACT,J,ALA,LBA,UNIT,LUNIT,CYL,TRACK,SECT,CELL,XTRA,CURRSECT,%C
         CURRHEAD,FIRSTHEAD,FIRST SECT,ERRLBE,K,UNRECOVERED,NEXTCELL, %C
         NEXTSECT,FAIL
      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(DDTADDR+I*DDTSIZE)
         QHEAD=0;                       ! ZERO WHOLE RECORD
         QHEAD_QSLOT=I+1
         QHEAD_DDTSLOT=I
         QHEAD_PROPADDR=DDT_PROPADDR
         QHEAD_DDTADDR=ADDR(DDT)
      %REPEAT
!
! SET UP REMAINDER OF QSPACE AS A FREE LIST FOR REQUESTS
!
      J=ADDR(QSPACE(1))>>18&255;        ! PUBLIC SEG NO
      J=INTEGER(X'80040000'+8*J)&X'3FF80'+X'80'-160
      I=NDISCS+1
      %UNTIL K>=J %CYCLE
         K=ADDR(QSPACE(I))
         INTEGER(K)=NEXT
         NEXT=I
         I=I+1
         K=K&X'3FFFF'
      %REPEAT
      INIT=1
      %RETURN
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
      %IF NEXT=0 %THEN PON(P) %AND %RETURN;! INCONVENIENT DIRECT CALL
      P_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
!
!      CELL=GETREC
      CELL=NEXT
      NEXT=INTEGER(ADDR(QSPACE(CELL)))
      %IF NEXT=0 %THEN INHIBIT(PDISCSNO>>16)
      REQ==QSPACE(CELL)
      REQ<-P
      REQ_FAULTS=0
      REQ_CTS=CYL<<16!TRACK
      REQ_SECT=SECT
      REQ_REQTYPE=ACT
      QUEUE(QHEAD,CELL)
      ->INIT TRANSFER %IF QHEAD_STATE=0; ! UNIT IDLE
      %RETURN
REJECT:                                 ! REQUEST INVALID
      PRINTSTRING('*** PDISC REJECTS ')
      PTREC(P)
      P_DEST=P_SRCE
      P_SRCE=PDISCSNO+ACT
      P_P2=TRANREJECT;                  ! REJECTED
      PON(P)
      %RETURN
INIT TRANSFER:                          ! SET UP CHAIN AND HAND TO DISC
      DDT==RECORD(QHEAD_DDTADDR)
      REQ==QSPACE(QHEAD_REQLINK)
      PROP==RECORD(QHEAD_PROPADDR)
      ALA=DDT_ALA
      LBA=DDT_LBA
      RQB==RECORD(DDT_RQA)
      CYL=REQ_CTS>>16
      FIRST HEAD=REQ_CTS&255
      FIRST SECT=REQ_SECT
      CURR HEAD=FIRST HEAD
      %IF CYL=0 %THEN XTRA=IGNORELB %ELSE XTRA=0
!
! THE IPL CYL (0) IS NONSTANDARD IN 2 WAYS
! FIRSTLY IT HAS OVERFLOW FORMATS AND SECONDLY TRACK 0 HAS NO KEYS
! DISC TRIES TO HIDE THIS SO THAT THE BULKMOVER ETC CAN BE USED
! TO MOVE CHOSUPI TO THE WORKSITE
!
      %CYCLE I=1,1,MAXTRANS
         J=REQ_CTS&255;                 ! HEAD FOR THIS TRANSFER
         REQ_FLB=(LBA-DDT_LBA)>>2
         %IF J#CURR HEAD %OR CYL=0 %START
            INTEGER(LBA)=X'86000000'+J; ! SELECT HEAD
            LBA=LBA+4
            CURR HEAD=J
         %FINISH
!
         J=REQ_SECT;                    ! ROTATIONAL SECTOR
         %IF I#1 %THEN %START;          ! NOT FIRST TRSFER-CHK ROTATION
            %IF J#NEXT SECT %START
               INTEGER(LBA)=X'86001000'+20*EPAGESIZE*(J-1); ! SET SECTOR FOR J
               LBA=LBA+4                
            %FINISH
         %FINISH
         CURR SECT=J
         J=(LBA-DDT_LBA)>>2;            ! LOGIC BLOCK NO FOR TIC
         K=(ALA-DDT_ALA)>>2;            ! START OF RELEVANT BIT OF ALIST
         INTEGER(LBA)=X'84106900'+K;         ! SEARCH ID =
         INTEGER(LBA+4)=X'01000000'+J;     ! TIC TO SEARCH ID
         INTEGER(ALA)=SD+5
         INTEGER(ALA+4)=ADDR(REQ_CTS)
         LBA=LBA+8
!
! TO REPLACE CHECKING OF THE KEYS WHICH ARE INCLUDED IN THE FORMAT
! UNCOMMENT THE NEXT 8 LINE
!
!         %UNLESS REQ_CTS=0 %THEN %START;   ! CYL=0 & TRACK=0
!            INTEGER(LBA)=X'84006102'+K;       ! SEARCH KEY ==
!            INTEGER(LBA+4)=X'01000002'+J;   ! TIC TO SEARCH KEY=
!            LBA=LBA+8
!         %FINISH
!         INTEGER(ALA+8)=SD+4;              ! KEY LENGTH =4
!         INTEGER(ALA+12)=ADDR(EMAS)
         INTEGER(LBA)=CCW(REQ_REQTYPE&7)!XTRA+K
         INTEGER(ALA+16)=SD+TRANSIZE
         INTEGER(ALA+20)=REQ_COREADDR
         LBA=LBA+4
         ALA=ALA+24
!
! MOVE THE CELL FROM THE REQUEST QUEU TO TRANSFERINPROGRESS QUEU
!
         J=REQ_REQLINK
         REQ_REQLINK=QHEAD_TRLINK
         QHEAD_TRLINK=QHEAD_REQLINK
         QHEAD_REQLINK=J
         REQ_LLB=(LBA-4-DDT_LBA)>>2
!
! SEE IF THERE ANY MORE TRANSFERS AND IF THE ARE ON THE SAME CYL
!
         %IF J=0 %THEN %EXIT
         CELL=J
         REQ==QSPACE(CELL)
         %IF REQ_CTS>>16#CYL %THEN %EXIT
!
! THIS NEXT SECTION OF CODE REORDERS THE NEXT 2 TRANSFERS TO TRY AND
! OPTIMISE ROTATIONAL DELAYS.  I AM UNSURE IF THIS IS WORTH THE 
! EXTRA OCP TIME INVOLVED OR NOT
!
         NEXT SECT=CURR SECT+1
         %IF NEXT SECT>PROP_PPERTRK %THEN NEXT SECT=1
         J=REQ_SECT
         NEXT CELL=REQ_REQLINK
         %IF NEXT CELL#0 %AND J#NEXT SECT %THEN %START
            NEXT REQ==QSPACE(NEXTCELL)
            %IF NEXT REQ_CTS>>16=CYL %AND %C
               (NEXT SECT <= NEXTREQ_SECT <J %OR %C
               J < NEXT SECT <=NEXT REQ_SECT %OR %C
               NEXTREQ_SECT < J < NEXT SECT) %START
               REQ_REQLINK=NEXT REQ_REQLINK
               NEXT REQ_REQLINK=CELL
               QHEAD_REQLINK=NEXT CELL
               REQ==NEXT REQ
            %FINISH
         %FINISH
      %REPEAT
      INTEGER(LBA-4)=INTEGER(LBA-4)&X'FBFFFFFF'
      RQB_W7=X'1E001300'
      RQB_W8=CYL<<16!(20*EPAGESIZE*(FIRST SECT-1))<<8!FIRST HEAD
      P_DEST=DISCSNO+2
      P_SRCE=PDISCSNO+10
      P_P1=QHEAD_QSLOT
      P_P2=QHEAD_DDTSLOT
!      P_P5=RQB_W8
!      P_P6=I
      QHEAD_STATE=1
      DISC(P)
      %RETURN
PDA(10):                                ! REPLY FORM DISC
      QHEAD==QSPACE(P_P1)
      CELL=QHEAD_TRLINK
      %IF P_P2=0 %THEN %START;         ! DUPLICATE CODE FOR SPEED
         P_SRCE=PDISCSNO
         J=NEXT
         %WHILE CELL#0 %CYCLE
            REQ==QSPACE(CELL)
            P_DEST=REQ_SRCE
            P_P1=REQ_IDENT
            PON(P)
!            PUTREQ(CELL)
            INTEGER(ADDR(QSPACE(CELL)))=NEXT
            NEXT=CELL
            CELL=REQ_REQLINK;           ! HAIRY BUT OK AFTER CELL RETURNED
         %REPEAT
         QHEAD_TRLINK=0;                ! NO TRANSFERS IN PROGRESS
         %IF J=0 %THEN UNINHIBIT(PDISCSNO>>16)
         ->INIT TRANSFER %IF QHEAD_REQLINK#0
         QHEAD_STATE=0; %RETURN
      %FINISH
      ERRLBE=P_P3&255
      UNRECOVERED=INTEGER(P_P6+4)&X'F7000000';! LOOK AT 2ND STAUS
      %IF UNRECOVERED =0 %THEN ERRLBE=ERRLBE+1
      FAIL=NOT TRANNED
      %IF INTEGER(P_P6+4)=X'10000000' %AND BYTEINTEGER(P_P6+8)=X'80' %C
         %THEN FAIL=TRANWITH ERR;       ! CYCLIC CHECK ONLY
!
! NOTE RECOVERED ERRORS STOP THE CHAIN ON THE NON-FAILING LBE WHICH
! IS NORMALLY  THE PAGE TRANSFER LBE. THIS BLOCK HAS TRANSFERED OK
! THE NEXT TRANSFERS HAVE NOT BEEN STARTED. THEREFORE UP THE LBE COUNT
! BY ONE AND REFRAIN FROM TAGGING ANY TRANSFER AS HAVING FAILED
! THUS ALL NECESSARY REQUEING SHOULD BE DONE INCLUDING THE CASE WHEN
! THE RECOVERY IS ON THE SEARCH
!
      %WHILE CELL#0 %CYCLE
         REQ==QSPACE(CELL)
         QHEAD_TRLINK=REQ_REQLINK
         %IF REQ_LLB<ERRLBE %OR REQ_FAULTS>RETRIES %START
            P_DEST=REQ_SRCE
            P_SRCE=PDISCSNO+REQ_REQTYPE&15
            P_P1=REQ_IDENT
            %IF REQ_LLB<ERRLBE%THEN P_P2=TRAN OK %ELSE P_P2=FAIL
            PON(P)
            %IF P_P2#0 %THEN %START
               PRINTSTRING("PDISC TRANSFER FAILS :-")
               PTREC(P)
            %FINISH
            PUTREC(CELL)
         %FINISH %ELSE %START
            REQ_FAULTS=REQ_FAULTS+1 %IF REQ_FLB<=ERRLBE<=REQ_LLB %C
                  %AND UNRECOVERED#0
            QUEUE(QHEAD,CELL);             ! REQUEUE FAULTY ONE  & LATERS
         %FINISH
         CELL=QHEAD_TRLINK
      %REPEAT
      ->INIT TRANSFER %IF QHEAD_REQLINK#0
      QHEAD_STATE=0
      %RETURN
%INTEGERFN GETREC
%INTEGER I
!***********************************************************************
!*    PRODUCE A CELL TO QUEUE A REQUEST. INHIBITS WHEN QUEUES FULL     *
!***********************************************************************
      %IF NEXT=0 %THEN OPMESS('Q SPACE????')
      I=NEXT
      NEXT=INTEGER(ADDR(QSPACE(I)))
      %IF NEXT=0 %THEN INHIBIT(PDISCSNO>>16)
      %RESULT=I
%END
%ROUTINE PUTREC(%INTEGER REC)
!***********************************************************************
!*    RETURNS A QUEUE CELL AND ARRANGES ANY UNIHIBITING NEEDED         *
!***********************************************************************
      %IF NEXT=0 %THEN UNINHIBIT(PDISCSNO>>16)
      INTEGER(ADDR(QSPACE(REC)))=NEXT
      NEXT=REC
%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=32
%INTEGER POSN,CELL,NEXTCELL,AD
      NEW==QSPACE(NEWREQ)
      CELL=QHEAD_REQLINK
      %IF CELL=0 %THEN %START;          ! NOTHING QUEUEING
         QHEAD_REQLINK=NEWREQ
         NEW_REQLINK=0
         %RETURN
      %FINISH
      POSN=NEW_DADDR;                   ! PAGE ADDR OF NEW REQUEST
!      ENTRY==QSPACE(CELL);              ! FIRST ON THE QUEUE
!      NEXTCELL=ENTRY_REQLINK
!
!      %WHILE NEXTCELL#0 %CYCLE
!         NEXT==QSPACE(NEXTCELL)
!         %EXIT %IF ENTRY_DADDR<=POSN<=NEXT_DADDR
!         ENTRY==NEXT
!         NEXTCELL=ENTRY_REQLINK
!      %REPEAT
!
!      ENTRY_REQLINK=NEWREQ
      *LSS_QSPACE+4; *ISB_QSIZE; *ST_AD;! KEEP ADDR(QSPACE(0))
      *LSS_POSN;                        ! POSN IN ACC THRO LOOP
      *LB_CELL; *MYB_QSIZE
      *ADB_AD; *LXN_%B;                 ! B TO RECORD ENTRY
      *LB_(%XNB+7); *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+7); *STB_NEXTCELL
      *JAF_12,<AGN>
XIT:  *LSS_NEWREQ; *ST_(%XNB+7);        ! ENTRY_REQLINK=NEWREQ
      NEW_REQLINK=NEXTCELL
%END
%END
! BULK MOVER WRITTEN BY PDS 18TH NOV 76
!
%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)     *
!*                                                                     *
!*       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,TODEV,L,%C
      FDINF1,FDINF2,TODINF1,TODINF2,IDENT,CORE,CDEX,UFAIL,WTRANS, %C
      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
%CONSTINTEGER REQSNO=X'240000',PRIVSNO=X'250000',MAXMASK=X'1E', %C
               GETPAGE=X'50000',RETURNPAGE=X'60000', %C
               CLAIM TAPE=X'31000C',RELEASE TAPE=X'310007', %C
               COMREP=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_L=P_P1&X'FFFF'
      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
         %CYCLE I=BM_CORE,8,BM_CORE+TRANSIZE-8
            LONGINTEGER(I)=0
         %REPEAT
      %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!READ PAGE
         %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 DUMPTABLE(34,BM_CORE,TRANSIZE)
STEP(9):                               ! PAGE WRITTEN
      BM_WTRANS=BM_WTRANS-1 %UNLESS BM_TODEV=5
      ->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
      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
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
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(DDTADDR+I*DDTSIZE)
         %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
            PAGE=PAGE&X'FFFF'!DDT_DLVN<<24
            %RESULT=0
         %FINISH
      %REPEAT
      %RESULT=1
      %END
      %END
%ENDOFFILE