*COMDECK  DECKALL 
          CTEXT  DECKALL  ---  COMMON SUBROUTINE FOR PFM
          LIST   X
DECKALL   TITLE  D E C K A L L   ---   COMMON SUBROUTINES 
**        THE *DECKALL* COMMON DECK CONTAINS COMMON SUBROUTINES 
*         USED BY THE PERMANENT FILE ROUTINES.  EACH SUBROUTINE 
*         IS CONDITIONALLY ASSEMBLED BASED ON A SYMBOL OF THE FORM
*         NAME$  WHERE  NAME  IS THE SUBROUTINE NAME.  IT IS THE
*         RESPONSIBILITY OF THE CALLER TO DEFINE THE SYMBOLS NECESSARY
*         FOR THE ASSEMBLY OF THE REQUIRED SUBROUTINES..
*         CALLING ROUTINES DEFINE TWO BLOCKS OF SYMBOLS - 
*            BLOCK 1 (PRIMARY LEVEL) - SUBROUTINES CALLED DIRECTLY
*                                        BY THE ROUTINE 
*            BLOCK 2 (SECONDARY LEVEL) - SUBROUTINES CALLED 
*                                          BY OTHER SUBROUTINES 
* 
* 
*         APFADR - CALCULATE FWA OF APF ENTRY 
*         APFLAG - CLEAR APF FLAG IN APF ENTRY
*         BACKSP - BACKSPACE FILE ONE PRU 
*         BCOPY - HIGH TO LOW PP STORAGE MOVE 
*         BIND - CONVERT BINARY NUMBER TO DISPLAY CODE DECIMAL CHARACTR 
*         BLANK - BLANK-FILL BYTE OF CHARACTER STRING 
*         BUSYFNT - CLEAR COMPLETE BIT IN FNT 
*         CALL - LOAD ANOTHER PROGRAM INTO PPU
*         CHAINC - BRING RBT CHAIN INTO CM
*         CHKCY - CHECK CYCLE NUMBERS IN PFD ENTRY
*         CHKFDB - CHECK FOR PARAMETER IN FDB 
*         CHKPOS - COMPARE TWO PFD POINTERS 
*         CHKPW - CHECK IF PASSWORD IN FDB
*         CHKSTS - CHECK RETURN STATUS OF A STACK REQUEST 
*         CHKSYSF - CHECK IF FILE IS DAYFILE OR CERFILE 
*         CNTCHR - CALCULATE NUMBER OF CHARACTERS IN PFN
*         COMPARE - COMPARE TWO 9-CHARACTER FIELDS
*         COMPLFN - COMPARE LOGICAL FILE NAMES
*         COPYPW - MOVE PASSWORDS FROM FDB TO PFD/PFC 
*         CYFDB - RETURN CYCLE NUMBER TO FDB
*         DELAY - WAIT FOR EVENT OR DELAY 
*         DFM - SUPPRESS DAYFILE MESSAGES IF  RC  OFF 
*         DIV5 - DIVIDE BY 5
*         ENDSD - COLLECTION OF SUBROUTINES TO SET/CLEAR S.PDESD
*         ERR - PROCESS USER/SYSTEM ERRORS
*         ERRFLG - CHECK CONTROL POINT ERROR FLAG 
*         EXFDB - EXTRACT PARAMETER FROM FDB
*         FCOPY - LOW TO HIGH PP STORAGE MOVE 
*         FDBADR - CALCULATE ABSOLUTE FDB ADDRESS 
*         FINDID - EXTRACT OWNER ID FROM FDB
*         FINDRBR - CALCULATE FWA OF RBR HEADER 
*         FMFO - FIND MF ORDINAL AND PFC I/L BYTE ADDRESS 
*         FREEFNT - SET COMPLETE BIT IN FNT 
*         GETRBT - GET NEXT RBT WORD PAIR 
*         GETSATR - GET PUBLIC SET ATTRIBUTES FROM MST
*         IOPFD - INITIALIZE FOR READ/WRITE OF PFD PRU
*         JSTMOD - DELINK FROM QUEUE IF NEVER SWAPPED 
*         MATCH - COMPARE TWO EQUAL-LENGTH BUFFER 
*         MFPCHK - CHECK PFC INTERLOCK BIT OF OTHER MAINFRAMED
*         MULT5 - MULTIPLY BY 5 
*         PFDIO - SET UP STACK REQUEST FOR READ/WRITE OF PRU
*         RBTADR - COMPUTE RBT WD PR ADDRESS
*         RDRBTC - READ RBTC NON-STOP 
*         READCAT - READ ONE PRU OF RBTC
*         READLBL - READ MASTER LABEL 
*         READPFD - READ PRU FROM SUBDIRECTORY
*         READPRU - READ PRU FROM FILE
*         RELAPF - RELEASE RESERVED EMPTY APF SLOT
*         RELCHN - ZERO RB BYTES AND RELEASE CHAIN
*         RPRU - READ AND CHECK PRU 
*         SRCHCP - SEARCH FOR FNT-S AT CONTROL POINT
*         SRCHFNT - SEARCH FOR FNT OF GIVEN NAME
*         SEARCH - SEARCH PFD 
*         SRPRU - READ ONE SUBDIRECTORY NON-STOP
*         VALCHR - CHECK FOR SPECIAL CHARACTERS IN A STRING 
*         WRTPFD - WRITE PRU TO SUBDIRECTORY
*         WRTPRU - WRITE PRU TO FILE
*         WPRU - WRITE A PRU AND RECOVER IF CONNECT BROKEN
*         SAVE - SAVE PRU CONTENTS IN BUFFER
*         RCAT - SET THE WRAP-AROUND FLAG IN MST
*         DCAT - CLEARS THE WRAP-AROUND FLAG IN MST 
*         INTRLCK - CLEAR ALL INTERLOCKS
*         FNTIL -CALL TO COMPLETE FNT IN ERR
*         RPFM - RESERVE PFM I/L IN MST 
*         DPFM - DROP PFM I/L IN MST
*         DROPIL - RELEASE DEVICE INTERLOCK 
APFADR    SPACE  4,12 
APFADR    IF     DEF,APFADR$
**        APFADR
*         ------
* 
*         SUBROUTINE TO CALCULATE FWA OF APF ENTRY
* 
*         ENTRY  (PPFM1 - PPFM1+4) = P.PFM1 
*                (APFO) = APF ORDINAL 
* 
*         EXIT   (A-REG) = FWA OF APF ENTRY 
  
  
APFADR    ENM    X                 ENTRY / EXIT 
  
          LDM    PPFM1+C.APF-1
          LPN    77B
          SHN    12 
          ADM    PPFM1+C.APF
  
          DUP    LE.APF,1 
          ADM    APFO 
  
          SBN    LE.APF 
          UJN  APFADRX
APFADR    ENDIF 
APFLAG    SPACE  4,12 
APFLAG    IF     DEF,APFLAG$
**        APFLAG
*         ------
* 
*         SUBROUTINE TO CLEAR APF FLAG IN APF ENTRY 
* 
*         ENTRY  (APFO) = APF ORDINAL 
* 
*         EXIT   APF FLAG IN APF ENTRY CLEARED
*                (CPTFLGS) = INTERNAL FLAG (APFF) CLEARED AS INTERLOCK
*                              DOUBLE CHECK 
* 
*         USES   D.T0 - D.T4
* 
*         CALLS  APFADR 
*                ERR (CODE 13)
  
  
APFLAG10  BSS    0
          LMD    CPTFLGS
          STD    CPTFLGS
          RJM  APFADR 
          ADN    1
          CRD    D.T0 
          LDD    D.T0+C.PFLAG 
          SCK    IBIT 
          STD    D.T0+C.PFLAG 
          RJM  APFADR 
          ADN    1                 SECOND WORD
          CWD    D.T0 
  
APFLAG    ENM    X                 ENTRY / EXIT 
  
          LDD    CPTFLGS
          LPK    APFF 
          NJN  APFLAG10 
* 
          LDN    CODE13            *INTERLOCK PROBLEM*
          RJM  ERR
APFLAG    ENDIF 
BACKSP    SPACE  4,12 
BACKSP    IF     DEF,BACKSP$
**        BACKSP
*         ------
* 
*         SUBROUTINE TO BACKSPACE ONE PRU 
* 
*         ENTRY  (REQTAB+1) = FST ADDRESS 
*                VARIABLES - FLAGS, PSEUBF, JTEMP 
* 
*         EXIT   IF FILE IS NOT ON AN RB BOUNDARY,
*                  UPDATE FST WITHOUT ISSUING STACK REQUEST 
* 
*         USES   D.T0 - D.T4   ORDER
*                STACKRE1 - STACKRE1+4   STACKRE2 - STACKRE2+4
* 
*         CALLS  R.RAFL 
*                PFDIO
*                R.EREQS
*                DELAY
  
  
BACKSP30  BSS    0
          SOD    D.T0+C.FLPRU 
          LDM    REQTAB+1 
          CWD    D.T0 
  
BACKSP    ENM    X                 ENTRY / EXIT 
  
          LDM    REQTAB+1 
          CRD    D.T0 
          LDD    D.T0+C.FLPRU 
          NJN  BACKSP30 
* 
          RJM  R.RAFL 
          LDN    O.BPRU 
          STM    ORDER
          LDC    REQTAB 
          RJM  PFDIO
          LDN    1                 NUMBER OF PRUS TO BACKSPACE
          STD    STACKRE2+2 
          LDN    0
          STD    STACKRE2 
          STD    STACKRE2+1 
          CRD    D.T0 
          LDM    REQTAB+1          CLEAR ACTIVITY BIT IN FST
          ADN    1
          CWD    D.T0 
          LDN    STACKRE1 
          STD    D.T0 
          RJM  R.EREQS
BACKSP10  BSS    0
          LDM    REQTAB+1 
          ADN    1
          CRD    D.T0 
          LDD    D.T4 
          LPN    1
          ZJN  BACKSP20 
          LJM  BACKSPX
* 
BACKSP20  BSS    0
          LDN    1
          RJM  DELAY
          UJN  BACKSP10 
BACKSP    ENDIF 
BCOPY     SPACE  4,12 
BCOPY     IF     DEF,BCOPY$ 
**        BCOPY 
*         ----- 
* 
*         SUBROUTINE TO DO PP STORAGE MOVE (HIGH TO LOW)
* 
*         ENTRY  (A-REG) = NUMBER OF BYTES TO BE MOVED
*                (TEMP1) = SOURCE ADDRESS 
*                (TEMP2) = TARGET ADDRESS (GREATER THAN TEMP1)
* 
*         USES   D.Z0 
  
  
BCOPY     ENM    X                 ENTRY / EXIT 
  
          ZJN  BCOPYX 
          STD    D.Z0              SAVE NUMBER OF BYTES 
          SBN    1
          RAD    TEMP1
          LDD    D.Z0 
          SBN    1
          RAD    TEMP2
BCOPY10   BSS    0
          LDI    TEMP1
          STI    TEMP2
          SOD    TEMP1
          SOD    TEMP2
          SOD    D.Z0 
          NJN  BCOPY10
          UJN  BCOPYX              RETURN 
BCOPY     ENDIF 
BIND      SPACE  4,12 
BIND      IF     DEF,BIND$
**        BIND
*         ----
* 
*         SUBROUTINE TO CONVERT A BINARY NUMBER TO THREE
*         DISPLAY CODE DECIMAL CHARACTERS 
* 
*         ENTRY  (COUNT) = BINARY NUMBER TO BE CONVERTED
* 
*         EXIT   (A-REG) = THREE DISPLAY CODE DECIMAL CHARACTERS
* 
*         USES   TIME   TEMP2   SCRATCH   REMAIN   TEMP1
* 
*         CALLS  DIV5 
  
  
BIND30    BSS    0
          LDD    SCRATCH     LOAD HUNDREDS DIGITS 
          SHN    6
          LMD    REMAIN      PLUS TENS DIGIT
          SHN    6
          LMD    TEMP1       PLUS UNITS 
          ADC    3R000       CONVERT TO DISPLAY CODE
  
BIND      ENM    X                 ENTRY / EXIT 
  
          STD    TIME 
          LDN    1
          STD    TEMP2
          LDD    TIME 
  
BIND10    RJM    DIV5        DIVIDE BY 5
          LDD    SCRATCH     DIVIDE BY 2
          SHN    17D
          STD    SCRATCH
          PJN  BIND20        IF EVEN
          LDN    5           ADVANCE REMAIN 
          RAD    REMAIN 
BIND20    BSS    0
          SOD    TEMP2
          MJN  BIND30        IF FINISHED
          LDD    REMAIN            STORE UNITS DIGIT
          STD    TEMP1
          LDD    SCRATCH
          UJN  BIND10        LOOP FOR HUNDREDS AND TENS DIGITS
BIND      ENDIF 
BLANK     SPACE  4,12 
BLANK     IF     DEF,BLANK$ 
**        BLANK 
*         ----- 
* 
*         SUBROUTINE TO BLANK-FILL ONE BYTE OF RIGHT-JUSTIFIED
*         CHARACTER STRING
* 
*         ENTRY  (A-REG) = BYTE OF STRING 
* 
*         EXIT   (A-REG) = BLANK-FILLED BYTE
* 
*         USES   D.Z0 
  
  
BLANK10   LDD    D.Z0              LOAD ONE CHAR
          LMN    1R                CLEAR LOWER BLANK
* 
BLANK20   LMC    2R                PLUS TWO BLANKS
  
BLANK     ENM    X                 ENTRY / EXIT 
  
          ZJN  BLANK20             IF NO CHAR 
          STD    D.Z0 
          SCN    77B               CHECK FOR ONE CHAR 
          ZJN  BLANK10             IF ONLY ONE CHAR 
* 
          LDD    D.Z0              RETURN GIVEN TWO CHARS 
          UJN  BLANKX 
BLANK     ENDIF 
BUSYFNT   SPACE  4,12 
BUSYFNT   IF     DEF,BUSYFNT$ 
**        BUSYFNT 
*         ------- 
* 
*         SET FNT BUSY
* 
*         ENTRY  UFNT CONTAINS ADDRESS OF FNT 
*                D.FNT-D.FNT+4 CONTAINS FIRST WD OF FNT 
* 
*         EXIT   FNT SET BUSY (COMPLETE BIT CLEARED)
*                OR PP REINITIALIZED IF FNT ALREADY BUSY
*                (A-REG " 0) FNT SET BUSY AND CALLED BY PFE 
*                (A-REG = 0) FNT ALREADY BUSY AND CALLED BY PFE 
* 
*         CALLS  DELAY,ERR,R.RCH,R.DCH,COMPLFN,CHKSYSF
* 
*         USES   D.Z1-D.Z5
  
  
          IFANY  (RENAME,EXTEND),1
BUSYFNT   RMT 
BUSY1     LDN    CH.FST 
          RJM  R.DCH
          LCN    RC003
          RJM  ERR
  
BUSYFNT   ENM    X
  
          LDN    CH.FST 
          RJM  R.RCH
  
*         CHECK IF FNT CHANGED
  
          LDC    LFN
          STD    D.Z1 
          RJM  COMPLFN             COMPARE LFN
          NJN  BUSY1               IF FNT NO LONGER THERE 
          LDD    D.CPAD 
          SHN    -7 
          LMD    D.FNT+C.FCPNUM    COMPARE CT PT NO 
          LPK    L.CPNUM
          ZJN  BUSY3
          LDD    D.FNT+C.FCPNUM    CHECK FOR CT PT ZERO 
          LPK    L.CPNUM
          NJN  BUSY1
BUSY3     BSS    0
          LDM    UFNT 
          ADN    W.FCS
          CRD    D.Z1 
          LDD    D.Z1+1+C.FSC 
          LPN    1
          ZJN  BUSYDLY             FNT ALREADY BUSY 
          LMD    D.Z1+1+C.FSC 
          STD    D.Z1+1+C.FSC      SET FNT BUSY (CLEAR COMPLETE BIT)
          LDD    D.Z1+C.FFETAD
          SCN    77B
          STD    D.Z1+C.FFETAD
          LDN    0
          STD    D.Z1+C.FFETAD+1
          LDM    UFNT 
          ADN    W.FCS
          CWD    D.Z1 
BUSY4     LDN    CH.FST 
          RJM  R.DCH
          IF     DEF,EXTEND,1 
          LDN    1
          LJM  BUSYFNTX 
  
  
*         REINITIALIZE PP ROUTINE AFTER 2 SEC DELAY 
  
BUSYDLY   LDN    CH.FST 
          RJM  R.DCH
BUSYPFE   IF     DEF,EXTEND 
          RJM  CHKSYSF
          NJN  BUSY5               IF NOT DAYFILE OR CERFILE
          LDN    1
          RJM  DELAY
          LDN    0
          LJM  BUSYFNTX 
  
BUSY5     BSS    0
BUSYPFE   ENDIF 
  
          LDD    D.PPIRB+1
          SCK    40B
          STD    D.PPIRB+1
          LDD    D.PPMES1 
          CWD    D.PPIRB
          LDN    2
          STD    D.T1 
          LDN    0
          STD    D.T2 
          LDN    M.RPJD 
          RJM  R.MTR
          LJM  R.IDLE 
          IFANY  (RENAME,EXTEND),1
BUSYFNT   RMT 
BUSYFNT   ENDIF 
CALL      SPACE  4,12 
CALL      IF     DEF,CALL$
**        CALL
*         ----
* 
*         SUBROUTINE TO CALL ANOTHER PP PROGRAM 
*         INTO THIS PERIPHERAL PROCESSOR
* 
*         ENTRY  (A-REG) = NAME OF PP ROUTINE 
* 
*         CALLS  DELAY  ( (RETADDR) = 0 ) 
  
  
CALL      ENM    X                 ENTRY /
  
          SHN    12 
          STD    D.PPIRB
          SHN    -6 
          SCN    77B
          LMD    D.PPIRB+1
          SCN    77B
          LMD    D.PPIRB+1         SET CONTROL POINT NO.
          STD    D.PPIRB+1
          LDD    D.PPIR 
          CWD    D.PPIRB
          LDN    0
          STM    RETADDR
  
          IFNE   IP.CC7,0,1 
CALL67    BSS    0
  
          RJM  DELAY
CALL      ENDIF 
CHAINC    SPACE  4,12 
CHAINC    IF     DEF,CHAINC$
**        CHAINC
*         ------
* 
*         SUBROUTINE TO BRING RBT CHAIN INTO CENTRAL MEMORY 
* 
*         ENTRY  (SECT1 - SECT1+477B) = PFC PRU 
* 
*         EXIT   (FRBT/RBTA/RBTO/PRU) = FST FOR FILE
* 
*         USES   D.Z1 - D.Z5   D.T0 - D.T4
* 
*         CALLS  MULT5
*                FINDRBR
*                R.RCH
*                R.DCH
*                DELAY
*                RBTPOS 
*                READPRU
  
          IF     DEF,CATALOG2,1 
SEG2FC    RMT 
  
CHAINC    ENM    X                 ENTRY / EXIT 
  
          LDN    0
          STM    FRBT              INITIALIZE FIRST RBT WD PR ORD BYTE
          LDN    P.RBT
          CRD    D.Z1 
          LDM    SECT1+CTPT,RBTCIX  LOAD T-POINTER
          RJM  MULT5
          ADD    RBTCIX 
          ADK    CLNGTH 
          ADC    SECT1
          STD    TEMP              PONTER TO THE BEGINING OF CHAIN
  
          LDM    CRBTDAM,TEMP 
          SHN    S.RBTDRB 
          STM    DAMORD 
          LDM    C.RBTAL,TEMP 
          SCN    77B
  
          IF     DEF,ATTACH,1 
          LMM    MSTORD 
  
          STM    DEVTYPE
          RJM  DCDWP
          NJN  CHAINC5             IF DDT ENTRY FOUND 
          IF     DEF,CATALOG2,1 
CHAINC1   LJM  CHAINCX
          IF     DEF,ATTACH,1 
CHAINC1   LJM  CHAINC99 
  
CHAINC5   BSS    0
          LDM    C.RBTFB,TEMP 
          LPN    7
          STM    RBTO 
  
          IF     DEF,ATTACH,1 
          STM    FRB
          LDM    C.RBTBIT,TEMP
RBTPFC    BIT    S.RBTPFC 
          SCK    RBTPFC 
          ADK    RBTPFC            SET CATALOG PF BIT 
          STM    C.RBTBIT,TEMP
  
          LDN    0
          STM    PRU
          LDD    CPTFLGS
          LPK    CHAINCM
          ZJN  CHAINC10            IF CHAIN NOT IN CM 
          UJK  CHAINCX
  
  
CHAINC10  LDI    TEMP              SAVE FOR LAST RBT WORD PAIR CHECK
          STM    CHAINC70    * * * INSTRUCTION MODIFY * * * 
          LDM    C.RBTDRB,TEMP
          SHN    -S.RBTDRB
          LMC    777B 
          NJN  CHAINC15            NOT AN OVERFLOW WORD PAIR
          LDM    CRBTDAM,TEMP 
          STM    C.RBTODO,TEMP
          SHN    S.RBTDRB 
          STM    DAMORD 
          LDC    777B*1S3 
          STM    C.RBTDRB,TEMP
          LDI    TEMP              NEXT RBT WD PR ORDINAL 
          ZJN  CHAINC14            IF NO MORE WORD PAIRS
          RJM  DCDWP
          NJN  CHAINC20            IF DDT ENTRY FOUND 
          UJK  CHAINC1
  
CHAINC14  LDM    C.RBTMST,TEMP
          LPN    77B
          SHN    18-S.RBTMST
          ADM    MSTORD 
          SHN    S.RBTMST 
          STM    C.RBTMST,TEMP
          UJN  CHAINC20 
  
  
CHAINC15  LJM  CHAINC16 
  
CHAINC16  BSS    0
**        ADD DAM ORDINAL TO NON-OVERFLOW WORD PAIR 
*         GET RBT WORD PAIR ,LINK AND WRITE 
          RJM  CHAINLK
          LJM  CHAINC7
          SPACE  3
CHAINLK   ENM    X
          LDM    C.RBTDRB,TEMP
          LPN    7
          ADC    ** 
DAMORD    EQU    *-1         * * *  INSTRUCTION MODIFIED  * * * 
          STM    C.RBTDRB,TEMP
* 
CHAINC20  LDN    CH.RBT 
          RJM  R.RCH
          LDN    P.RBT
          CRD    D.T0 
          LDD    D.T2              FWA/2 OF EMPTY CHAIN 
          NJN  CHAINC30            IF EMPTY CHAIN NOT EMPTY 
* 
          LDN    CH.RBT 
          RJM  R.DCH
  
          IF     DEF,ATTACH,2 
          LDD    TEMP 
          STD    TEMP2
  
          LDC    500               1/2 SECOND DELAY 
          RJM  DELAY
  
          IF     DEF,ATTACH,2 
          LDD    TEMP2
          STD    TEMP 
  
          RJM  ERRFLG              CHECK IF ERROR FLAG SET
          ZJN  CHAINC20            IF ERROR FLAG NOT SET
EVICT     IF     DEF,ATTACH 
          LDC    PFMGR+BUFLNG      BEG LOCATION OF 8PA OVERLAY
          STD    D.T3 
OV.8PA    EQU    3R8PA
          LDC    3RA8P
          RJM  CALLOVL             CALL 8PA OVERLAY 
          LJM  CLEANUP2 
EVICT     ENDIF 
  
          IF     DEF,CATALOG2,1 
          LJM  CHAINCX
  
* 
          IF     DEF,ATTACH,2 
CHAINC30  LDC    7777B
PASTRBT   EQU    *-1
          IF     -DEF,ATTACH,1
CHAINC30  LDM    PASTRBT
          LMC    7777B
          ZJN  CHAINC40            IF FIRST TIME THROUGH
* 
          RJM  RBTPOS 
          CRD    D.Z1 
          LDD    D.T2              PUT IN LINK POINTER
          STD    D.Z1 
          RJM  RBTPOS 
          CWD    D.Z1              WRITE OUT AGAIN
          UJN  CHAINC50 
* 
CHAINC40  LDD    D.T2              SET UP FNT FOR FILE
          STM    FRBT 
          STM    RBTA 
CHAINC50  LDD    D.T2 
          STM    PASTRBT           SET PAST RBT=CURRENT 
          LDN    0
          STI    TEMP              SET CURRENT LINK TO ZERO 
          RJM  RBTPOS 
          CRD    D.Z1 
          LDD    D.Z1 
          STD    D.T2 
          LDN    P.RBT             WRITE OUT TO LOW CORE
          CWD    D.T0              CURRENT RBT ADDRESS
          LDD    TEMP 
          STM    CHAINC60    * * * INSTRUCTION MODIFY * * * 
          LDN    2
          STD    D.Z1 
          RJM  RBTPOS 
          CWM    **,D.Z1           WRITE RBT TO HIGH CORE 
CHAINC60  EQU    *-1
          LDN    CH.RBT 
          RJM  R.DCH
          LJM  CHAINLKX 
          SPACE  3
CHAINC7   BSS    0
          LDC    **                ORIGINAL RBT CHAIN POINTER 
CHAINC70  EQU    *-1
          NJN  CHAINC80 
          UJK  CHAINCX
* 
CHAINC80  LDN    10D
          RAD    TEMP 
          ADC    -SECT1-466B       SEE IF END OF PRU
          ZJN  CHAINC85 
          LDD    TEMP 
          ADC    -SECT1-473B       SEE IF END OF PRU
          NJN  CHAINC90 
  
          IF     DEF,ATTACH,2 
CHAINC85  LDK    O.RDP             READ INTO PP ORDER CODE
          RJM  READPRU             READ PFC ENTRY PRU 
          IF     -DEF,ATTACH,1
CHAINC85  RJM  RPRU                READ NEXT PRU
  
* 
CHAINC86  LDC    SECT1+5
          STD    TEMP 
* 
CHAINC90  UJK  CHAINC10            REPEAT 
  
CHNPFA    IF     DEF,ATTACH 
OV.8PA    EQU    3R8PA
* 
*         CALL OVERLAY 8PA TO EVICT RBT CHAIN AND CALL 1PC
* 
CHAINC99  BSS    0
          LDC    PFMGR+BUFLNG      BEG LOCATION OF 8PA OVERLAY
          STD    D.T3 
          LDC    3RA8P
          RJM  CALLOVL
          LJM  CLEANUP
CHNPFA    ENDIF 
D.PPTWO   EQU    D.SV1
RBTPOS    SPACE  3,5
**        RBTPOS
*         ------
* 
*         SUBROUTINE TO CALCULATE RBT ADDRESS 
  
  
RBTPOS    ENM    X                 ENTRY / EXIT 
  
          LDD    D.T4              GET ADR OF RBT WORD PAIR 
          SHN    5                 IN HIGH CORE 
          SBM    PASTRBT
          SHN    1
          UJN  RBTPOSX
DCDWP     SPACE  4,15 
**        DCDWP 
*         ----- 
* 
*         SUBROUTINE TO CHANGE THE STRUCTURE OF USER SET FIRST AND
*         OVERFLOW WORD PAIRS.
* 
*         ENTRY  SECT1 CONTAINS PFC ENTRY 
*                TEMP POINTS TO CURRENT WORD PAIR IN SECT1
  
DCDWP     ENM    X                 ENTRY / EXIT 
  
          LDM    C.RBTMST,TEMP
          LPN    77B
          SHN    18-S.RBTMST
          ADM    MSTORD 
          SHN    S.RBTMST 
          STM    C.RBTMST,TEMP
          RJM  FINDAUS
          STM    C.RBTAUS+5,TEMP
          UJN  DCDWPX 
  
          IF     DEF,CATALOG2,1 
SEG2FC    RMT                      END OF SEG2FC BLOCK
SEG8PA    RMT 
**        SEGMENT  8PA
* 
*         CLEAN UP PROCESSING IF PART OF FILE IS ON IDLE DEVICE 
* 
CHNPFA    IF     DEF,ATTACH 
          TITLE  8PA
8PA       SEGMENT  PFMGR+BUFLNG+L.PPHDR 
          ORG      PFMGR+BUFLNG+L.PPHDR 
CLEANUP   BSS    0
          LDC    MESSA
          RJM  DFM                 ISSUE DAYFILE MESSAGE
          LDN    0
          RJM  FDBADR              LOAD FDB ADDR
          CRD    D.T0 
          LDD    D.T4              LOAD RC FIELD, BITS 6-8 BYTE 4 
          LPC    100B              EXTRACT RC BIT, BIT 6
          ZJN  CLEANUP1            IF OWNCODE ERROR PROCESSING SPECIFIED
* 
*         SET ERROR FLAG TO ABORT JOB 
* 
          LDD    D.CPAD            CONTROL POINT AREA ADDRESS 
          ADN    W.CPEF            ERROR FLAG WORD IN C P AREA
          CRD    D.T0 
          LDD    D.T0+C.CPEF       ERROR FLAG BYTE
          LDN    F.ERPP            SET PPU ABORT IN C P ERR FLAG
          STD    D.T0+C.CPEF
          LDD    D.CPAD            CONTROL POINT AREA ADDRESS 
          ADN    W.CPEF            ERROR FLAG WORD IN C P AREA
          CWD    D.T0 
          LDC    MESSB+50000B      SEND MESS TO JOB DAYFILE ONLY
          RJM  DFM                 ISSUE DAYFILE MESSAGE
          UJN  CLEANUP2 
* 
*         SET ERROR CODE 43B IN FDB 
* 
CLEANUP1  LDD    D.T4              ERR CODE IN BITS 9-11 OF BYTE 4
          LPC    777B 
          ADC    3000B
          STD    D.T4 
          LDD    D.T3              AND BITS 0-2 OF BYTE 3 
          SCN    7B 
          ADN    4
          STD    D.T3 
          LDD    D.T4              STATUS BYTE BITS 0-8 
          SCN    1
          ADN    1                 SET COMPLETE BIT IN FDB
          STD    D.T4 
          LDN    0
          RJM  FDBADR              LOAD FDB ADDR
          CWD    D.T0 
* 
*         CALL 1PC TO CLEAN UP FNT, APF, AND PFC ENTRY
* 
CLEANUP2  BSS    0
          RJM  RELCHN              RELEASE RBT CHAIN
          RJM  APFLAG              CLEAR APF INTERLOCK
          LDC    7777B             ADDR OF FNT ADDRESS
          STD    D.FA              STORE FOR 1PC
          LDM    UFNT              FNT ADDRESS
          STI    D.FA              LOC 7777 HAS FNT ADDR
          LDN    1                 NUM OF FNT FOR 1PC TO PROCESS
          STD    D.FA+1            STORE FOR 1PC
          LDC    OV.1PC 
          SHN    12D
          STD    D.T6 
          SHN    -6 
          SCN    77B
          STD    D.T7 
          LJM  R.OVLJ 
  
RC043     EQU    43B
MESSA     DIS    ,*PF ABORT*
MESSB     DIS    ,*FILE RESIDES ON UNAVAILABLE DEVICE*
SEG8PAR   HERE
SEG8PAX   HERE
CHNPFA    ENDIF 
          IF     DEF,ATTACH,2 
          IFGT   *+4,ATT92Z,1 
          ERR 
SEG8PA    RMT 
  
CHAINC    ENDIF 
CHKCY     SPACE  4,12 
CHKCY     IF     DEF,CHKCY$ 
**        CHKCY 
*         ----- 
* 
*         SUBROUTINE TO CHECK CYCLE NUMBERS IN PFD ENTRY
*         AND CALCULATE LOWEST/HIGHEST CYCLE NUMBERS
* 
*         ENTRY  (A-REG) = PROPOSED CYCLE NUMBER
*                (ENTCOUNT) = PFD ENTRY POSITION IN SECT1 
*                (TEMP1) = 7776 IF MINIMUM CYCLE DESIRED
*                        = 0 IF MAXIMUM CYCLE DESIFED 
* 
*         EXIT   (TEMP1) = DESIRED CYCLE NUMBER 
*                (TEMP2) = DESIRED CYCLE NUMBER SLOT INDEX
*                (CYMATCH) = MATCHED CYCLE NUMBER SLOT INDEX
* 
*         USES   SCRATCH   TEMP 
  
  
CHKCY     ENM    X                 ENTRY / EXIT 
  
          STD    SCRATCH
          LDN    0
          STD    TEMP 
          LCN    1
          STM    CYMATCH
          LDC    SECT1+PCYNUM 
          ADD    ENTCOUNT 
          STM    CHKCY10+1
* 
CHKCY10   LDM    **,TEMP
          SBD    SCRATCH
          ZJN  CHKCY40             IF FOUND 
          ADD    SCRATCH
          SBD    TEMP1
CHKCY15   PJN  CHKCY30
          RAD    TEMP1       BETTER CYCLE FOUND 
          LDD    TEMP 
          STD    TEMP2
CHKCY30   BSS    0
          LDN    5                 ADVANCE INDEX
          RAD    TEMP 
          SBN    25D
          NJN  CHKCY10             IF NOT AT END
          UJK  CHKCYX 
* 
CHKCY40   BSS    0
          LDD    TEMP 
          STM    CYMATCH
          UJN  CHKCY30
CHKCY     ENDIF 
CHKPW     SPACE  4,12 
CHKPW     IF     DEF,CHKPW$ 
**        CHKPW 
*         ----- 
* 
*         SUBROUTINE TO CHECK IF NAMED P/W IS IN FDB
* 
*         ENTRY  (A-REG) = P/W POSITION IN PFD ENTRY
* 
*         EXIT   (A-REG) = 0 IF OK
*                (A-REG) = -1 IF NOT OK 
* 
*         USES   TEMP1   REMAIN   TEMP2 
* 
*         CALLS  EXFDB
*                COMPARE
  
  
CHKPW     ENM    X                 ENTRY / EXIT 
  
          STD    TEMP1             POSITION T/K PASSWORD
          LDN    PWC               PASSWORD KEYWORD CODE
          STD    REMAIN 
CHKPW10   BSS    0
          LDD    REMAIN 
          RJM  EXFDB
          MJN  CHKPW20             IF NOT FOUND 
          LDC    BUF
          STD    TEMP2
          RJM  COMPARE
          ZJN  CHKPWX              IF OK
          AOD    REMAIN 
          SBN    PWC+5
          MJN  CHKPW10
* 
CHKPW20   LCN    1
          UJN  CHKPWX              RETURN 
CHKPW     ENDIF 
CHKSTS    SPACE  4,12 
CHKSTS    IF     DEF,CHKSTS$
**        CHKSTS
*         ------
* 
*         SUBROUTINE TO GET THE RETURN
*         STATUS OF A STACK REQUEST 
* 
*         ENTRY  NONE 
* 
*         EXIT   IF RECEIVES ERRORS OR 3 SUCCESSIVE 
*                BROKEN CONNECTS, ABORTS JOB AND ISSUES 
*                MESSAGE *ERROR IN PFD/PFC READ/WRITE*
*                UNLESS THIS IS 1QF 
*                ELSE, (A) = 0, NORMAL COMPLETION 
*                      (A) =-VE, CONNECT BROKEN 
*                      (A) = +VE, I/O ERR OR DEV I/L BROKEN 3 TIMES 
* 
*         USES   D.T0-D.T0+4
  
CHKSTS1   LDN    0
          STM    ERRCNT 
  
CHKSTS    ENM    X                 ENTRY/EXIT 
  
          LDN    1
          STM    STRI 
          LDD    D.PPMES1 
          ADN    W.RWPPCW 
          CRD    D.T0              GET COMMUNICATION WORD 
          LDD    D.T0+3 
          LPN    3                 MASK OUT LOWER TWO BITS
          SHN    12 
          ADD    D.T0+4 
          SHN    -9                BITS 9-13 CONTAINS RETURN STATUS 
          ZJN  CHKSTS1             IF NO ERROR RETURN STATUS
          SBN    1B 
          ZJN  CHKSTS1             IF EOI ENCOUNTERED 
          SBN    23B
          NJN  CHKSTS2             IF NOT BROKEN CONNECT STATUS (24B) 
  
          LDN    0
          STM    STRI              CONNECT BROKEN, CLEAR INTERNAL SR I/L
          AOM    ERRCNT            INCREMENT ERROR COUNT
          SBN    3
          NJN  CHKSTSX             IF NOT EXCEEDS 3 TIMES 
  
CHKSTS2   BSS    0
CAFLG     IFNONE (LOA,QFILE)
          LDD    CPTFLGS
          LPK    APFF 
          ZJN  CHKSTS3             IF APF FLAG NOT SET
          LMD    CPTFLGS
          STD    CPTFLGS
          RJM  APFADR 
          ADN    1
          CRD    D.T0 
          LDD    D.T0+C.PFLAG 
          SCK    IBIT              CLEAR APF FLAG 
          STD    D.T0+C.PFLAG 
          RJM  APFADR 
          ADN    1
          CWD    D.T0 
CAFLG     ENDIF 
  
NOABT     IFANY  (QFILE)
          LDC    *-*               FLAG TO INDICATE IF 1QF CAN BE 
NOABT     EQU    *-1               RESTARTED
          NJK  CHKSTSX             IF 1QF CANNOT BE RESTARTED 
NOABT     ENDIF 
CHKSTS3   RJM  DPFM                DROP PFM I/L 
          LCN    RC073             * ERROR ON PFC/PFD READ/WRITE *
          RJM  ERR
  
  
ERRCNT    BSSZ   1                 STACK REQUEST ERROR COUNT
  
CHKSTS    ENDIF 
CHKFDB    SPACE  4,12 
CHKFDB    IF     DEF,CHKFDB$
**        CHKFDB
*         ------
* 
*         SUBROUTINE TO CHECK FOR NONZERO FDB PARAMETER 
* 
*         ENTRY  (A-REG)  = CODE FOR PARAMETER
* 
*         EXIT   (A-REG) = -1 IF PARAMETER VALUE NOT IN FDB 
* 
*         CALLS  EXFDB
  
  
CHKFDB0   LCN    1
CHKFDB    ENM    X
          RJM  EXFDB
          MJN  CHKFDBX
          LDM    BUF+4
          SHN    -6 
          ADM    BUF+3
          ZJN  CHKFDB0
          UJN  CHKFDBX
CHKFDB    ENDIF 
CHKSYSF   SPACE  4,12 
CHKSYSF   IF     DEF,CHKSYSF$ 
**        CHKSYSF 
*         ------- 
* 
*         CHECK IF FILE IS DAYFILE OR CERFILE 
* 
*         ENTRY  LFN CONTAINS LOGICAL FILE NAME 
*                D.CPAD CONTAINS CONTROL POINT ADDRESS
* 
*         EXIT   (A-REG) = 0 IF DAYFILE OR CERFILE
*                (A-REG) " 0 OTHERWISE
  
  
CHKSYSF   ENM    X
          LDD    D.CPAD 
          NJN  CHKSYSFX            IF NOT A CP 0
  
*         CHECK IF LAST THREE CHAR OF LFN ARE -ILE- 
  
          LDM    LFN+3
          LMC    1RE*100B 
          NJN  CHKSYSFX 
          LDM    LFN+2
          LMC    2RIL 
          NJN  CHKSYSFX 
          UJN  CHKSYSFX 
CHKSYSF   ENDIF 
CHKPOS    SPACE  4,12 
CHKPOS    IF     DEF,CHKPOS$
**        CHKPOS
* 
*         SUBROUTINE TO COMPARE TWO PFD POSITIONS RELATIVE TO A HASH
*         POINT.  POSITIONS ARE TWO WORD ENTRIES.  THE FIRST IS THE 
*         ENTRY OFFSET, THE SECOND IS THE PRU OFFSET.  POINTER ADDRESSES
*         ON ENTRY ARE OFFSETS FROM PTRTBL. 
* 
*         ENTRY  (A)     = 2**12*FIRST POSITION+SECOND POSITION 
*                HASHPTR = PRU OFFSET OF HASH POINT 
* 
*         EXIT   (A) = FIRST POSITION - SECOND POSITION RELATIVE TO THE 
*                      HASH POINT.
  
CHKPOS    ENM    X                 ENTRY / EXIT 
  
          STD    D.Z1 
          SHN    -12
          STD    D.Z3 
          LDM    PTRTBL+1,D.Z1
          SBM    HASHPTR+1
          STD    D.Z2 
          LDM    PTRTBL+1,D.Z3
          SBM    HASHPTR+1
          STD    D.Z4 
          LDD    D.Z4 
          SBD    D.Z2 
          NJN  CHKPOSX             PRU OFFSETS ARE NOT EQUAL
          LDM    PTRTBL,D.Z3
          SBM    PTRTBL,D.Z1
          UJK  CHKPOSX
CHKPOS    ENDIF 
CNTCHR    SPACE  4,12 
CNTCHR    IF     DEF,CNTCHR$
**        CNTCHR
*         ------
* 
*         SUBROUTINE TO CALCULATE NUMBER OF PFN CHARACTERS
*         AND ADD TO TOP SIX BITS OF OWNER-1
* 
*         USES   TEMP2   TEMP   TEMP1 
  
  
CNTCHR30  BSS    0
          LDD    TEMP2
          LPN    77B
          SHN    6
          RAM    OWNER-1
  
CNTCHR    ENM    X                 ENTRY / EXIT 
  
          LDN    0
          STD    TEMP2
          LDC    PFN
          STD    TEMP 
          ADN    20 
          STD    TEMP1
CNTCHR10  BSS    0
          LDI    TEMP 
          SCN    77B
          ZJN  CNTCHR30 
          LDI    TEMP 
          LPN    77B
          ZJN  CNTCHR20 
          AOD    TEMP2
CNTCHR20  BSS    0
          AOD    TEMP2
          AOD    TEMP 
          SBD    TEMP1
          ZJN  CNTCHR30 
          UJN  CNTCHR10 
CNTCHR    ENDIF 
COMPARE   SPACE  4,12 
COMPARE   IF     DEF,COMPARE$ 
**        COMPARE 
*         ------- 
* 
*         SUBROUTINE TO COMPARE TWO 9-CHARACTER FIELDS
* 
*         ENTRY  (TEMP1) = ADDRESS OF ONE FIELD 
*                (TEMP2) = FWA OF BYTES TO COMPARE
* 
*         EXIT   (A-REG) = 0  IF GOOD COMPARE 
*                (A-REG) = -1 IF BAD COMPARE
* 
*         USES   D.Z3   D.Z1   D.Z2 
  
  
COMP20    LCN    1
  
COMPARE   ENM    X                 ENTRY / EXIT 
  
          LDN    0
          STD    D.Z3 
          LDD    TEMP1
          STD    D.Z1 
COMP10    BSS    0
          LDI    TEMP2
          SBI    D.Z1 
          NJN  COMP20              IF NOT EQUAL 
          AOD    D.Z1 
          AOD    TEMP2
          AOD    D.Z3 
          SBN    4
          MJN  COMP10 
* 
          LDI    TEMP2
          SCN    77B
          STD    D.Z2 
          LDI    D.Z1 
          SCN    77B
          SBD    D.Z2 
          ZJN  COMPAREX 
          UJK  COMP20 
COMPARE   ENDIF 
COMPLFN   SPACE  4,12 
COMPLFN   IF     DEF,COMPLFN$ 
**        COMPLFN 
*         ------- 
* 
*         SUBROUTINE TO COMPARE LOCAL FILE NAMES
* 
*         ENTRY  D.FNT-D.FNT+4 HAS FIRST WD OF FNT
*                D.Z1 CONTAINS ADDRESS OF LFN 
* 
*         EXIT   (A-REG) = 0 LFN MATCH
*                (A-REG) " 0 LFN DO NOT MATCH 
* 
COMPLFN   ENM    X
          LDD    D.FNT             COMPARE CHARS 1,2
          LMI    D.Z1 
          NJN  COMPLFNX            IF NOT A MATCH 
          LDD    D.FNT+1           CHARS 3,4
          LMM    1,D.Z1 
          NJN  COMPLFNX 
          LDD    D.FNT+2           CHARS 5,6
          LMM    2,D.Z1 
          NJN  COMPLFNX 
          LDD    D.FNT+3           CHAR 7 
          LMM    3,D.Z1 
          SHN    -6 
          UJN  COMPLFNX 
COMPLFN   ENDIF 
COPYPW    SPACE  4,12 
COPYPW    IF     DEF,COPYPW$
**        COPYPW
*         ------
* 
*         SUBROUTINE TO COPY PASSWORD FROM FDB TO PFD/PFC ENTRY BUFFER
* 
*         ENTRY  (A-REG) = PASSWORD FDB CODE
*                (ENTCOUNT) = BYTE INDEX TO START OF PFD ENTRY (*PFC*)
*                (RBTCIX) = BYTE INDEX TO START OF PFC ENTRY (*1FC*)
* 
*         EXIT   PASSWORD STORED IN SLOT IN SECT1 BUFFER
* 
*         USES   TEMP1   TEMP2
* 
*         CALLS  EXFDB
*                MULT5
*                BCOPY
  
  
COPYPW30  AOM    COPYPW10    * * *   MODIFY INSTRUCTION   * * * 
  
COPYPW    ENM    X                 ENTRY / EXIT 
  
          STM    COPYPWA
          RJM  EXFDB
          PJN  COPYPW20            IF PASSWORD SPECIFIED
COPYPW10  LDN    **          * * *   INSTRUCTION MODIFIED   * * * 
          NJN  COPYPWX             IF NOT SPECIFIED AND NO *XR* 
  
*         IF PASSWORD NOT DEFINED FOR CN/MD/EX, USE XR IF SPECIFIED 
  
          LDN    XRC               XR KEYWORD CODE
          RJM  EXFDB
          MJN  COPYPW30            IF PASSWORD NOT SPECIFIED
* 
          LDM    COPYPWA
          SBN    CNC               CONTROL KEYWORD CODE 
          MJN  COPYPWX             IF NOT CN/MD/EX
          SBN    RDC-CNC
          PJN  COPYPWX             IF NOT CN/MD/EX
* 
COPYPW20  LDN    2
          STD    D.T2              ALLOW LEADING ZEROS FOR VALCHR 
          LDC    BUF+5*1S12        COMPARE 1 WORD 
          RJM  VALCHR 
          ZJN  COPYPW25            ALL CHARACTERS ARE LEGAL 
          RJM  RELAPF 
          RJM  DPFM 
          LCN    RC026
          RJM  ERR
  
COPYPW25  LDM    BUF+4
          SCN    77B
          STM    BUF+4             CLEAR PASSWORD CODE
          LDC    BUF
          STD    TEMP1             SOURCE ADDRESS 
          LDC    SECT1+PWTK 
          ADD    ENTCOUNT 
          STD    TEMP2             TARGET ADDRESS 
          LDC    ** 
COPYPWA   EQU    *-1
          SBN    TKC               TURNKEY KEYWORD CODE 
          RJM  MULT5
          RAD    TEMP2
          LDN    5
          RJM  FCOPY
          UJK  COPYPWX
COPYPW    ENDIF 
CYFDB     SPACE  4,12 
CYFDB     IF     DEF,CYFDB$ 
**        CYFDB 
*         ----- 
* 
*         SUBROUTINE TO RETURN CYCLE NUMBER TO FDB
* 
*         ENTRY  (CYCLE) = CYCLE NUMBER 
* 
*         EXIT   CYCLE NUMBER IN FDB (IF CY PARAMETER PRESENT)
* 
*         USES   TEMP   D.T0 - D.T5 
* 
*         CALLS  EXFDB
*                FDBADR 
  
  
CYFDB     ENM    X                 ENTRY / EXIT 
  
          LDN    CYC               CYCLE NUMBER KEYWORD CODE
          RJM  EXFDB
          MJN  CYFDBX 
          STD    TEMP 
          LDN    P.ZERO 
          CRD    D.T0 
          LDD    CYCLE
          SHN    12 
          STD    D.T3 
          SHN    -6 
          ADN    CYC
          STD    D.T4 
          LDD    TEMP 
          RJM  FDBADR 
          CWD    D.T0 
          UJN  CYFDBX 
CYFDB     ENDIF 
DELAY     SPACE  4,12 
DELAY     IF     DEF,DELAY$ 
**        DELAY 
*         ----- 
* 
*         SUBROUTINE TO ALLOW A ROUTINE TO WAIT FOR A CERTAIN EVENT 
*         OR CALL ANOTHER ROUTINE INTO THE PP 
* 
*         A WAIT CAN BE ACHIEVED IN FOUR WAYS 
*                1) INTERNAL FIXED INTERVAL DELAY 
*                2) ENTRY INTO THE FIXED INTERVAL DELAY STACK 
*                3) ENTRY INTO EVENT STACK
*                4) SWAPOUT 
* 
*         THREE WORDS OF INFORMATION ARE STORED IN THE LAST 
*         THREE WORDS OF THE PP MESSAGE BUFFER IN THE 
*         LATTER THREE CASES AND IN THE CASE OF ANOTHER 
*         PF ROUTINE CALL 
* 
*         THE INFORMATION IS RESTORED BY INIT SUBROUTINE AND
*         A RETURN TO THE ADDRESS AFTER THE CALL TO DELAY CAN 
*         BE ACHIEVED 
* 
*         ENTRY- ACCUM=0           ANOTHER PF ROUTINE CALL REQUESTED
*                ACCUM=NEG         SWAPOUT
*                ACCUM MORE THAN 1000B   ENTER EVENT STACK
*                ACCUM LES THAN 1000B    INTERNAL DELAY 
* 
*         IF ANOTHER PF ROUTINE IS TO BE CALLED, RETADDR HAS
*         ADDRESS TO RETURN TO
* 
*         IF DELAY IS CALLED BY PFA, ALL FUNCTIONS OF THE 
*         DELAY SUBROUTINE EXCEPT INTERNAL DELAYS ARE PERFORMED 
*         BY THE OVERLAY 1PD
  
  
DELAY     ENM    X                 ENTRY / EXIT 
  
          PJN  DEL3A
          LMC    -0 
          STM    SWAP 
  
**
*         IF RT BIT SET IN FDB, DO NOT QUEUE BUT RETURN A 
*                                  CODE OF 25B
* 
          LDN    0
          RJM  FDBADR              ELSE,CHECK RT FLAG IN CALL 
          CRD    D.T0 
          LDD    D.T4 
          LPC    200B              RT BIT 
          ZJN  DEL4 
          LJM  DDELAY11 
* 
* 
DEL3A     UJN  DEL3 
* 
* 
* 
DEL5      LDM    RETADDR
          STD    D.T0 
          UJN  DEL6 
* 
DEL3      BSS    0
          STD    TIME 
          ZJN  DEL5 
          ADC    -1000B 
          PJN  DEL1 
**
*         IF EVENT STACK ENTRY, ACCUM ON ENTRY TO DELAY 
*         WILL HAVE 1000B + BIT NUMBER OF BIT IN MST I/L BYTE 
*         ON WHICH PP PROGRAM IS TO WAIT TILL OFF IN PP 
*         IF BIT 11 SET IN ACCUMULATOR DELAY IS ON THE APF FLAG 
*         OF AN APF ENTRY 
*         STACK 
* 
* 
DEL2      LDC    125D              ** 
          SBN    1                 *1/4MSEC DELAY*REPEATED FOR
          NJN  *-1                 **             * N MSECS 
          SOD    TIME                             * 
          NJN  DEL2                               **
          RJM  R.RAFL 
          UJK  DELAYX 
* 
* 
* 
DEL1      STD    D.FNT+4           LOAD BIT NUMBER OF I/L IN QUESTION 
DEL4      LDM    DELAYX+1          LOAD AND SAVE
          STD    D.T0 
* 
*         STORE INFORMATION 
* 
DEL6      LDM    PFMI 
          ADM    STRI 
          ZJN  DEL60               IF ALL INTERLOCKS ARE CLEAR
  
          LDN    CODE13            *INTERLOCK PROBLEM*
          RJM  ERR
  
DEL60     LDM    SUBD 
          LPC    777B 
* 
          STD    D.T1              SUBD 
          LDM    MSTORD 
          STD    D.T2 
          LDM    APFO 
          STD    D.T3 
          LDM    UFNT 
          STD    D.T4 
* 
*         STORE FIRST WORD
* 
*         FORMAT
*         BYTE  0     1      2      3       4 
*         *********************************** 
*         *RETAD* SUBD *MSTORD* APFO * UFNT *   RETAD=RETURN ADDRESS
*         *********************************** 
          LDD    POINT+3
          SHN    6
          STD    POINT+3
          LDD    CPTFLGS
          STD    POINT+4
* 
*         STORE SECOND WORD 
* 
*         FORMAT
* 
*         BYTE  0     1      2      3        4
*         ************************************
*         *PNT  *PNT+1 *PNT+2 *PNT+3 *CPTFLGS*      PNT = POINT 
*         ************************************
* 
*         PNT+3  IS IN THE HIGHER 6 BITS OF BYTE 3
          LDM    RBTC+3 
          SHN    6
          ADM    PERM 
          STM    RBTC+3 
          LDD    CYCLE
          STM    RBTC+4 
* 
*         STORE THIRD WORD
* 
*         FORMAT
* 
*         BYTE  0     1      2      3       4 
*         *********************************** 
*         *RBTC  *RBTC+1*RBTC+2*+3PERM*CYCLE* 
*         *********************************** 
* 
*         BYTE 3 HAS RBTC+3 IN HIGH ORDER 6 BITS AND PERM IN
*                              LOWER SIX BITS 
* 
          LDD    D.PPMES1 
          ADN    W.PPMES4-2 
          CWM    D.T0,D.PPONE 
          CWM    POINT,D.PPONE
          CWM    RBTC,D.PPONE 
* 
DEL6A     BSS    0
**
* 
*         OTHER PF ROUTINES ARE CALLED BY MODIFYING THE PP
*         INPUT REGISTER INCLUDING THE SETTING OF BIT 40
*         AND THEN JUMPING TO R.IDLE
* 
*         BIT 40 IF SET SIGNIFIES THAT A PF PP PROGRAM SHOULD 
*         INITIALIZE USING THE LAST THREE WORDS OF THE
*         MESSAGE BUFFER
          LDD    TIME 
          ADM    SWAP 
          NJN  DEL7 
          LDD    D.PPIRB+1
          SCN    40B
          ADN    40B
          STD    D.PPIRB+1
          LDD    D.PPIR 
          CWD    D.PPIRB
          RJM  R.RAFL 
          UJK  R.IDLE 
* 
DEL7      LDM    SWAP 
          ZJN  DDELAY1
* 
**
*         IF RUNNING AT CONTROL POINT ZERO, JOB WILL NOT BE 
*         SWAPPED OUT BECAUSE IT HAS NO JDT 
* 
DEL8      LDD    D.CPAD 
          ZJN  DDELAY11 
          LJM  SWAPOUT
* 
DDELAY11  BSS    0
          RJM  APFLAG              DROP APF FLAG
          LCN    RC025
          RJM  ERR
* 
* 
DDELAY1   BSS    0
**
*         ENTER  EVENT STACK
* 
*         PUT INPUT REGISTER IMAGE IN W.PPMES1
*         THREE WORDS OF INFORMATION IN W.PPMES4-W.PPMES6 
* 
*         (0040,00AA,AAAA,****,SYTT)  IN W.PPOR 
*                AAAAAA = WORD ADDRESS OF THE EVENT STATUS BIT
*                Y = BYTE ADDRESS WITHIN THE WORD (0-4) 
*                TT = BIT ADDRESS WITHIN THE BYTE (0-11)
*                S = F + B
*                F = 0   ASSIGN WHEN BIT=0
*                F = 4   ASSIGN WHEN BIT=1
*                B = 0   AAAAAA IS AN ABSOLUTE ADDRESS
*                B = 1   RELATIVE TO RA 
*                B = 2   CONTROL POINT AREA ADDRESS 
* 
*         CURRENTLY,     AAAAAA = MST ENTRY STARTING ADDRESS
*                        F=0, B=0, Y=4, TT=VARIABLE 
* 
          RJM  R.RAFL 
PFEDLY    IFNONE (EXTEND) 
          LDD    D.PPIRB+1
          SCN    40B
          ADN    40B
          STD    D.PPIRB+1
          LDD    D.PPIR 
          CWD    D.PPIRB
PFEDLY    ENDIF 
          LDN    M.EESD 
          STD    D.FNT
          LDD    D.FNT+4
          SHN    6
          PJN  EVENT
          RJM  APFADR              WAIT ON FLAG IN APF ENTRY
          ADN    1
          STD    D.FNT+2
          SHN    -12
          STD    D.FNT+1
          LDC    C.PFLAG*100B+F.ESOFF+F.ESABS-4000B 
          RAD    D.FNT+4
          UJN  EVENT2 
* 
EVENT     BSS    0
          IFANY  (EXTEND),1 
          RJM  APFLAG              CLEAR APF FLAG 
          RJM  MSTADR              GET MST ENTRY STARTING ADDRESS 
          STM    D.FNT+2
          SHN    -12
          STM    D.FNT+1
          LDC    C.PFMIL*100B+F.ESOFF+F.ESABS 
          RAD    D.FNT+4
EVENT2    BSS    0
          IFANY  (EXTEND),1 
          RJM  FREEFNT             SET FNT NOT BUSY 
          LDD    D.PPMES1          PP MSG BUFFER ADDRESS
          SBN    1
          CWD    D.FNT
          ADN    1
          CWD    D.PPIRB
          RJM  R.WAIT 
* 
*         DROP, WHICH FOLLOWS, CAN BE USED APART FROM DELAY 
* 
          UJK  R.IDLE              PP 
* 
* 
SWAPOUT   BSS    0
**
* 
*         SWAPOUT IS INITIATED BY CALLING 1PF USING R.OVL 
*         1PF SHOULD NOT BE PUT IN INPUT REGISTER THIS ALLOWS 
*         PFA TO BOUNCE IF NOT SWAPPABLE
* 
          RJM  R.RAFL 
          LDM    SWAP 
          STD    TIME 
          LDC    OV.1PF 
          SHN    12 
          STD    D.T6 
          SHN    -12
          SHN    6
          STD    D.T7 
          LDD    D.PPIRB+1
          SCN    40B
          ADN    40B
          STD    D.PPIRB+1
          LDD    D.PPIR 
          CWD    D.PPIRB
          LDC    C.PPFWA-5
          LJM  R.OVLJ 
DELAY     ENDIF 
DFM       SPACE  4,12 
DFM       IF     DEF,DFM$ 
**        DFM 
*         --- 
* 
*         SUBROUTINE TO SUPPRESS DAYFILE MESSAGES IF RC OFF 
* 
*         ENTRY  (A-REG) = FWA OF MESSAGE 
* 
*         USES   D.Z1 - D.Z5
* 
*         CALLS  FDBADR 
*                R.DFM
  
  
DFM10     LDC    ** 
          RJM  R.DFM
  
DFM       ENM    X                 ENTRY / EXIT 
  
          STM    DFM10+1           SAVE MESSAGE ADDRESS AND FLAGS 
          SHN    -12
          LPN    7
          ADC    2000B             *LDC*
          STM    DFM10
          LDN    0
          RJM  FDBADR 
          CRD    D.Z1 
          LDD    D.Z5 
          SHN    17-6 
          MJN  DFM10               IF *RC* FLAG ON
          UJN  DFMX                ELSE,DO NOT ISSUE MESSAGE
DFM       ENDIF 
DFMSG     SPACE  4,12 
DFMSG     IF     DEF,DFMSG$ 
**        DFMSG 
*         ----- 
* 
* 
*         SUBROUTINE TO ISSUE DAYFILES MESSAGES 
* 
* 
*         USES   TEMP1,CYCLE,MESS13,NUMMSG,MSGTBL,DFMFLAG 
* 
*         CALLS  DFM,BIND 
  
  
DFMSG     ENM    X
  
CYCLE     IF     DEF,CATALOG
          LDD    CYCLE             CYCLE NUMBER 
          RJM  BIND                CONVERT TO DISPLAY CODE
          STM    MESS13+8            ADD TO MESSAGE 
          SHN    -12D 
          ADC    1R *1S6
          STM    MESS13+7 
CYCLE     ENDIF 
  
          LDN    0
          STD    TEMP1             INITIALIZE PTR TO DAY MSG TABLE
DFMFLG1   LDM    DFMFLAG,TEMP1     FLAG FOR CORRESPONDING MSG IN TABLE
          ZJN  DFMFLG2             IF CORRESPONDING MSG NOT TO BE ISSUED
          LDM    MSGTBL,TEMP1      ADDRESS OF MESSAGE 
          ADC    5*1S12            SEND MSG ONLY TO JOB DAYFILE 
          RJM  DFM                 ISSUE DAYFILE MESSAGE
DFMFLG2   AOD    TEMP1             INCREMENT POINTER TO TABLE 
          SBN    NUMMSG            CHECK FOR END OF TABLE 
          MJN  DFMFLG1             IF MORE DAY MSG FLAGS TO CHECK 
          UJK  DFMSGX 
  
DFMSG     ENDIF 
DIV5      SPACE  4,12 
DIV5      IF     DEF,DIV5$
**        DIV5
*         ----
* 
*         SUBROUTINE TO DIVIDE BY 5 
* 
*         ENTRY  (A-REG) = NUMBER 
* 
*         EXIT   (SCRATCH) = NUMBER/5 
*                (REMAIN) = REMAINDER 
  
  
DIV5      ENM    X                 ENTRY / EXIT 
  
          STD    REMAIN            STORE NUMBER 
          LDN    0                 ZERO 
          STD    SCRATCH           SCRATCH WORD 
DIV10     BSS    0
          LDD    REMAIN 
          SBN    5B                SUBTRACT 5 
          MJN  DIV5X               IF -VE ,END
          STD    REMAIN            TEMPORARY SAVE 
          AOD    SCRATCH           BUMP DIVISION COUNT BY ONE 
          UJN  DIV10
DIV5      ENDIF 
DPFM      SPACE  4,12 
DPFM      IF     DEF,DPFM$
**        DPFM
*         ----
* 
*         DROP PFM INTERLOCK IN MST 
* 
*         ENTRY  PFMI SHOULD BE NONZERO 
* 
*         EXIT   PFM INTERLOCK CLEARED
* 
*         USES   D.T0-T4
* 
*         CALLS  MSTADR,DROPIL,ERR,R.RCH,R.DCH
  
  
DPFM1     LMD    D.T0+C.PFMIL      CLEAR PFM I/L BIT
          STD    D.T0+C.PFMIL 
          RJM  MSTADR              LOAD MST ADDRESS 
          CWD    D.T0 
          LDN    0                 CLEAR INTERNAL PFM I/L FLAG
          STM    PFMI 
          LDN    CH.MST            DROP MST CHANNEL 
          RJM  R.DCH
  
DPFM      ENM    X
  
          LDM    PFMI              CHECK INTERNAL PFM I/L FLAG
          NJN  DPFM3               IF FLAG ON 
DPFM2     LDN    CODE13            *INTERLOCK PROBLEM*
          RJM  ERR                 ISSUE BAD MONITOR REQUEST
DPFM3     RJM  DROPIL              DROP DEVICE I/L
          LDN    CH.MST            RESERVE MST CHANNEL
          RJM  R.RCH
          RJM  MSTADR              LOAD MST ADDRESS 
          CRD    D.T0 
          LDD    D.T0+C.PFMIL      INTERLOCK BYTE IN MST
          LPN    PFMIL             PFM I/L BIT
          NJN  DPFM1               INTERLOCK IS ON
          UJN  DPFM2               ERROR - INTERLOCK ALREADY DROPPED
DPFM      ENDIF 
DROPIL    SPACE  4,12 
DROPIL    IF     DEF,DROPIL$
*         DROPIL
*         ------
* 
*         ISSUE DUMMY STACK REQUEST 
*         TO RELEASE THE DEVICE INTERLOCK 
* 
*         ENTRY  STRI NONZERO IF DEVICE INTERLOCK TO BE DROPPED 
*                STACK REQUEST SET UP IN STACKRE1-STACKRE2+4
* 
*         EXIT   DEVICE INTERLOCK RELEASED
* 
*         CALLS  R.READP
  
  
DROPIL    ENM    X
  
          LDM    STRI              INTERNAL DEVICE I/L FLAG 
          ZJN  DROPILX             IF DEVICE I/L ALREADY DROPPED
          LDD    STACKRE1+C.STO    CHANGE ORDER CODE
          SCN    77B               TO NON-INTERLOCKED 
          ADN    O.RDP             READ ORDER CODE
          STD    STACKRE1+C.STO 
          LDD    STACKRE2+C.STPFW  SET PP BUFFER LWA EQUAL FWA
          STD    STACKRE2+C.STPLW  SO NOTHING READ
          LDN    STACKRE1          ISSUE STACK REQUEST
          RJM  R.READP
          LDN    0                 CLEAR INTERNAL DEVICE I/L FLAG 
          STM    STRI 
          UJN  DROPILX
DROPIL    ENDIF 
ERR       SPACE  4,12 
ERR       IF     DEF,ERR$ 
**        ERR 
*         --- 
* 
*         SUBROUTINE TO PROCESS USER/SYSTEM ERRORS
* 
*         ENTRY-    ACCUM +VE  SYSTEM ABORT MESSAGE AND CODE
*                             WRITTEN TO DAYFILE
*                   IF IP.DEBUG .NE. 0, ISSUE 77B BAD MTR REQUEST 
*                   ACCUM - VE MESSAGE ALREADY GIVEN, IF ERROR CODE 
*                              LESS THAN -70B, USER IS ABORTED IF 
*                              RC NOT SPECIFIED, ELSE CODE IS RETURNED. 
*                              ERROR CODES GREATER THAN -67B ARE
*                              UNCONDITIONAL FATAL ERRORS.
*                   ACCUM = 0      PF  REQUEST SUCCESSFUL 
  
          IF     DEF,PFA5PA,1 
SEG5PA    RMT 
  
          IF     -DEF,PFA5PA,1
ERR       ENM    X                 ENTRY /
  
PFAERR    IF     DEF,PFA5PA 
ERROR     BSS    0
          LDM    CYERR
          ZJN  LDDERR 
          RJM  BIND 
          STM    MESS13+8 
          SHN    -12
          ADC    5500B
          STM    MESS13+7 
          LDC    MESS13+50000B
          RJM  DFM
  
LDDERR    BSS    0
          LDM    SAVERR 
          LPN  77B
          SHN  12D
          ADM    SAVERR+1 
PFAERR    ENDIF 
          ZJN  ERR0 
          PJN  ERRA 
          LJM  ERR1 
* 
PFPERR    IF     DEF,ATTACH 
ERR0      LDD    CPTFLGS           FLAG BYTE
          LPK    PURPFN 
          NJN  ERR01               IF PURGE BY PFN
          LJM  ERR1BB 
  
ERR01     LDC    OV.PFP            CALL PFP 
          RJM  CALL 
PFPERR    ENDIF 
          IF     -DEF,ATTACH,1
ERR0      LJM  ERR1BB 
* 
ERRA      BSS    0
          STM    ACUM 
          IF     -DEF,ONEPD,4 
          IF     -DEF,CATALOG,2 
          IF     -DEF,ATTACH,1
          IF     DEF,LOA,1
          RJM  RELAPF              RELEASE RESERVED EMPTY APF SLOT
* 
          RJM  DROPIL              RELEASE DEVICE I/L 
  
ERRB      BSS    0
          LDC    ** 
ACUM      EQU    *-1
          RJM  BIND 
          STM    MESS16+9          AND STORE IN MESSAGE 
          LDD    D.PPIRB
          STM    MESS16 
          LDD    D.PPIRB+1         STORE PF 
          SCN    77B               FUNCTION 
          ADN    1R                NAME 
          STM    MESS16+1          IN MESSAGE 
          LDC    MESS16            THEN 
          RJM  R.DFM               WRITE MESSAGE TO DAYFILE 
  
          RJM  MSTADR                                                    SC45982
                                                                         SC45982
          CRD    D.T0                                                    SC45982
          LDD    D.T0+C.PFMIL                                            SC45982
          SHN    17D-S.MSDPF                                             SC45982
          MJN  ERRB.1              IF PF DEFAULT SET                     SC45982
          SHN    S.MSDPF-S.MSSYS                                         SC45982
          MJN  ERRB.1              IF SYS SET                            SC45982
          UJK  ERR4                IF PRIVATE USER SET                   SC45982
                                                                         SC45982
ERRB.1    BSS    0                                                       SC45982
          IF     DEF,FNTIL$,1 
          RJM  FNTIL               COMPLETE FNT 
DEBUG     IFNE   IP.DEBUG,0 
          LDM    ERR               CALLING ADDRESS TO ERR 
          STD    D.T4 
          LDK    M.KILL            SYSTEM ERROR 
          RJM  R.MTR               SO KILL MONITOR
**
* 
*         IF IP.DEBUG-0 AND A SYSTEM ERROR IS ENCOUNTERED 
*         ALL INTERLOCKS WILL BE CLEARED
* 
 DEBUG    ELSE   1
          RJM  INTRLCK
DEBUG     ENDIF 
  
          UJK  ERR4 
* 
ERR1      LMC    -0 
ERR1BB    STD    TEMP 
          IFANY  (EXTEND,CATALOG),1 
          RJM  FREEFNT             SET COMPLETE BIT IN FNT
EXTSYSF   IF     DEF,CATALOG2 
          LDD    CPTFLGS
          LPK    LPFF+LPFCL 
          LMK    LPFF+LPFCL 
          ZJN  ERR1BD              IF 1FC CALLED BY LPF 
          RJM  FREEFNT             SET COMPLETE BIT IN FNT
ERR1BD    BSS    0
EXTSYSF   ENDIF 
* 
* 
FREEFNT   IF     DEF,RENAME 
          LDC    LFN
          RJM  SRCHCP 
          NJN  ERR1BD              IF LFN DOES NOT EXIST
ERR1BC    LDD    D.T0 
          STM    UFNT 
          RJM  FREEFNT
ERR1BD    BSS    0
FREEFNT   ENDIF 
          IF     -DEF,ONEPD,4 
          IF     -DEF,CATALOG,2 
          IF     -DEF,ATTACH,1
          IF     DEF,LOA,1
          RJM  RELAPF              RELEASE RESERVED EMPTY APF SLOT
**
* 
*         ALL INTERLOCKS ARE CHECKED TO BE OFF
* 
          IF     DEF,FNTIL$,1 
          RJM  FNTIL               COMPLETE FNT 
          RJM  DROPIL              DROP SR I/L
DPFM      IF     -DEF,ONEPD 
          LDM    PFMI              PF MGR I/L FLAG
          ZJN  ERR1A               IF PP DOES NOT STILL HAVE PFM I/L
          RJM  DPFM                DROP PFM I/L 
DPFM      ENDIF 
  
* 
ERR1A     BSS    0
  
LOAD      IF     -DEF,LOA 
          LDD    CPTFLGS
          LPK    APFF 
          ZJN  ERR3 
          LDN    CODE13            INTERLOCK PROBLEM
          LJM  ERRA 
LOAD      ELSE
  
          UJN  ERR3 
LOAD      ENDIF 
* 
* 
ERR4      LDC    MESS92 
          RJM  R.DFM
ERR41A    LDN    M.ABORT
          RJM  R.MTR
          LJM  R.IDLE 
* 
* 
* 
MSG       IF     DEF,RENAME 
ERR3      RJM  DFMSG               CHECK FOR DAY MSGS TO BE ISSUED
          LDD    TEMP 
MSG       ELSE
ERR3      LDD    TEMP              LOAD COMPLEMENT OF RETURN CODE 
MSG       ENDIF 
          ZJN  EXIT          JIF NO ERROR 
          SBN    RC072       COMPARE WITH FDB-ADDR ERROR
          ZJN  ERR3.1        CALL 1PD IF FDB ERROR
  
LOAD1     IF     -DEF,LOA 
          LDD    CPTFLGS
          LPK    LPFF+LPFCL+RELEASE 
          LMK    LPFF+LPFCL+RELEASE 
          ZJN  EXIT 
          LDN    0
          RJM  FDBADR        COMPUTE ABSOLUTE FDB ADDRESS 
          CRD    D.T0        READ FDB WORD CONTAINING RC OPTION 
          LDD    D.T4        LOAD RC FIELD, BITS 6-8
          LPC    100B        EXTRACT RC BIT, BIT 6
          ZJN  EXIT          JIF OWNCODE ERROR PROCESSING SPECIFIED 
LOAD1     ENDIF 
  
ERR3.1    UJK  EXITA1        CALL OVL 1PD TO PROCESS USER ERROR 
* 
**
* 
*         THE RETURN CODE IS PUT IN BITS 9-17 OF WORD 5 OF
*         THE FDB 
* 
EXIT      BSS    0
  
RCOF23    IF     DEF,PFA5PA 
          LDD    TEMP 
          NJN  EXITA
          LDD    CPTFLGS
          LPK  INCOM               CHECK FOR INCOMPLETE CYCLE 
          ZJN  EXITA               IF NOT INCOMPLETE CYCLE
          LDC    MESS93+5*1S12     SEND MSG ONLY TO JOB DAYFILE 
          RJM  R.DFM               ISSUE DAYFILE MESSAGE
          LDD    D.CPAD            CONTROL POINT ADDRESS
          ZJN  EXITAA              C.P. = 0, SET RC023 UNCOND.
          LDN    0
          RJM  FDBADR              FDB ADDRESS
          CRD    D.T0 
          LDD    D.T4 
          SHN    11D
          MJN  EXITA               IF RC NOT SPECIFIED
EXITAA    BSS    0
  
*         IF CONTROL POINT=0,CYCLE IS INCOMPLETE, IT IS SPECIAL CASE
*         TIME.  THIS MEANS RETURN AN ERROR CODE OF 23B.
  
          LDN    RC023
          STD    TEMP 
RCOF23    ENDIF 
  
EXITA     LDN    0
          RJM  FDBADR 
          CRD    D.T0 
          LDD    TEMP              SET ERROR CODE IN FDB
          SHN    9
          LMD    D.T4 
          LPC    77000B 
          LMD    D.T4 
          STD    D.T4 
          SHN    -12
          LMD    D.T3 
          LPN    77B
          LMD    D.T3 
          STD    D.T3 
          LDN    0
          RJM  FDBADR 
          CWD    D.T0 
EXIT1     BSS    0
  
          LDD    D.T4 
          SCN    1
          ADN    1                 SET COMPLETION BIT ONLY IF NOT 
          STD    D.T4              RETURNING TO ANOTHER PP PROGRAM
  
ACC       IF     -DEF,CATALOG 
ACC       IF     -DEF,SETP
          IF     -DEF,ATTACH
          IF     -DEF,LOA 
          LDD    CPTFLGS
          LPK    ACCOUNTF 
          ZJN  NOACCNT             IF NO ACCOUNTING REQUIRED
          LDD    TEMP 
          NJN  NOACCNT
          LJM  ACCNT
NOACCNT   BSS    0
ACC       ENDIF 
  
          LDN    0
          RJM FDBADR
          CWD    D.T0 
          LDD    TEMP 
          ZJN  ERR92               IF WITHOUT ERROR 
          IF     DEF,CATALOG2,3 
          SBN    5B                RBTC FULL,ERROR CODE 5 
          ZJN  EXITA1 
          LDD    TEMP 
          SBN    70B
          MJN  ERR92
  
          IF     DEF,ATTACH,1 
          UJN  EXITA1 
          IF     -DEF,ATTACH,1
          LJM  ERR4 
* 
* 
ERR92     LDN    M.DPP
          RJM  R.MTR
          UJK  R.IDLE 
* 
  
EXITA1    LDC    7700B
          STD    TEMP1
OV.1PD    EQU    OV.1PD 
OV.1PD    EQU    3R1PD
          LDC    3RD1P
          STD    D.T6 
          SHN    -6 
          SCN    77B
          STD    D.T7 
          LDC    1100B
          STM    R.OVL
          SBN    L.PPHDR
          LJM    R.OVL+1           LOAD AND EXECUTE 1PD 
* 
*   CALL PFM ACCOUNTING 
* 
ACC       IF     -DEF,ATTACH
ACC       IF     -DEF,SETP
ACC       IF     -DEF,CATALOG 
ACC       IF     -DEF,LOA 
ACCNT     BSS    0
  
RNM       IF     DEF,RENAME 
          LDC    LFN
          RJM  SRCHCP              GO FIND FNT
          LDD    D.T0 
          STM    UFNT              RESET FWA FNT FOR ACCOUNTING 
          LDC    SECT1
          STD    D.SX7             STORE POINTER TO OLD PFN/ID IN 67B 
          LDD    CYCLE
OLDCYCLE  EQU    66B
          STD    OLDCYCLE          SET OLD CYCLE
          RJM  APFADR              GET NEW CYCLE FROM APF 
          ADN    1
          CRD    D.T0 
          LDD    D.T0+C.PFCY
          LPC    1777B
          STD    CYCLE
RNM       ENDIF 
OV.6PM    EQU    3R6PM
          LDC    OV.6PM 
          SHN    12 
          STD    D.T6 
          SHN    -6 
          SCN    77B
          STD    D.T7 
BEG6PM    EQU    C.PP6WA+1000B-L.PPHDR
          LDC    BEG6PM            BEG LOAD ADDRESS 
          RJM  R.OVL               LOAD 6PM 
          RJM  C.PP6WA+1000B+1     EXECUTE 6PM
CALL6PM   BSS    0
          IFGT   CALL6PM,BEG6PM,1 
          ERR    *** 6PM OVERWRITES CALL TO 6PM *** 
ACC       ENDIF 
MSG       IF     DEF,PFA5PA 
MESS16    DIS    ,*PFM SYS ERR, CODE XX*
MESS92    DIS    ,*PFA ABORT* 
MESS13    DIS    ,*PF CYCLE NO. = 000*
MESS93    DIS    ,*INCOMPLETE CYCLE ATTACHED* 
          RMT 
MSG       ENDIF 
  
ERR       ENDIF 
ERRFLG    SPACE  4,12 
ERRFLG    IF     DEF,ERRFLG$
**        ERRFLG
*         ------
* 
*         SUBROUTINE TO FETCH CONTROL POINT ERROR FLAG
* 
*         EXIT   (A-REG) = 0 IF NO ERROR
*                (A-REG) = -RC070 IF ERROR FLAG ON
* 
*         USES   D.T0 - D.T4
  
  
ERRFLG    ENM    X                 ENTRY / EXIT 
  
          LDD    D.CPAD      SEE IF CTL POINT ZERO... 
          ZJN  ERRFLGX
          LDK    W.CPSTAT 
          ADD    D.CPAD 
          CRD    D.T0 
          LDD    D.T0+C.CPEF
          ZJN  ERRFLGX
          LCN    RC070
          UJN  ERRFLGX
ERRFLG    ENDIF 
EXFDB     SPACE  4,12 
EXFDB     IF     DEF,EXFDB$ 
**        EXFDB 
*         ----- 
* 
*         SUBROUTINE TO EXTRACT PARAMETER FROM FDB
* 
*         ENTRY  (A-REG) = FDB PARAMETER CODE 
* 
*         EXIT   (A-REG) = -1 IF PARAMETER NOT FOUND
*                (A-REG) = INDEX INTO FDB IF PARAMETER FOUND
*                (BUF - BUF+4) = PARAMETER FROM FDB 
* 
*         USES   SCRATCH   TEMP 
* 
*         CALLS  FDBADR 
  
  
EXFDB30   LCN    1
  
EXFDB     ENM    X                 ENTRY / EXIT 
  
          STD    SCRATCH
          LDN    1
          STD    TEMP 
EXFDB10   BSS    0
*                                  (A=TEMP= THE OFFSET) 
          RJM  FDBADR 
          CRM    BUF,D.PPONE
          LDM    BUF+4
          ZJN  EXFDB30             IF END OF FDB
          LPN    77B               GET NUMERIC CODE 
          SBD  SCRATCH             CHECK VALUE
          ZJN  EXFDB20
          AOD    TEMP 
          UJK  EXFDB10
* 
EXFDB20   LDD    TEMP 
          UJK  EXFDBX              RETURN 
EXFDB     ENDIF 
FCOPY     SPACE  4,12 
FCOPY     IF     DEF,FCOPY$ 
**        FCOPY 
*         ----- 
* 
*         SUBROUTINE TO DO PP STORAGE MOVE (LOW TO HIGH)
* 
*         ENTRY  (A-REG) = NUMBER OF BYTES TO BE MOVED
*                (TEMP2) = TARGET ADDRESS 
*                (TEMP1) = SOURCE ADDRESS (GREATER THAN TEMP2)
* 
*         USES   D.Z0 
  
  
FCOPY     ENM    X                 ENTRY / EXIT 
  
          ZJN  FCOPYX 
          STD    D.Z0              SAVE NUMBER OF BYTES 
FCOPY10   BSS    0
          LDI    TEMP1
          STI    TEMP2
          AOD    TEMP1
          AOD    TEMP2
          SOD    D.Z0 
          NJN  FCOPY10
          UJN  FCOPYX 
FCOPY     ENDIF 
FDBADR    SPACE  4,12 
FDBADR    IF     DEF,FDBADR$
**        FDBADR
*         ------
* 
*         SUBROUTINE TO CALCULATE ABSOLUTE FDB ADDRESS
* 
*         ENTRY  FDB ADDRESS PRESET INTO FDBADRA BY INIT
*                A=OFFSET FROM FDB LOCATION.
* 
*         EXIT   (A-REG) = ABSOLUTE FDB ADDRESS 
* 
*         CALLS  R.TFL
*                ERR (CODE 16  /  -RC072) 
* 
*         IF CALLED AT CONTROL POINT ZERO, D.RA IS OF COURSE ZERO, AND
*         D.FL IS MACHINE SIZE. 
  
  
FDBADR    ENM    X                 ENTRY / EXIT 
  
          ADC    *-*               LOAD ADDRESS OF FDB
FDBADRA   EQU    *-1               (PRESET BY INIT) 
          ADDRA  OK=FDBADRX 
  
LOAD      IF     DEF,LOA
          LCN    RC014             *BAD LPF COMMUNICATION*
LOAD      ELSE
          LCN    RC072
LOAD      ENDIF 
  
          RJM    ERR
FDBADR    ENDIF 
FINDAUS   SPACE  4,12 
FINDAUS   IF     DEF,FINDAUS$ 
**        FINDAUS 
*         ------- 
* 
*         SUBROUTINE TO FIND PRU / RB FOR A SET MEMBER
* 
*         ENTRY  MSTORD = MST ORDINAL 
*                DAMORD = DAM ORDINAL 
*                TEMP = FIRST OR OVERFLOW WD PR PTR IN SECT1
* 
*         EXIT   (A) = PRU/RB 
*                (A) = 0 IF DDT ENTRY NOT FOUND 
* 
*         USES   D.Z1-D.TH1 
* 
*         CALLS  GETRBT 
  
FINDAUS   ENM    X
  
          LDM    SETATTR
          NJN  PBLIC               IF PUBLIC SET
          RJM  MSTADR 
          ADN    W.MSPFC
          CRD    RBTWRD 
          RJM    GETRBT 
          LDD    RBTWRD+5+C.RBTAUS
          UJN  FINDAUSX 
  
PBLIC     BSS    0
          LDN    P.DDT
          CRD    D.T0 
          LDD    D.T0+C.DDT 
          STM    DDT
          LDN    0
          STD    D.T7 
  
FINDAUS1  LDC    ** 
DDT       EQU    *-1
          SHN    3
          ADD    D.T7 
          ADN    1
          CRD    D.T0              SECOND WORD OF DDT ENTRY 
          LDK    LE.DDTF
          RAD    D.T7 
          LDD    D.T0+C.DDEST 
          NJN  FINDAUS2            NOT END OF FIXED SECTION OF DDT
          LDN    0
          UJK    FINDAUSX 
  
FINDAUS2  LDD    D.T0+C.DDMST 
          LMM    MSTORD 
          NJN  FINDAUS1 
          LDM    DAMORD            COMPARE DAM  ORDINAL 
          SHN    -S.RBTDRB
          SBD    D.T0+C.DDFRBR
          MJN  FINDAUS1 
          ADD    D.T0+C.DDFRBR
          SBD    D.T0+C.DDLRBR
          ZJN  FINDAUS3 
          PJN  FINDAUS1 
FINDAUS3  BSS    0
  
          LDN    P.RBR
          CRD    D.Z1 
FINDAUS5  LDD    D.Z1              GET RBR HEADER 
          SHN    12D
          ADD    D.Z2 
          CRD    D.Z3 
          ADN    1
          CRD    D.T5 
          LDN    2
          RAD    D.Z2              INCREMENT POINTER TO NEXT RBR HEADER 
          SHN    -12D 
          RAD    D.Z1 
          LDD    D.T5+C.RBREST
          SBD    D.T0+C.DDEST 
          NJN  FINDAUS5            IF EST ORDINAL DOES NOT MATCH
          LDD    D.T0+C.DDFRBR
          SHN    S.RBTDRB 
          LMM    DAMORD 
          NJN  MULTDEV             IF DAM ORDINAL DOES NOT MATCH
          LDD    D.Z3+4            PRU/RB 
          LJM  FINDAUSX 
  
MULTDEV   LDD    D.T5 
          SHN    -6+1              BIT TABLE LENGTH 
          ADC    3+77B             +HEADER(ROUNDED-UP)
          SHN    -6                /100B = NO OF PRUS FOR DAM 
          RAD    D.T0+C.DDFRBR
          UJK  FINDAUS5 
FINDAUS   ENDIF 
FINDID    SPACE  4,12 
FINDID    IF     DEF,FINDID$
**        FINDID
*         ------
* 
*         SUBROUTINE TO EXTRACT OWNER ID FROM FDB 
* 
*         EXIT   (OWNER - OWNER+4) = ID 
* 
*         USES   BUF - BUF+4   OWNER - OWNER+4
* 
*         CALLS  EXFDB
*                FCOPY
*                FDBADR 
* 
  
  
          IFANY  (CATALOG,EXTEND,RENAME),1
FINDID    RMT 
FINDID30  BSS    0
          LDN    0
          RJM  FDBADR 
          CRM    BUF,D.PPONE
          LDM    BUF+4
          LPN    74B
          SBN    50B
          ZJN  FINDIDX             RETURN IF RENAME AND OWNER=0 
          LDD    D.CPAD      SEE IF CTL POINT ZERO... 
          ZJN  FINDID40            IF SYSTEM REQUEST
          LDK    PUBLIC-SYSTEM
* 
FINDID40  BSS    0
          ADC    SYSTEM 
          STD    TEMP1
          LDC    OWNER
          STD    TEMP2
          LDN    5
          RJM  FCOPY               COPY ID
  
FINDID    ENM    X                 ENTRY / EXIT 
  
          LDN    IDC               IDENT KEYWORD CODE 
          RJM  EXFDB
          MJN  FINDID30            IF ID ERROR
* 
          LDN    0
          STD    TEMP 
FINDID20  BSS    0
          LDM    BUF,TEMP 
          RJM  BLANK
          STM    OWNER,TEMP 
          AOD    TEMP 
          SBN    5
          NJN  FINDID20 
          UJN  FINDIDX
          IFANY  (CATALOG,EXTEND,RENAME),1
FINDID    RMT 
FINDID    ENDIF 
FINDRBR   SPACE  4,12 
FINDRBR   IF     DEF,FINDRBR$ 
**        FINDRBR 
*         ------- 
* 
*         SUBROUTINE TO LOCATE RBR TABLE
* 
*         ENTRY  (D.T1) = RBR ORDINAL (C.RBTRBR FORMAT) 
* 
*         EXIT   (A-REG) = FWA OF RBR HEADER
* 
*         USES   D.T7 
  
  
FINDRBR   ENM    X                 ENTRY / EXIT 
  
          LDD    D.T1 
          SHN    -S.RBTRBR
          SHN    1
          STD    D.T7              RBR ORDINAL
          LDM    PRBT+C.RBRAD 
          LPN    77B
          SHN    12 
          ADM    PRBT+C.RBRAD+1 
          ADD    D.T7 
          UJK  FINDRBRX 
FINDRBR   ENDIF 
FMFO      SPACE  4,12 
FMFO      IF     DEF,FMFO$
**        FMFO
*         ----
* 
*         SUBROUTINE TO FIND MF ORDINAL 
*         ENTRY  RBTCIX HAS BEEN SET
*         EXIT   MFORD=MF ORDINAL 
*                MFOADDR=MF ORDINAL BYTE ADDRESS
*         CALLS  MSTADR 
*         USES   D.Z1-5 
* 
  
  
FMFO      ENM    X
          RJM  MSTADR 
          CRD    D.Z1 
          LDD    D.Z1+C.MSMFO 
          STM    MFORD
          ADC    CPFCIL            ADDR IS REL TO BEGINNING OF ENTRY
          ADD    RBTCIX 
          STD    MFOADDR
          UJN  FMFOX
FMFO      ENDIF 
FREEFNT   SPACE  4,12 
FREEFNT   IF     DEF,FREEFNT$ 
**        FREEFNT 
*         ------- 
* 
*         SET FREE BIT IN FNT IF NOT SET
* 
*         ENTRY  UFNT CONTAINS ADDRESS OF FNT 
* 
*         USES   D.Z1-D.Z5
* 
  
  
FREEFNT   ENM    X
  
          LDM    UFNT 
          ZJN  FREEFNTX            IF FNT NEVER SET BUSY
          ADN    W.FCS
          CRD    D.Z1 
          LDD    D.Z1+1+C.FSC 
          SCN    1
          ADN    1                 SET FNT NOT BUSY (SET COMPLETE BIT)
          STD    D.Z1+1+C.FSC 
          LDM    UFNT 
          ADN    W.FCS
          CWD    D.Z1 
          UJN  FREEFNTX 
FREEFNT   ENDIF 
GETRBT    SPACE  4,12 
GETRBT    IF     DEF,GETRBT$
**        GETRBT
*         ------
* 
*         SUBROUTINE TO GET NEXT RBT WORD PAIR
* 
*         ENTRY  (RBTWRD+C.RBTWPL) = ORDINAL OF NEXT RBT WORD PAIR
* 
*         EXIT   (RBTWRD - RBTWRD+9) = NEXT RBT WORD PAIR 
  
  
GETRBT    ENM    X                 ENTRY / EXIT 
  
          LDC    **          LOAD LWA OF MACHINE
 GETRBTA  EQU    *-1         (PRESET BY INIT) 
  
          SBD    RBTWRD+C.RBTWPL
          SHN    1
          CRD    RBTWRD      READ WORD PAIR 
          ADN    1
          CRD    RBTWRD+5 
  
          UJN    GETRBTX
GETRBT    ENDIF 
GETSATR   SPACE  4,12 
GETSATR   IF     DEF,GETSATR$ 
**        GETSATR 
*         ------- 
* 
*         SUBROUTINE TO GET SET ATTRIBUTES FROM MST 
* 
*         ENTRY  MSTORD = MST ORDINAL 
* 
*         EXIT   SETATTR = SET ATTRIBUTES 
* 
*         USES   D.T0-D.T4
  
GETSATR   ENM    X                 ENTRY / EXIT 
  
          RJM  MSTADR 
          CRD    D.T0 
          LDD    D.T0+C.PFMIL 
          SHN    -S.MSSYS 
          LPK    SYSSET+DPFSET+QSET+SCRSET
          STM    SETATTR
          UJN  GETSATRX 
GETSATR   ENDIF 
IOPFD     SPACE  4,12 
IOPFD     IF     DEF,IOPFD$ 
**        IOPFD 
*         ----- 
* 
*         SUBROUTINE TO INITIALIZE FOR READ/WRITE OF PFD PRU
* 
*         ENTRY  (A-REG) = O.RDP/O.WRP
* 
*         EXIT   (A-REG) = PP FWA OF 10-BYTE STACK REQUEST
* 
*         USES   ORDER   FLAGS   PSEUBF 
* 
*         CALLS  PFDIO
  
IOPFD     ENM    X                 ENTRY / EXIT 
  
          ADC    4000B             MAKE IT DIRECT 
          STM    ORDER
          LDC    1600B             NO FNT-FET,EXACT REWRITE 
          STM    FLAGS
          LDC    SECT1
          STM    PSEUBF 
          RJM  MSTADR 
          ADN    W.MSPTR
          CRD    D.T0+C.MSEST-5    GET EST ORDINAL IN D.T1
          LDD    POINT+2
          STD    D.T2              PRU
          LDD    POINT
          STW    RBTWRD+C.RBTWPL
          RJM  GETRBT 
          LDM    RBTWRD+2,POINT+1 
          STD    D.T0              RB NUMBER
          LDN    D.T0 
          RJM  PFDIO
          LDN    STACKRE1 
          UJK  IOPFDX 
IOPFD     ENDIF 
JSTMOD    SPACE  4,12 
JSTMOD    IF     DEF,JSTMOD$
**        JSTMOD
*         ------
* 
*         SUBROUTINE TO CHECK IF JOB NEVER SWAPPED OUT
*         AND TO DELINK FROM QUEUE IF SO
* 
*         ENTRY  (SCHED) = HIGH ORDER THREE SCHEDULER BITS
* 
*         THESE BITS ARE USED TO COMMUNICATE THAT 1SO WAS 
*         UNABLE TO SWAP OUT THE JOB, THEREFORE, THE JOB
*         NEEDS TO BE DELINKED
* 
*         CALLS  DELAY
*                APFADR 
*                R.RCH
*                R.DCH
*                APFLAG 
  
  
          IFANY  (ATTACH,LOA,CATALOG),1 
JSTMOD    RMT 
JSTMOD    ENM    X                 ENTRY / EXIT 
  
          LDD    D.CPAD      SEE IF CTL POINT ZERO... 
          ZJN  JSTMODX
          LDM    SCHED
          SHN    17-S.EVJST+36
          PJN  JSTMODX
* 
JSTMOD10  BSS    0
          LDN    CH.APF 
          RJM  R.RCH
* 
JSTMOD20  BSS    0
          RJM  APFADR 
          CRD    D.Z1 
          ADN    1
          CRD    D.T0 
          LDD    D.Z1+C.PFQ-1 
          LPN    77B
          ADD    D.Z1+C.PFQ 
          ZJN    JSTMODX
          LDD    D.T0+C.PFLAG      GET APF FLAG 
          LPN    IBIT 
          ZJN  JSTMOD30 
          LDN    CH.APF 
          RJM  R.DCH
          UJN  JSTMOD10 
* 
JSTMOD30  BSS    0
          LDK    IBIT              IF NOT SET,SET IT
          RAD    D.T0+C.PFLAG 
          RJM  APFADR 
          ADN    1
          CWD    D.T0 
          LDN    CH.APF 
          RJM  R.DCH
          LDD    CPTFLGS
          SCK    APFF 
          ADK    APFF              REFLECT SETTING OF APF FLAG
          STD    CPTFLGS
          LDN    CH.SCH 
          RJM  R.RCH
          LDD    D.CPAD 
          ADK    W.CPSCH
          CRD    D.T0 
          LDD    D.T0+C.CPJDA 
          LPN    77B
          SHN    12 
          ADD    D.T1+C.CPJDA 
          ADN    W.JDMGR           (A)=JOB DES MGR WORD ADDR
          CRD    D.Z1 
          LDD    D.Z1+C.JDJST 
          LPC    777B              CLEAR UPPER 3 BITS 
          STD    D.Z1+C.JDJST 
          LDD    D.T0+C.CPJDA 
          LPN    77B
          SHN    12 
          ADD    D.T1+C.CPJDA 
          ADN    W.JDMGR
          CWD    D.Z1 
          SBN    W.JDMGR-W.JDLINK 
          CRD    D.T0 
          STD    D.FNT+1           STORE THIS JOBS JOB DESR ADDR
          SHN    -12
          STD    D.FNT
          LDD    D.T0+C.JDLINK
          LPN    77B
          STD    TEMP 
          LDD    D.T0+C.JDLINK+1
          STD    TEMP1
          ADD    TEMP 
          NJN  JSTMOD40 
          LJM  JSTMOD50 
  
JSTMOD40  BSS    0
          LDD    D.T0+C.JDLINK
          LPN    37B
          SHN    12 
          ADD    D.T0+C.JDLINK+1
          CRD    D.T0 
          STD    D.FNT+3
          SHN    -12
          STD    D.FNT+2
          LDD    D.T0+C.JDLINK+1
          SBD    D.FNT+1
          NJN  JSTMOD40 
          LDD    D.T0+C.JDLINK
          LMD    D.FNT
          LPN    77B
          NJN  JSTMOD40 
          LDD    D.T0+C.JDLINK
          SCN    77B
          ADD    TEMP 
          STD    D.T0+C.JDLINK     UPDATE LINK POINTING TO THIS JOB 
          LDD    TEMP1
          STD    D.T0+C.JDLINK+1
          LDD    D.FNT+2
          LPN    77B
          SHN    12 
          ADD    D.FNT+3
          CWD    D.T0 
          RJM  APFADR 
          CRD    D.T0 
          LDD    D.T0+C.PFQ-1 
          SHN    12 
          PJN  JSTMOD50 
          LDD    D.T0+C.PFQ-1 
          SCN    77B
          STD    D.T0+C.PFQ-1 
          LDN    0
          STD    D.T0+C.PFQ 
          RJM  APFADR 
          CWD    D.T0 
JSTMOD50  BSS    0
          LDN    CH.SCH 
          RJM  R.DCH
          RJM  APFLAG 
          LJM  JSTMODX
          IFANY  (ATTACH,LOA,CATALOG),1 
JSTMOD    RMT 
JSTMOD    ENDIF 
MATCH     SPACE  4,12 
MATCH     IF     DEF,MATCH$ 
**        MATCH 
*         ----- 
* 
*         SUBROUTINE TO COMPARE CONTENTS IN 
*         TWO EQUAL-LENGTH BUFFER.
* 
*         ENTRY  (A) = NO. OF BYTES TO COMPARE
*                (TEMP1) = FWA OF FIRST BUFFER
*                (TEMP2) = FWA OF SECOND BUFFER 
* 
*         EXIT   (A) = 0 IF GOOD COMPARE
*                (A) =-1 IF BAD  COMPARE
  
MATCH1    LCN    1
  
MATCH     ENM    X                 ENTRY/EXIT 
  
          STD    TEMP 
MATCH2    LDI    TEMP1
          SBI    TEMP2
          NJN  MATCH1 
          AOD    TEMP1
          AOD    TEMP2
          SOD    TEMP 
          NJN  MATCH2 
          UJN  MATCHX 
MATCH     ENDIF 
MFPCHK    SPACE  4,12 
MFPCHK    IF     DEF,MFPCHK$
  
**        MFPCHK
* 
*         SUBROUTINE TO CHECK IF BIT IS SET IN PFC I/L WORD 
*         ENTRY  (A) = BIT TO CHECK 
*                RBTCIX HAS BEEN SET
*                MFORD HAS BEEN SET 
*                SECT1 CONTAINS PFC ENTRY 
*         EXIT   (A) = 0  BIT IS NOT SET
*                (A) = 1  BIT IS SET
*         USES   D.Z1 
* 
  
MFPCHK    ENM    X
          STM    BITMSK            MODIFY INSTRUCTION 
          LDC    SECT1+CPFCIL 
          IF     DEF,EXTEND,1 
          ADM    ORBTCIX
          IF     -DEF,EXTEND,1
          ADD    RBTCIX 
          STM    BYTEADR
          LDN    1
          STD    D.Z1              START WITH MF1 BYTE
MFPCHK1   LDD    D.Z1 
          SBM    MFORD             DO NOT CHECK HOST MF BYTE
          ZJN  MFPCHK2
          LDM    0,D.Z1            LOAD MF PFC I/L BYTE 
BYTEADR   EQU    *-1
          LPC    0
BITMSK    EQU    *-1
          ZJN  MFPCHK2             JUMP IF BIT NOT SET
          LDN    5
          STD    D.Z1 
MFPCHK2   AOD    D.Z1 
          SBN    5
          MJN  MFPCHK1
          UJN  MFPCHKX
MFPCHK    ENDIF 
MULT5     SPACE  4,12 
MULT5     IF     DEF,MULT5$ 
**        MULT5 
*         ----- 
* 
*         SUBROUTINE TO MULTIPLY BY 5 
* 
*         ENTRY  (A-REG) = NUMBER 
* 
*         EXIT   (A-REG) = NUMBER*5 
* 
*         USES   REMAIN 
  
  
MULT5     ENM    X                 ENTRY / EXIT 
  
          STD    REMAIN 
          SHN    2           *4 
          ADD    REMAIN      *5 
          UJN  MULT5X 
MULT5     ENDIF 
PFDIO     SPACE  4,12 
PFDIO     IF     DEF,PFDIO$ 
**        PFDIO 
*         ----- 
* 
*         SUBROUTINE TO SET UP STACK REQUEST FOR READ/WRITE OF ONE PRU
* 
*         ENTRY  (A-REG) = POINTER TO RBTA/RBTO/PRU 
*                                     OR
*                          0/FSTADR/PRU 
*                (ORDER) = READ/WRITE ORDER CODE
*                (FLAGS) = FLAGS
*                (PSEUBF) = ADDRESS OF PP BUFFER
* 
*         EXIT   STACK REQUEST IS SET UP
* 
*         USES   TEMP 
  
  
PFDIO     ENM    X                 ENTRY / EXIT 
  
          STD    TEMP 
          LDI    TEMP              RBTA OR ZERO 
          STD    STACKRE1+C.STPRBA
          AOD    TEMP 
          LDI    TEMP              RBTO OR FST ADDRESS
          STD    STACKRE1+C.STPRBN
          AOD    TEMP 
          LDI    TEMP              PRU
          STD    STACKRE1+C.STPPRU
          LDM    ORDER             STORE ORDER CODE 
          STD    STACKRE1+C.STO 
          LDM    FLAGS
          STD    STACKRE2+C.STFB
          LDM    PSEUBF 
          STD    STACKRE2+C.STPFW  BUFFER FWA 
          ADC    BUFLNG-1          CALCULATE LWA OF BUFFER
          STD    STACKRE2+C.STPLW 
          UJK  PFDIOX 
PFDIO     ENDIF 
RBTADR    SPACE  4,12 
RBTADR    IF     DEF,RBTADR$
          IF     DEF,ATTACH,1 
SEG8PAX   RMT 
**        RBTADR
**        ------
* 
*         SUBROUTINE TO COMPUTE RBT WD PR ADDRESS 
* 
*         ENTRY  PRBT+C.CMLWA CONTAINS LWA+1/100B OF CM 
*                D.T3 CONTAINS RBT ORDINAL
* 
*         EXIT   (A-REG) CONTAINS RBT WD PR ADDRESS 
* 
  
  
RBTADR    ENM    X
          LDM    PRBT+C.CMLWA      LWA+1/100B 
          SHN    5                 LWA+1/2
          SBD    D.T3              SUBTRACT RBT ORD 
          SHN    1                 LWA+1 - RBTORD*2 
          UJN  RBTADRX
          IF     DEF,ATTACH,1 
          RMT 
RBTADR    ENDIF 
RDRBTC    SPACE  4,12 
RDRBTC    IF     DEF,RDRBTC$
**        RDRBTC
*         ------
* 
*         SUBROUTINE TO READ RBTC NON-STOP
* 
*         ENTRY  (COUNT) = SIZE OF RBTC ENTRY SLOT DESIRED
* 
*         EXIT   (A-REG) = 0 IF RBTC EOI REACHED
*                         (IF REMAIN " 0 DID FIND PRU IN SECTION OF PFC 
*                         RESERVED FOR I/O QUEUES,REMAIN=0 IS REAL EOI) 
*                (A-REG) .NE. 0  IF PRU IN SECT1 BUFFER 
*                (RBTC - RBTC+2) = RBTA/RBTO/PRU
* 
*         CALLS  R.RAFL 
*                PFDIO
*                R.EREQS
*                R.STB
*                BACKSP 
  
  
RDRBTC    ENM    X                 ENTRY / EXIT 
  
          RJM  R.TAFL 
          LDN    P.ZERO 
          CRM    RBTC,D.PPONE 
          LDK    O.RDP+STIL        INTERLOCK ORDER CODE 
          STM    ORDER
          LDC    400B              SET NO FET BIT 
          STM    FLAGS
          LDC    SECT1
          STM    PSEUBF 
          LDN    0
          STM    REQTAB 
          LDC    REQTAB 
          RJM  PFDIO
          LDN    STACKRE1 
          STD    D.T0 
RRWP2     LDD    D.PPMES1 
          STD    STACKRE2+C.STPMS 
          RJM  R.EREQS             ENTER REQUEST IN STACK 
RWPP2     LDN    RWDELAY/2         DELAY RWDELAY MICROSECONDS 
          SBN    1
          NJN  *-1
RWPL2     LDD    D.PPMES1 
          ADN    W.RWPPCW 
RWPL12    CRD    D.T3              READ CONTROL WORD
          LDD    D.T3+C.RWPPCF
          SBN    3
          ZJN  RWPIO2              IF TRANSMISSION READY
          PJN  EOIJP               IF END OF TRANSMISSION 
          ADN    2
          MJN  RWPP2               IF STILL WAITING FOR CHANNEL 
          NJN  RWPL2               IF WAITING FOR TRANSMISSION
          LDC    RWPSTBL1          STORE CHANNEL
          RJM  R.STB
          AOD    D.T3+C.RWPPCF     SET CONTROL FLAG TO 2
          UJN  RWPWF2 
* 
RWPIO2    LDD    D.T3+C.RWPPWC
RWPIOW2   IJM    *,** 
RWPIOT2   IAM    SECT1,** 
          LDM    SECT1+4
RDRBTM1   LPN    CEF               ** 1QF MODIFIES BYTE TO LPN QFLG+CEF 
RDRBTM2   LMN    0                 ** 1QF MODIFIES BYTE TO LMN QFLG+CEF 
          ZJN  FINISH22 
          LDN    0
          STD    D.T3+C.RWPPWT
          LDN    2
          STD    D.T3+C.RWPPCF
RWPWF2    LDD    D.PPMES1 
          ADN    W.RWPPCW 
          CWD    D.T3 
          UJK  RWPL2
* 
EOIJP     LDN    0
          STD    REMAIN 
          LJM  WAIT12 
* 
FINISH22  LDN    1
          STD    REMAIN 
DROP22    LDN    2
          STD    D.T3+C.RWPPCF
          LDC    500B 
          STD    D.T3+C.RWPPWT
          LDD    D.PPMES1 
          ADN    W.RWPPCW 
          CWD    D.T3 
WAIT1     LDD    D.PPMES1 
          ADN    W.RWPPCW 
          CRD    D.T3 
          LDD    D.T3+C.RWPPCF
          SBN    1
          ZJN  DROP22 
          SBN    3
          NJN  WAIT1
WAIT12    AOD    D.T3+C.RWPPCF     SET TO 5 
          LDD    D.PPMES1 
          ADN    W.RWPPCW 
          CWD    D.T3 
RDRBTC4   CRD    D.T3 
          LDD    D.T3 
          ZJN  RDRBTC6
          LDN    25 
RDRBTC5   SBN    1
          NJN  RDRBTC5
          LDD    D.PPMES1 
          ADN    W.RWPPCW 
          UJN  RDRBTC4
* 
RDRBTC6   RJM  R.RAFL 
          LDD    REMAIN 
          NJN  RDRBTC1
          LJM  RDRBTCX
* 
RDRBTC3   LDD    D.T0+C.FLRBWP
          STM    RBTC 
          LDD    D.T0+C.FLRBEB
          STM    RBTC+1 
          LDD    D.T0+C.FLPRU 
          STM    RBTC+2 
          RJM  CHKIOQ              CHECK IF PRU IS IN RES. SECTION
RDRBTC7   LJM  RDRBTCX
* 
RDRBTC1   RJM  BACKSP 
          LDD    D.PPMES1 
          ADN    4
          CRD    D.T0 
          UJN  RDRBTC3
* 
* 
* 
RWPSTBL1  VFD    12/D.T3+C.RWPPCC,12/RWPIOW2,12/RWPIOT2 
          DATA   0
CHKIOQ    SPACE  4,15 
**        CHKIOQ - TEST IF EMPTY PRU FOUND IS IN THE SECTION OF 
*         THE PFC RESERVED FOR I/O QUEUES 
*         ENTRY - RBTC - RBTC+2 = RBTA, RBTO, PRU 
*                FST1 WITH PFC POSITION IN PPMES5 
*         EXIT  - A = 0 IF PRU IN RESERVED SECTION (BE USED ONLY BY 1QF)
*                 A " 0 IF PRU IN MAIN SECTION OF PFC,
* 
CHKIOQ    ENM    X
          LDD    D.PPMES1 
          ADN    4
          CRD    D.T0              OBTAIN POINTER TO FIRST RBT
          LDD    D.T0+C.FFRBA 
          STD    RBTWRD+C.RBTWPL
          RJM  GETRBT              FIRST WORD PAIR
          LDK    N.PFCIO           NUMBER OF RESERVED PRUS
          ADM    RBTC+2 
          SBD    RBTWRD+C.RBTPRU   MINUS FREE PRUS IN CURRENT RB
          MJN  CHKIOQX             OUTSIDE OF RESERVED AREA 
          STD    D.T6              FREE PRUS STILL NEEDED 
          LDD    RBTWRD+5+C.RBTAUS
          STD    D.T5 
          LDM    RBTC 
          STD    RBTWRD+C.RBTWPL
          RJM  GETRBT              CURRENT WORD PAIR
          LDM    RBTC+1            RBTO 
          STD    D.T7 
CHK1      AOD    D.T7 
          SBN    8
          ZJN  CHK4                IF NEED NEXT WORD PAIR 
CHK2      LDM    RBTWRD+2,D.T7
          ZJN  CHK1                IF NO RB 
          LDD    D.T6 
          SBD    D.T5 
          STD    D.T6              REDUCE NEEDED COUNT
          PJN  CHK1                IF STILL NEED MORE 
CHK3      UJK  CHKIOQX
          SPACE  1
CHK4      LDD    RBTWRD+C.RBTWPL
          ZJN  CHK3                IF REACHED END OF CHAIN
          RJM  GETRBT 
          LDN    0
          STD    D.T7 
          UJN  CHK2 
RDRBTC    ENDIF 
READCAT   SPACE  4,12 
READCAT   IF     DEF,READCAT$ 
**        READCAT 
*         ------- 
* 
*         SUBROUTINE TO READ ONE PRU OF RBTC TO PP BUFFER 
* 
*         USES   SCRATCH   D.FNT - D.FNT+4
*                TEMP1   REQTAB 
*                FLAGS   PSEUBF 
* 
*         EXIT   (A)= 0, OPERATION ALRIGHT
*                (A) = -VE, DEVICE I/L  IS BROKEN, AND
*                IF HAPPENS 3 CONSECUTIVE TIMES, ABORTS 
* 
*         CALLS  PSDFNT 
*                READPRU
  
  
READCAT   ENM    X                 ENTRY / EXIT 
  
          LDN    0
          STD    SCRATCH
          RJM  PSDFNT              0RBTC FST IN D.FNT-D.FNT+9 
          LDM    RBTCPT 
          STD    D.FNT+C.FLRBWP    INSERT POINTER 
          LDM    RBTCPT+1 
          STD    D.FNT+C.FLRBEB 
          LDM    RBTCPT+2 
          STD    D.FNT+C.FLPRU
          LDN    2
          STD    TEMP1
* 
          LDD    D.PPMES1 
          ADN    4
          STM    REQTAB+1 
          CWM    D.FNT,TEMP1
          LDN    0
          STM    REQTAB 
          LDC    SECT1
          STM    PSEUBF 
          IF     DEF,ATTACH,1 
          LDK    O.RDP+STIL        INTERLOCKED READ INTO PP ORDER CODE
          RJM  READPRU             READ PRU TO SECT1
          ZJN  READCAT2            IF ALRIGHT 
          LCN    1
* 
READCAT2  LJM  READCATX            EXIT 
READCAT   ENDIF 
READLBL   SPACE  4,12 
READLBL   IF     DEF,READLBL$ 
RML       RMT 
**        RML - READ MASTER LABEL 
* 
*         SUBROUTINE TO READ THE MASTER LABEL TO SECT1 BUFFER 
*         AND STORE PRIVATE SET UNIVERSAL PASSWORD AT *UNIV*
*         OR STORE PRIVATE SET PUBLIC PASSWORD AT *IDPERM*. 
* 
*         ENTRY  (MSTORD) = MST ORDINAL OF SET
* 
*         EXIT   (UNIV)   = PRIVATE SET UNIVERSAL PASSWORD(FOR PFA) 
*                  OR 
*                (IDPERM) = PRIVATE SET PUBLIC PASSWORD(FOR PFC)
* 
*         USES   D.Z1 - D.Z5,D.T0 - D.T4,SECT1,STRI,TEMP
* 
*         CALLS  FLB,MSTADR,DROPIL
* 
  
  
 RML      SUBR                     ENTRY/EXIT 
          RJM    MSTADR            GET MST ADDR 
          ADN    W.MSVSN
          CRD    D.Z1              READ MST WORD 0
          ADN    W.MSPTR-W.MSVSN
          CRD    D.T0              READ MST WORD 2
  
          LDD    D.T0+C.MSEST 
          STM    SRQ+C.STPRBN      MASTER EST 
          LDC    SECT1
          STM    SRQ2+C.STPFW      BUFFER FWA 
          LDN    STIL 
          STM    FLB0              SET DEVICE I/L BIT 
          STM    STRI              SET INTERNAL SR I/L FLAG 
  
          RJM    FLB               READ MASTER LABEL
          ZJN    RML04             IF LABEL FOUND 
          MJN    RML03             IF LABEL NOT FOUND 
          LMN    LOSTIL 
          NJN    RML01             IF NOT BROKEN CONNECT
*         BROKEN CONNECT
          LDN    0
          STM    STRI 
 RML01    LDC    MESS14            * I/O ERROR* 
 RML02    RJM    R.DFM
          RJM    DDI               DROP DEVICE INTERLOCK
          LDN    M.ABORT           CONTROL POINT ABORT
          RJM    R.MTR
          LJM    R.IDLE 
  
 RML03    LDC    MESS17            *LABEL NOT FOUND*
          UJN    RML02             TO ISSUE DAYFILE MESSAGE 
  
 RML04    LDN    0
          STD    TEMP 
 RML05    BSS    0                 MOVE PASSWORD
 ATT      IFANY  (ATTACH) 
          LDM    SECT1+W.LBDUP*5,TEMP 
          STM    UNIV,TEMP
 ATT      ENDIF 
 CAT      IFANY  (CATALOG)
          LDM    SECT1+W.LBDPI*5,TEMP 
          STM    IDPERM,TEMP
 CAT      ENDIF 
          AOD    TEMP 
          SBN    5
          MJN    RML05             IF PASSWORD MOVE NOT COMPLETE
ATT       IFANY  (ATTACH) 
* 
*         MODIFY ATT19 INSTRUCTION TO LOAD UP= VALUE FROM LABEL.
* 
          LDM    UNIV+4 
          LPN    17B
          LMC    .LDN.
          STM    ATT19             *MODIFY INSTRUCTION* 
          LDM    UNIV+4 
          SCK    77B
          STM    UNIV+4            CLEAR UP= BITS IN UNIVERSAL PASSWORD 
ATT       ENDIF 
          RJM    DDI               DROP DEVICE INTERLOCK
          LJM    RMLX              EXIT BACK TO CALLING OVERLAY 
DDI       SPACE  4,12 
**        DDI -  DROP DEVICE INTERLOCK. 
* 
*         ISSUE A DUMMY STACK REQUEST TO RELEASE THE DEVICE INTERLOCK.
* 
*         ENTRY  (STRI) = NONZERO IF DEVICE INTERLOCK TO BE DROPPED.
*                (SRQ - SRQ2+4) = STACK REQUEST.
* 
*         EXIT   DEVICE INTERLOCK RELEASED. 
* 
*         USES   STRI,SRQ - SRQ+4,SRQ2 - SRQ2+4.
* 
*         CALLS  R.READP. 
* 
 DDI      SUBR                     ENTRY/EXIT 
          LDM    STRI              INTERNAL DEVICE INTERLOCK FLAG 
          ZJN    DDIX              IF DEVICE INTERLOCK ALREADY DROPPED
          LDM    SRQ+C.STO
          SCN    77B
          ADN    O.RDP
          STM    SRQ+C.STO         USE NON-INTERLOCKED READ ORDER CODE
          LDM    SRQ2+C.STPFW 
          STM    SRQ2+C.STPLW      SET PP BUFFER LWA EQUAL FWA
          LDC    SRQ               ISSUE STACK REQUEST TO READ NOTHING
          RJM    R.READP
          LDN    0
          STM    STRI              CLEAR INTERNAL DEVICE INTERLOCK FLAG 
          UJN    DDIX              TO EXIT
RML       RMT 
READLBL   ENDIF 
READPFD   SPACE  4,12 
READPFD   IF     DEF,READPFD$ 
**        READPFD 
*         ------- 
* 
*         SUBROUTINE TO READ PRU FROM SUBDIRECTORY
* 
*         ENTRY  (POINT - POINT+3) = RBT POINTER
* 
*         EXIT   (A)= 0, OPERATION ALRIGHT
*                (A) = -VE, DEVICE I/L  IS BROKEN, AND
*                IF HAPPENS 3 CONSECUTIVE TIMES, ABORTS 
* 
*         CALLS  IOPFD
*                R.READP
  
  
READPFD   ENM    X                 ENTRY / EXIT 
  
          LDC    O.RDP+STIL        INTERLOCK ORDER CODE 
          RJM  IOPFD
          RJM  R.READP             READ PRU 
          RJM  CHKSTS 
          UJK  READPFDX 
READPFD   ENDIF 
READPRU   SPACE  4,12 
READPRU   IF     DEF,READPRU$ 
**        READPRU 
*         ------- 
* 
*         SUBROUTINE TO READ A PRU FROM A FILE
* 
*         ENTRY  (REQTAB - REQTAB+2) = BYTES 0,1,2 FOR STACK REQUEST
*                (JTEMP3) = ORDINAL OF FIRST RBT WORD PAIR
*                (PSEUBF) = FWA OF PP BUFFER
*                (A) = ORDER CODE (PFA ONLY)
* 
*         EXIT   (A)= 0, OPERATION ALRIGHT
*                (A) = -VE, DEVICE I/L  IS BROKEN, AND
*                IF HAPPENS 3 CONSECUTIVE TIMES, ABORTS 
  
*         USES   ORDER   FLAGS
* 
*         CALLS  PFDIO
*                R.READP
  
  
READPRU   ENM    X                 ENTRY / EXIT 
  
          IF     -DEF,ATTACH,1
          LDK    O.RDP+STIL        INTERLOCK ORDER CODE 
          STM    ORDER
          LDC    0400B             *NO FET* FLAG
          STM    FLAGS
          LDC    REQTAB 
          RJM  PFDIO               BUILD READ STACK REQUEST 
          LDN    STACKRE1 
          RJM  R.READP             READ A PRU TO BUFFER 
          RJM  CHKSTS 
          UJK  READPRUX 
READPRU   ENDIF 
RELAPF    SPACE  4,12 
RELAPF    IF     DEF,RELAPF$
**        RELAPF
*         ------
* 
*         SUBROUTINE TO RELEASE RESERVED APF EMPTY SLOT 
* 
*         ENTRY  APFO CONTAINS ORDINAL OF APF SLOT TO BE RELEASED 
*                RAPFF INDICATES IF A SLOT HAD BEEN RESERVED
* 
*         EXIT   APF RESERVED SLOT RELEASED 
* 
*         CALLS  APFADR 
  
  
RELAPF    ENM    X                 ENTRY/EXIT 
  
          LDD    CPTFLGS
          LPK    RAPFF             CHECK IF APF RESERVED FLAG SET 
          ZJN  RELAPFX             EXIT IF NOT
  
          LDN    P.ZERO 
          CRD    D.T0 
          RJM  APFADR 
          ADN    1
          CWD    D.T0              CLEAR RSVAPF FLAG IN RESERVED SLOT 
          LDD    CPTFLGS
          SCK    RAPFF             CLEAR APF SLOT RESERVED FLAG 
          STD    CPTFLGS
          UJN  RELAPFX
RELAPF    ENDIF 
RELCHN    SPACE  4,12 
RELCHN    IF     DEF,RELCHN$
          IF     DEF,ATTACH,1 
SEG8PAR   RMT 
**        RELCHN
*         ------
* 
*         SUBROUTINE TO RELEASE CHAIN 
* 
*         ENTRY  FRBT CONTAINS FIRST WD PR ORDINAL
* 
* 
*         EXIT   CHAIN RELEASED 
* 
*         CALLS  GETRBT,RBTADR,R.EREQS
* 
*         USES   D.T0-D.T4,D.Z1-D.Z5,RBTWRD-RBTWRD+9
  
  
RELCHN    ENM    X
          LDM    FRBT              FIRST RBT WD PR ORDINAL
          ZJN  RELCHNX             NO CHAIN TO RELEASE
          STM    RELREQ            STORE FRBT ORD FOR CHAIN EVICT 
          STD    RBTWRD+C.RBTWPL
          STD    D.T3 
          RJM  GETRBT              READ RBT WORD PAIR INTO RBTWRD 
          LDD    RBTWRD+C.RBTDRB
          LPN    7B 
          STD    D.T0              RB BYTE OFFSET 
          LDN    8D                MAX NUM OF RBS IN A WORD PAIR
          SBD    D.T0 
          STD    D.T1              NO OF RBS TO ZERO
RELCHN1   LDN    0
          STM    RBTWRD+2,D.T0     ZERO RB IN BYTE POINTED TO BY D.T0 
          SOD    D.T1              DECREMENT NO OF BYTES TO ZERO
          ZJN  RELCHN2             NO MORE BYTES TO ZERO
          AOD    D.T0              ADVANCE POINTER TO NEXT BYTE 
          UJN  RELCHN1
  
RELCHN2   LDN    2                 NO OF WORDS TO WRITE BACK TO CM
          STD    D.T2 
          RJM  RBTADR              GET RBT WD PR ADDR 
          CWM    RBTWRD,D.T2       WRITE EMPTY RBT WD PR BACK TO CM 
          LDN    P.ZERO            LOAD ADDR OF CM ZERO WORD
          CRD    RBTWRD+1 
          CRD    RBTWRD+5 
RELCHN3   LDD    RBTWRD+C.RBTWPL
          ZJN  RELCHN4             IF NO MORE WD PRS IN RBT CHAIN 
          STD    D.T3 
          RJM  RBTADR              GET RBT WD PR ADDR 
          CRD    D.Z1              READ FIRST WD OF RBT WD PR 
          LDD    D.Z1+C.RBTWPL     NEXT RBT WD PR ORDINAL 
          STD    RBTWRD+C.RBTWPL   STORE FOR WRITING RBTWRD BACK TO CM
          RJM  RBTADR              GET RBT WD PR ADDRESS
          CWM    RBTWRD,D.T2       WRITE EMPTY RBT WD PR BACK TO CM 
          UJN  RELCHN3
  
RELCHN4   LDC    RELREQ            ADDR OF STACK REQUEST
          STD    D.T0 
          RJM  R.EREQS             ISSUE STACK REQUEST TO EVICT CHAIN 
          UJK  RELCHNX
  
STFETP    BIT    S.STFETP+S.STF    BIT S.STFETP SHIFTED S.STF BITS
STFNTP    BIT    S.STFNTP+S.STF    BIT S.STFNTP SHIFTED S.STF BITS
RELREQ    VFD    36/0,12/O.RCHN,12/1     STACK REQUEST TO EVICT CHAIN 
          VFD    36/0,12/STFETP+STFNTP,12/0 
          IF     DEF,ATTACH,1 
SEG8PAR   RMT 
RELCHN    ENDIF 
RPRU      SPACE  4,12 
RPRU      IF     DEF,RPRU$
**        RPRU
*         ----
*         IF THE READ IS SUCCESSFUL 
*         SUBROUTINE TO READ A PRU AND CHECK
* 
* 
*         ENTRY  NONE 
* 
*         EXIT   IF RECEIVES 3 CONSECUTIVE BROKEN 
*                CONNECTS, ABORTS JOB AND ISSUES
*                *ERROR IN PFD/PFC READ/WRITE*
*                OTHERWISE, A=0, SUCCESSFUL COMPLETION
* 
*         CALLS  READPRU, CHKSTS, BACKSP, DROPIL, ERR 
  
RPRU      ENM    X                 ENTRY/EXIT 
  
          LDM    REQTAB+1          FST ADDRESS
          CRM    RPRUFS,D.PPONE    SAVE CUR. POSITION FOR BROKEN I/L
RPRU1     RJM  READPRU
          ZJN  RPRUX               READ IS ALRIGHT
          LDM    REQTAB+1          RESET POSITION IN FST
          CWM    RPRUFS,D.PPONE 
          UJN  RPRU1               GO TRY AGAIN 
  
          IF     -DEF,RPRUFS,1
RPRUFS    BSSZ   5
RPRU      ENDIF 
SRCHCP    SPACE  4,12 
SRCHCP    IF     DEF,SRCHCP$
**        SRCHCP
*         ------
* 
*         SUBROUTINE TO SEARCH FOR FNT-S AT A CERTAIN CONTROL POINT 
* 
*         ENTRY  (A-REG) = ADDRESS OF NAME TO MATCH 
* 
*         EXIT   (A-REG) = 0 IF ENTRY FOUND 
*                (A-REG) = 1 IF ENTRY NOT FOUND 
*                (D.T2 ) = CM ADDRESS IF FILE FOUND AT C. P. ZERO 
* 
*         CALLS  SRCHFNT (ALSO TRANSFERS DIRECTLY INTO SRCHFNT) 
  
  
SRCHCP    ENM    X                 ENTRY / EXIT 
  
          RJM  SRCHFNT
          NJN  SRCHCPX             LOCAL FILE NOT FOUND 
          LDD    D.CPAD 
          SHN    -7                FORM C.P. NUMBER 
          LMD    D.FNT+C.FCPNUM 
          LPK    L.CPNUM
          ZJN  SRCHCPX             FILE FOUND 
  
          LDD    D.FNT+C.FCPNUM    CHECK FOR C. P. ZERO 
          LPK    L.CPNUM
          NJN  GETNEXT
          LDD    D.T0 
          STD    D.T2              SAVE FOR END OF SEARCH 
          UJN  GETNEXT             CONTINUE SEARCH
SRCHCP    ENDIF 
SRCHFNT   SPACE  4,12 
SRCHFNT   IF     DEF,SRCHFNT$ 
**        SRCHFNT 
*         ------- 
* 
*         SUBROUTINE TO SEARCH FNT FOR A GIVEN FILE 
* 
*         ENTRY  (A-REG) = ADDRESS OF NAME TO MATCH 
* 
*         EXIT   (A-REG) = 1 IF ENTRY NOT FOUND 
*                (A-REG) = 0 IF ENTRY FOUND 
*                (D.FNT - D.FNT+4) = FNT WORD 
*                (D.T0) = CM ADDRESS OF FNT ENTRY 
* 
*         USES   D.Z1   D.T0 - D.T4 
  
*         CALLS  COMPLFN
  
  
 SRCHFNT1 LDN    1           (A)=1,FILE NOT FOUND 
  
SRCHFNT   ENM    X                 ENTRY / EXIT 
  
          STD    D.Z1        SAVE ADDRESS OF NAME 
          LDN    P.FNT
          CRD    D.T0        READ POINTER TO FNT
          LDN    0                 CLEAR C. P. ZERO FNT ADDRESS OF FILE 
          STD    D.T2              WITH THE SAME NAME (IF ONE EXISTS) 
          LDD    D.T0        READ FIRST FNT 
          UJN    SRCHFNT2    ENTER LOOP 
  
 GETNEXT  LDN    LE.FNT      ADVANCE POINTER
          RAD    D.T0 
 SRCHFNT2 CRD    D.FNT       READ FNT ENTRY 
          SBD    D.T1        CHECK FOR LIMIT
          ZJN    SRCHFNT1    IF AT END OF FNT 
  
COMPLFN   IFNONE (CATALOG,EXTEND,RENAME)
          LDD    D.FNT       COMPARE CHARS 1,2
          LMI    D.Z1 
          NJN    GETNEXT     IF NOT A MATCH 
          LDD    D.FNT+1     CHARS 3,4
          LMM    1,D.Z1 
          NJN    GETNEXT
          LDD    D.FNT+2     CHARS 6,5
          LMM    2,D.Z1 
          NJN    GETNEXT
          LDD    D.FNT+3     CHAR 7 
          LMM    3,D.Z1 
          SHN    -6 
COMPLFN   ELSE
          RJM  COMPLFN
COMPLFN   ENDIF 
          ZJN    SRCHFNTX    EXIT IF MATCH
          UJN    GETNEXT
SRCHFNT   ENDIF 
SEARCH    SPACE  4,12 
SEARCH    IF     DEF,SEARCH$
**        SEARCH
*         ------
* 
*         SUBROUTINE TO SEARCH PFD (WILL WRAP AROUND
*         IF EOI ENCOUNTERED) 
* 
*                ENTRY -OWNER-PFN(25 BYTES) MUST HOLD NAME OF 
*                       OWNER AND PERM FILE NAME
*                      -NASLOT= 0 NAME AND SLOT SEARCH
*                       NASLOT= 1 NAME SEARCH 
*                PRU HAS NUMBER OF PRUS INTO PFD
* 
*                EXIT - ACCUM = 1 
*                                    POINT-POINT+2 - PRU ADDRESS OF EMPT
*                                  POINT-POINT+3=0 IF NO ES FOUND 
*                      ACCUM = 0  NAME FOUND
*                                  EXCEPT IN RENAME, WHERE = 0 MEANS
*                                   ID-PFN PAIR DOES NOT ALREADY EXIST
* 
*         CALLS  R.RAFL 
*                PSDFNT 
*                PFDIO
*                SRPRU
*                DIV5 
*                MSTADR 
*                CALPTR 
*                BACKSP 
  
  
SEA00     LDN    0           NAME FOUND STATUS
  
SEARCH    ENM    X           ENTRY / EXIT 
  
          RJM  R.RAFL 
SEA00A    BSS    0
  
          IFNONE (ATTACH),6 
          LDN    P.ZERO 
          CRM    PTRTBL,D.PPONE 
          LDN    P.ZERO 
          CRM    PTRTBL+5,D.PPONE  ZERO ALL TEN BYTES OF PTRTBL 
          LDC    HASHPTR+1
          STM    SEA01B+1 
  
SEA01A    LDM    SUBSRP1
          STM    SRP2 
          LDC    SRP6 
          STM    SRP1A+1
          LDD    D.PPMES1 
          ADN    W.PPMES5-W.PPMES1
          STM    REQTAB+1 
          LDN    2
          STD    COUNT
          LCN    1
          STM    JTEMP3 
          STM    PRUSLOT
          LDN    0
          STD    SCRATCH
          STD    ENTCOUNT 
SEA01     LDM    SUBD 
          RJM  PSDFNT              (D.FNT-D.FNT+9)=SD FST 
          LDD    TEMP2
          STM    PRU
  
          IFNONE (ATTACH),1 
SEA01B    STM    HASHPTR+1         * * *  INSTRUCTION MODIFIED  * * * 
  
          ADN    1
          STD    TIME              INITIALIZE STARTING POINT
* 
SEA05B    LDM    REQTAB+1 
          CWM    D.FNT,COUNT
          LDC    0400B             *NO FET* FLAG
          STM    FLAGS
          LDK    O.RDP+STIL        INTERLOCK ORDER CODE 
          STM    ORDER
          LDC    SECT1
          STM    PSEUBF 
          LDN    0
          STM    REQTAB 
  
          IFNONE (ATTACH),1 
          STM    SEA01B+1          FORCE NO SAVE OF HASHPTR ON WRAP AROU
  
          LDC    REQTAB 
          RJM  PFDIO               BUILD STACK REQUEST
          LDM    NASLOT 
          RJM  SRPRU
          RJM  CHKSTS              CHECK RETURN STATUS
          NJN  SEA05               IF CONNECT BROKEN
          LDD    COUNT             EXIT FLAG FROM SRPRU 
          NJN  SEA06
          LJM  SEA52               NAME FOUND,JUMP
* 
          IFANY  (ATTACH),3 
SEA05     LDN    0
          STM    FLAGPTR+1         REINITIALIZE END OF SUBDIRECTORY FLAG SC45982
          LJM  SEA01A 
          IFNONE (ATTACH),1 
SEA05     LJM  SEA00A              TRY AGAIN
* 
SEA06     SBN    1
          NJN  SEA07
          LJM  SEA51
* 
NAME      IFNONE (ATTACH) 
SEA07     LDM    NASLOT 
          ZJN  SEA07A 
          LJM  SEA00
  
SEA07A    LDM    JTEMP3 
          LMC    7776B
          NJN  SEA08
          LJM  SEABB
* 
* 
*         SLOT FOUND
* 
SEA08     BSS    0
          LDC    SECT1+4
          STD    ENTCOUNT 
          LDM    PRUSLOT
          SBN    1
          STM    PRU
          LDM    JTEMP3 
          SBD    ENTCOUNT 
          STD    ENTCOUNT 
          RJM  DIV5 
          LDD    SCRATCH
          STD    POINT+3
NAME      ELSE
SEA07     LJM  SEA00
NAME      ENDIF 
SEA09     RJM  MSTADR 
          ADN    W.MSPFD
          CRD    D.T1 
          CRD    D.Z1 
          LDM    PRU
          STD    D.T0+2 
          LDN    0
          STD    D.T0+1 
          STD    D.T0+3 
CVPR..    SET    *
          RJM  /CALPTR/CPR= 
          LDD    D.T0+C.FLRBWP
          STD    POINT
          LDD    D.T0+C.FCB 
          STD    POINT+1
          LDD    D.T0+C.FLPRU 
          STD    POINT+2
SUBSRP1   LDN    1
          UJN  SEARCHXX 
* 
SEABB     LDN    2                 FLAG FOR NO SLOT FOUND 
SEARCHXX  LJM  SEARCHX
* 
* 
*         EOI ENCOUNTERED,SO BEGIN SEARCH OF PFD AT BEGINNING 
*         OF PFD
* 
SEA51     LDM    SUBD              CHECK FOR SUBD 1 
          SBN    1
          NJN  SEA51X              JUMP IF NOT
          LJM  SEA07               PFD SEARCH COMPLETE
SEA51X    LDN    2
          STD    COUNT
          LDN    1
          RJM  PSDFNT              REWIND PFD 
          RJM  R.RAFL 
          LDM    SUBSRP2
          STM    SRP2              *MODIFY INSTRUCTION IN SRPRU ROUTINE*
          LDD    TEMP2
          STM    PRU
          ADN    1
          SBD    TIME              CHECK IF NEXT PRU TO SEARCH HAS BEEN 
          ZJN  SEABB               IF NEXT PRU TO SEARCH HAS BEEN SEARCH
SEA51A    LJM  SEA05B 
* 
* 
*         NAME FOUND
* 
SEA52     BSS    0
          SOM    PRU
  
          IFNONE (ATTACH),1 
          STM    ENTRYPTR+1 
  
SEA52C    LDC    SECT1+4
          STD    ENTCOUNT 
          LDD    TEMP 
          SBD    ENTCOUNT 
          STD    ENTCOUNT 
  
          IFNONE (ATTACH),1 
          STM    ENTRYPTR 
  
          RJM  DIV5 
          LDD    SCRATCH
          STD    POINT+3
  
ATTACH    IF     -DEF,ATTACH
          RJM  BACKSP 
SEA52B    LDD    D.PPMES1 
          ADN    4
          CRD    D.T0 
SEA41     LDD    D.T0+C.FLRBWP
          STD    POINT
          LDD    D.T0+C.FLRBEB
          LPN    7B 
          STD    POINT+1
          LDD    D.T0+C.FLPRU 
          STD    POINT+2
          LDM    NASLOT 
          UJK  SEARCHX
ATTACH    ELSE
          LJM  SEA09
ATTACH    ENDIF 
  
SEARCH    ENDIF 
SRPRU     SPACE  4,12 
SRPRU     IF     DEF,SRPRU$ 
**        SRPRU 
*         ----- 
* 
*         SUBROUTINE TO SEARCH ONE SUBDIRECTORY WITH NON-STOP READ
* 
*         ENTRY     A=0      SEARCH FOR EMPTY SLOT
*                   A NE 0   SEARCH FOR PFN 
*                   TCOUNT=C.SDL
*                   STACKRE1 = STACK REQUEST WORD 1 
*                   STACKRE2 = STACK REQUEST WORD 2 
*                   COUNT NE 0
* 
*         DIRECT CELLS USED 
*                   SCRATCH=TCOUNT
*                   TEMP=ADDRESS OF FOURTH BYTE OF CURRENT HEADER 
*                   TEMP1,ENTCOUNT   SCRATCH CELLS
* 
*         EXIT      A=0      SLOT OR NAME FOUND 
*                   A NE 0   NO SLOT OR NAME FOUND
*                   TEMP   =ADDRESS OF FOURTH BYTE OF LAST HEADER 
*                            EXAMINED 
*                JTEMP3  FLAGS WHETHER A  SLOT HAS BEEN FOUND 
*                IF 7776B, NO SLOT FOUND
* 
* 
*         THIS SUBROUTINE MODIFIES INSTRUCTIONS HEAVILY 
*         (ALSO MODIFIED BY SUBROUTINE *SEARCH*)
*                                  AT DROP1, *LDM JTEMP3* BECOMES 
*                                  *LJM DROP2*
*                  IF ONLY A NAME SEARCH IS DESIRED 
* 
*                                  AT SRP1A, *LJM SRP6* BECOMES 
*                                  *LJM SRP81*
*                  ONCE A SLOT IS FOUND 
* 
* 
*         THIS ROUTINE SHOULD ALLOW FOR RE-ISSUING OF STACK 
*         REQUEST BY STACK PROCESSOR ON MAJOR RE-POSITIONING
*         THIS WILL BE FLAGGED BY A RETURN OF 1 RATHER THAN 
*         3 IN CONTROL WORD 
* 
*         CALLS  R.TAFL 
*                R.EREQS
*                R.STB
*                R.RAFL 
  
  
SRPRU     ENM    X                 ENTRY / EXIT 
  
          ZJN  SRPRU1 
          LDC    SRP81
          STM    SRP1A+1           *INSTRUCTION MODIFACATION* 
SRPRU1    RJM  R.TAFL              ALLOW FOR STORAGE MOVE DURING SEARCH 
          IF     -DEF,ATTACH,2
          LDM    SUBD 
          STD    REMAIN 
          LDC    SECT1+4
          STD    TEMP 
          LDN    STACKRE1 
          STD    D.T0 
          LDD    D.PPMES1 
          STD    STACKRE2+C.STPMS 
          RJM  R.EREQS             ENTER REQUEST IN STACK 
RWPP      LDN    RWDELAY/2         DELAY  RWDELAY MICROSECONDS
          SBN    1
          NJN  *-1
RWPL      LDD    D.PPMES1 
          ADN    W.RWPPCW 
RWPL1     CRD    D.T3              READ CONTROL WORD
          LDD    D.T3+C.RWPPCF
          SBN    3
          NJN  RWPLR
          LJM  RWPIO
* 
RWPLR     MJN  SRP9B               1SP REPLY IS 1,2, OR 4.  JIF NOT 4 
          LDN    1
          STD    COUNT             FLAG FOR EOI-ENCOUNTERED 
          LJM  WAIT11              ACKNOWLEDGE COMPLETION TO 1SP
* 
SRP9B     BSS    0
          ADN    2
          MJN    RWPP 
          NJN    RWPL 
          LDC    RWPSTBL
          RJM  R.STB               STORE CHANNEL NUMBER 
          AOD    D.T3+C.RWPPCF     RESET CONTROL FLAG = 2 
RWPLR1    LDD    D.PPMES1          FWA 1SP COMMUNICATION BUFFER 
          ADN    W.RWPPCW 
          CWD    D.T3 
          UJN  RWPL1
* 
SRP6      LDM    PRU
          STM    PRUSLOT
  
          IFNONE (ATTACH,RENAME),2
          SBN    1
          STM    EMPTYPTR+1 
  
          LDD    TEMP 
          STM    JTEMP3 
  
          IFNONE (ATTACH,RENAME),2
          ADC    -SECT1-4 
          STM    EMPTYPTR 
  
          LDC    SRP81
          STM    SRP1A+1           *INSTRUCTION MODIFICATION* 
  
          IFNONE (ATTACH),1 
SRP81     LDM    FLAGPTR+1
  
          IFANY  (ATTACH),2 
SRP81     LDC    *-*               * * *  INSTRUCTION MODIFIED  * * * 
FLAGPTR   EQU    SRP81
  
          NJN  SRP90               PAST END OF SUBDIRECTORY 
SRP82     LDC    SECT1+4+PRULNG*5-PLNGTH
          SBD    TEMP 
          NJN  SRP91         NOT END OF PRU YET 
          STD    D.T3+C.RWPPWT     CUMULATIVE BYTE-COUNT RESET TO 0 
          LDN    2
          STD    D.T3+C.RWPPCF     CONTROL-FLAG = 2 = READY FOR XMISSION
          LDC    SECT1+4
          STD    TEMP              SAVE BYTE-ADDR OF FREE-ENTRY FLAG
          UJK  RWPLR1              REQUEST MORE DATA FROM 1SP 
  
RWPIO     LDD    D.T3+C.RWPPWC
RWPIOW    IJM    *,**              WAIT FOR CHANNEL ACTIVE
RWPIOT    IAM    SECT1,** 
          AOM    PRU
  
SRP2      LDN    1                 SRP2 WILL BE CHANGED TO *SBD TIME* 
*                                  EOI IS ENCOUNTERED 
  
          NJN  SRP1 
SRP89     LJM    DROP2
  
SUBSRP2   SBD    TIME 
  
          IFNONE (ATTACH,RENAME),2
SRP90     LDM    EMPTYPTR+1 
          NJN  SRP89               EMPTY ENTRY ALREADY FOUND
          UJK  SRP82
  
          IFANY  (ATTACH,RENAME),1
SRP90     EQU    SRP89
  
SRP91     LDC    PLNGTH 
          RAD    TEMP 
* 
SRP1      LDI    TEMP 
          LPN    EUFLAG 
          NJN  SRP11
SRP1A     LJM  SRP6                *INSTRUCTION  MODIFICATION*
* 
PFASR     IF     -DEF,ATTACH
SRP11     LDM    -1,TEMP           HASH VALUE OF THIS ENTRY 
          SBD    REMAIN 
          NJN  SRP811              NOT THIS SUBDIRECTORY
          STD    TEMP1
          LDM    FLAGPTR+1
          ZJN  SRP812              NO FLAGGED ENTRY YET IN THIS SD
          RJM  DPFM 
          LDN    CODE25            END OF SD FLAG NOT IN LAST ENTRY 
          RJM  ERR
  
SRP811    LJM  SRP81               DONE WITH THIS ENTRY 
  
SRP812    LDM    PRU
          SBN    1
          STM    LASTPTR+1         PRU OFFSET TO CURRENT ENTRY
          LDD    TEMP 
          ADC    -SECT1-4 
          STM    LASTPTR           ENTRY OFFSET OF CURRENT ENTRY
PFASR     ELSE
SRP811    UJK  SRP81
SRP11     LDN    0
          STD    TEMP1
PFASR     ENDIF 
          LDI    TEMP 
          SHN    17-S.PDESD 
          PJN  SRP13               END OF SD FLAG NOT SET 
PFASR     IFNONE (ATTACH) 
          LDM    LASTPTR
          STM    FLAGPTR
          LDM    LASTPTR+1
          STM    FLAGPTR+1
PFASR     ELSE
          LDM    -1,TEMP
          SBM    SUBD 
          NJN  SRP811              SUBDIRECTORY MISMATCH
          AOM    FLAGPTR+1
PFASR     ENDIF 
SRP13     LDD    TEMP 
          ADN    1
          STD    ENTCOUNT 
JK19      LDI    ENTCOUNT 
          LMM    OWNER,TEMP1
          NJN  SRP811              JUMP IF NO MATCH 
          AOD    ENTCOUNT 
          AOD    TEMP1
          SBN    25                25  BYTE COMPARISON
          NJN  JK19                CONTINUE 
          STD    COUNT
DROP2     LDN    2
          STD    D.T3+C.RWPPCF
          LDC    500B 
          STD    D.T3+C.RWPPWT
          LDD    D.PPMES1 
          ADN    W.RWPPCW 
          CWD    D.T3 
WAIT      LDD    D.PPMES1 
          ADN    W.RWPPCW 
          CRD    D.T3 
          LDD    D.T3+C.RWPPCF
          SBN    1
          ZJN  DROP2
          SBN    3
          NJN  WAIT 
WAIT11    AOD    D.T3+C.RWPPCF     SET TO 5 
          LDD    D.PPMES1 
          ADN    W.RWPPCW 
          CWD    D.T3 
WAIT14    CRD    D.T3 
          LDD    D.T3 
          ZJN  WAIT12A
          LDN    25 
          SBN    1
          NJN  *-1
          LDD    D.PPMES1 
          ADN    W.RWPPCW 
          UJN  WAIT14 
* 
WAIT12A   RJM  R.RAFL              GET ACCESS TO FL 
          LJM  SRPRUX 
          SPACE  3
RWPSTBL   VFD    12/D.T3+C.RWPPCC,12/RWPIOW,12/RWPIOT 
          DATA   0
SRPRU     ENDIF 
TRAPIT    SPACE  4,12 
TRAPIT    IF     DEF,TRAPIT$
**        TRAPIT
*         ------
* 
*         SUBROUTINE TO STOP A PP ROUTINE VIA A M.PASS WITHOUT
*         CLOBBERING ANY DIRECT CELLS.  D.Z0-D.T4 ARE SAVED WITHIN
*         THE ROUTINE.  THE ACCUMULATOR IS RESTORED TO ITS ORIGIONAL
*         VALUE.
* 
*         BYTE 1 OF THE OUTPUT REGISTER WILL BE THE CALLING ADDRESS 
*         BYTE 2-3 WILL BE THE VALUE IN THE ACCUM. LEFT JUSTIFIED.
  
 TRAPIT   ENM    X
  
          STM    TRAPITC+1         SAVE ACCUM.
          SHN    -12
          ADC    2000B
          STM    TRAPITC           BITS 12-17 OF ACCUM. + .LDC. 
          LDD    D.T4 
          STM    TRAPITA
          LDN    0
          STD    D.T4 
 TRAPIT1  LDI    D.T4 
          STM    TRAPITB,D.T4 
          AOD    D.T4 
          SBN    D.T4 
          MJN  TRAPIT1
          LDM    TRAPIT 
          SBN    2
          STD    D.T1 
  
 TRAPITC  LDC    *-*               * * *  INSTRUCTION MODIFIED  * * * 
  
          STD    D.T3 
          SHN    -12
          STD    D.T2 
          LDN    M.PASS 
          RJM  R.MTR
          LDN    0
          STD    D.T4 
 TRAPIT2  LDM    TRAPITB,D.T4 
          STI    D.T4 
          AOD    D.T4 
          SBN    D.T4 
          MJN  TRAPIT2
  
          LDC    *-*
 TRAPITA  EQU    *-1               D.T4 
  
          LDM    TRAPITC
          LPN    77B
          SHN    12 
          ADM    TRAPITC+1         ACCUM. RESTORED
          UJK  TRAPITX
  
 TRAPITB  BSS    1                 D.Z0 
          BSS    1                 D.Z1 
          BSS    1                 D.Z2 
          BSS    1                 D.Z3 
          BSS    1                 D.Z4 
          BSS    1                 D.Z5 
          BSS    1                 D.Z6 
          BSS    1                 D.Z7 
          BSS    1                 D.T0 
          BSS    1                 D.T1 
          BSS    1                 D.T2 
          BSS    1                 D.T3 
TRAPIT    ENDIF 
VALCHR    SPACE  4,12 
VALCHR    IF     DEF,VALCHR$
**        VALCHR
*         ------
* 
*         CHECK A STRING OF ARBITRARY LENGTH FOR NON ALPHANUMERIC 
*         CHARACTERS.  TRAILING ZERO CHARACTERS ARE ALLOWED.
*         LEADING BLANKS OR ZEROS MAY BE ALLOWED. 
  
*         ENTRY  (A) = FIRST BYTE ADDRESS OF CHARACTER STRING + 
*                      BYTE COUNT*1S12
*                D.T2 = 0  ALPHA-NUMERIC ONLY (TRAILING ZEROS ALSO) 
*                     = 1  LEADING BLANKS WILL BE ALLOWED 
*                     = 2  LEADING ZEROS WILL BE ALLOWED
* 
*         EXIT   (A) = 0  STRING OK 
*                    " 0  SPECIAL CHARACTER OR IMBEDDED ZERO BYTE 
* 
*         USES   D.T0,D.T1,D.T2 
  
VALCHR1   LDD    D.T3 
          ZJN  VALCHR3             BEGINING OF TRAILING ZEROS 
          SBN    1R9+1
          PJN  VALCHR5             ILLEGAL CHARACTER, EXIT (D.T0).NE.0
          LDN    0
          STD    D.T2              FLAG NO MORE LEADING SPECIAL CHARS.
  
VALCHR2   ENM    X                 INTERNAL SUBROUTINE
  
          STD    D.T3 
          LJM  VALCTBL,D.T2        HOP INTO JUMP TABLE
  
*         JUMP TABLE, SO TO SPEEK 
  
VALCTBL   UJN  VALCHR1             LEADING BLANKS OR ZEROS NOW A NO NO
          SBN    1R                LEADING BLANKS OK, MAP 1R  INTO 0
          ZJN  VALCHR2X            LEADING BLANK/ZERO IS A OK 
  
*         END OF JUMP TABLE 
  
          UJN  VALCHR1             NON LEADING CHARACTER, ALLOW NO MORE 
  
*         A ZERO HAS BEEN FOUND WHEN LEADING ZEROS ARE ILLEGAL
  
VALCHR3   LDI    D.T0 
          LPN    77B
          NJN  VALCHRX             BYTE IS 00XX, XX.NE.0
VALCHR4   AOD    D.T0 
          SBD    D.T1 
          ZJN  VALCHRX             DONE WITH STRING, NO ERRORS
VALCHR5   LDI    D.T0 
          ZJN  VALCHR4             KEEP CHECKING THAT ZEROS ARE TRAILING
  
VALCHR    ENM    X                 ENTRY / EXIT 
  
          STD    D.T0              FIRST BYTE ADDRESS 
          STD    D.T1 
          SHN    -12
          RAD    D.T1 
VALCHR6   LDI    D.T0 
          SHN    -6 
          RJM  VALCHR2             CHECK FIRST CHARACTER OF BYTE
          LDI    D.T0 
          LPN    77B
          RJM  VALCHR2             CHECK SECOND CHARACTER OF BYTE 
          AOD    D.T0 
          SBD    D.T1 
          NJN  VALCHR6             MORE BYTES TO DO 
          UJN  VALCHRX             DONE, NO TRAILING ZEROS
VALCHR    ENDIF 
WRTPFD    SPACE  4,12 
WRTPFD    IF     DEF,WRTPFD$
**        WRTPFD
*         ------
* 
*         SUBROUTINE TO WRITE PRU TO SUBDIRECTORY 
* 
*         ENTRY  (POINT - POINT+3) = RBT POINTER
*                (SECT1 - SECT1+477B) = PRU TO BE WRITTEN 
* 
*         EXIT   (A)= 0, OPERATION ALRIGHT
*                (A) = -VE, DEVICE I/L  IS BROKEN, AND
*                IF HAPPENS 3 CONSECUTIVE TIMES, ABORTS 
  
*         CALLS  IOPFD
*                R.WRITEP 
  
  
WRTPFD    ENM    X                 ENTRY / EXIT 
  
          LDK    O.WRP+STIL 
          RJM  IOPFD
          RJM  R.WRITEP            WRITE PRU
          RJM  CHKSTS 
          UJK  WRTPFDX
WRTPFD    ENDIF 
WRTPRU    SPACE  4,12 
WRTPRU    IF     DEF,WRTPRU$
**        WRTPRU
*         ------
* 
*         SUBROUTINE TO WRITE ONE PRU TO A FILE 
* 
*         ENTRY  (REQTAB - REQTAB+2) = BYTES 0,1,2 FOR STACK REQUEST
*                (JTEMP3) = ORDINAL OF FIRST RBT WORD PAIR
*                (PSEUBF) = FWA OF PP BUFFER
* 
*         EXIT   (A)= 0, OPERATION ALRIGHT
*                (A) = -VE, DEVICE I/L BROKEN 
*                    = +VE, I/O ERR OR DEV I/L BROKEN 3 TIMES 
* 
*         USES   ORDER   FLAGS
* 
*         CALLS  PFDIO
*                R.WRITEP 
  
  
WRTPRU    ENM    X                 ENTRY / EXIT 
  
          IF     -DEF,QFILE,1                                            SC44949
          LDK    O.WRP+STIL 
          STM    ORDER
          LDC    0600B             NO FET  /  EXACT 
          STM    FLAGS
          LDC    REQTAB 
          RJM  PFDIO               BUILD WRITE STACK REQUEST
          LDN    STACKRE1 
          RJM  R.WRITEP            WRITE A PRU FROM BUFFER
          RJM  CHKSTS 
          UJK  WRTPRUX
WRTPRU    ENDIF 
WPRU      SPACE  4,12 
WPRU      IF     DEF,WPRU$
**        WPRU
*         ----
* 
*         SUBROUTINE TO WRITE A PRU 
* 
*         ENTRY  NONE 
* 
*         EXIT   (A) = 0, WRITE IS ALRIGHT
*                (A)=-1, I/L IS BROKEN AND
*                IF A MULTIPRU ENTRY, THE 
*                PREVIOUSLY WRITTEN PRUS
*                WOULD BE RELEASED
* 
*         CALLS  BACKSP, SAVE, RPRU, WRTPRU 
*                MATCH, CHKSTS
* 
  
WPRU      ENM    X                 ENTRY/EXIT 
  
          LDM    REQTAB+1          SAVE CURRENT POSITION
          CRM    RPRUFS,D.PPONE 
          IF     DEF,QFILE,1                                             SC44949
          LDK    O.WRP+STIL                                              SC44949
          RJM  WRTPRU 
          ZJN  WPRUX               IF ALRIGHT, EXIT 
* 
*         ELSE, DEVICE INTERLOCK IS BROKEN
* 
          RJM  SAVE                SAVE WRTPRU DATA IN SECT3
          LDM    REQTAB+1          RESET CURRENT POSITION 
          CWM    RPRUFS,D.PPONE 
          RJM  RPRU                REREAD LAST PRU TO SECT1 
          LDM    SECT1+4
          LPN    CEF
          NJN  WPRU3               IF ENTRY IN USE
  
WPRU2     LJM  FREPRU              IF ENTRY FREE
  
WPRU3     BSS    0
  
          IF     DEF,QFILE,3
          LDM    SECT1+4
          LPN    QFLG 
          ZJN  WPRU2               IF NOT A QUEUE FILE
  
          LDC    SECT1+5
          STD    TEMP1
          LDC    SECT3             COMPARE SECT1 AND SECT3
          STD    TEMP2
          LDC    315D 
          RJM  MATCH
          ZJN  WPRU4               IF COMPARED
  
          LDC    RBTCHDR           CHECK IF PRU IS 1ST PRU OF PFC 
          STD    TEMP1
          LDC    SECT1+5
          STD    TEMP2
          LDN    4
          RJM  MATCH
          ZJN  WPRU5               IF COMPARED
WPRU4     AOM    NWPRU             INCREMENT NO. OF PRUS WRITTEN
          UJN  FREPRU 
  
WPRU5     BSS    0
  
          IF     -DEF,QFILE,2 
          LDM    SECT1+5+CCYCLE    CHECK CYCLE NUMBER 
          ZJN  WPRU4               IF WRITE IS PARTIAL
  
          LDC    SECT1+10          COMPARE OWNER-ID 
          STD    TEMP1
          LDC    SECT3+5           PFN AND
          STD    TEMP2
          LDN    26D
          RJM  MATCH
          ZJN  WPRU4               IF MATCHED 
* 
*         FREE PREVIOUSLY WRITTEN PRUS
* 
FREPRU    LDM    NWPRU
          NJN  FREPRU1
FREPRU0   BSS    0
          LCN    1                 GO SEARCH RBTC FOR EOI 
          LJM  WPRUX               EXIT 
* 
FREPRU1   LDM    RBTC              SET CURRENT TO 1ST PRU OF ENTRY
          STM    RPRUFS+C.FLRBWP
          LDM    RBTC+1 
          STM    RPRUFS+C.FCB 
          LDM    RBTC+2 
          STM    RPRUFS+C.FLPRU 
          LDM    REQTAB+1 
          CWM    RPRUFS,D.PPONE 
* 
FREPRU2   RJM  RPRU                READ A PRU 
FREPRU3   LDM    SECT1+4
          SCN    CEF               CLEAR ENTRY BUSY FLAG
          STM    SECT1+4
          LDM    REQTAB+1          RESET FST TO PRU JUST READ 
          CWM    RPRUFS,D.PPONE 
          IF     DEF,QFILE,1                                             SC44949
          LDK    O.WRP+STIL                                              SC44949
          RJM  WRTPRU              WRITE A PRU
          ZJN  FREPRU5             IF ALRIGHT 
* 
*         ELSE, DEVICE INTERLOCK IS BROKEN
* 
          RJM  SAVE                SAVE WRTPRU DATA IN SECT3
          LDM    REQTAB+1          REPOSITION 
          CWM    RPRUFS,D.PPONE 
          RJM  RPRU                REREAD LAST PRU
          LDM    SECT1+4
          LPN    CEF
          ZJN  FREPRU5             IF ENTRY IS FREE 
  
          LDC    SECT1+5
          STD    TEMP1
          LDC    SECT3
          STD    TEMP2
          LDC    315D 
          RJM  MATCH
          NJN  FREPRU5             IF NOT MATCHED 
          LJM  FREPRU3             IF MATCHED, TRY AGAIN
  
FREPRU5   SOM    NWPRU             DECREMENT PRU COUNT
          ZJN  FREPRU6             IF NO MORE PRUS TO FREE UP 
          LJM  FREPRU2             IF MORE, CONTINUE
  
FREPRU6   LJM  FREPRU0             EXIT 
  
NWPRU     BSSZ   1                 NO. OF PRUS SUCCESSFULLY WRITTEN 
WPRU      ENDIF 
SAVE      SPACE  4,12 
SAVE      IF      DEF,SAVE$ 
**        SAVE
*         ----
* 
*         SUBROUTINE TO SAVE CONTENTS OF
*         SECT1 BUFFER IN SECT3 BUFFER
* 
*         ENTRY  SECT1
* 
*         EXIT   SECT1 IS SAVED IN SECT3
* 
*         CALLS  BCOPY
  
SAVE      ENM    X                 ENTRY/EXIT 
  
          LDC    SECT1+5
          STD    TEMP1
          LDC    SECT3
          STD    TEMP2
          LDC    315D 
          RJM  FCOPY
          UJN  SAVEX
SAVE      ENDIF 
DECKALL   TITLE  D E C K A L L   ---   INTERLOCK PROCESSING SUBROUTINES 
RS        SPACE  4,12 
RS        IF     DEF,RS$
**        RS
*         --
* 
*         SUBROUTINE TO GET PFM INTERLOCK BYTE (P.PFM1/C.PFMCH) 
* 
*         ENTRY - NONE
* 
*         EXIT   CH.PFM RESERVED
*                (A-REG) = INTERLOCK BYTE 
*                (SCRATCH) = INTERLOCK BYTE 
* 
*         USES   D.T0 - D.T4
* 
*         CALLS  R.RCH
  
  
RS        ENM    X                 ENTRY / EXIT 
  
          LDN    CH.PFM            LOAD PSEUDO CHANNEL
          RJM  R.RCH               PROCESS REQUEST
          LDK    P.PFM1            LOAD WORD POSITION 
          CRD    D.T0              READ 
          LDD    D.T0+C.PFMCH      PICK UP CORRECT BYTE 
          STD    SCRATCH           SAVE 
          UJK  RSX                 RETURN 
RS        ENDIF 
REND      SPACE  4,12 
REND      IF     DEF,REND$
**        REND
*         ----
* 
*         SUBROUTINE TO UPDATE PFM INTERLOCK BYTE (P.PFM1/C.PFMCH)
* 
*         ENTRY  (A-REG) = INTERLOCK BYTE 
*                CH.PFM RESERVED
* 
*         EXIT   P.PFM1 UPDATED 
*                CH.PFM DROPPED 
* 
*         CALLS  R.DCH
  
  
REND      ENM    X                 ENTRY / EXIT 
  
          STD    D.T0+C.PFMCH      WRITE BACK INTERLOCK BYTE
          LDK    P.PFM1            LOAD WORD POSITION 
          CWD    D.T0              WRITE
          LDN    CH.PFM            LOAD PSEUDO CHANNEL
          RJM  R.DCH               PROCESS DROP 
          UJK  RENDX
REND      ENDIF 
RPFM      SPACE  4,12 
RPFM      IF     DEF,RPFM$
**        RPFM
*         ----
* 
*         RESERVE PFM INTERLOCK IN MST
* 
*         ENTRY  PFMI SHOULD HAVE APPROPRIATE VALUE 
* 
*         EXIT   (A) = +VE, PFM INTERLOCK ALREADY ON
*                (A) = -VE, TRANSPF UTILITY BIT IS ON 
*                (A) = 0, PFM INTERLOCK SET 
* 
*         CALLS  R.RCH,R.DCH, MSTADR
  
  
RPFM3     STM    RPFM4             SAVE RETURN CODE 
          LDN    CH.MST 
          RJM R.DCH                DROP MST PSEUDO-CHANNEL
          LDC    ** 
RPFM4     EQU    *-1               EXIT MODE
  
RPFM      ENM    X                 ENTRY/EXIT 
          LDM    PFMI              CHECK INTERNAL PFM INTERLOCK 
          ZJN  RPFM2               IF INTERLOCK NOT ALREADY SET 
  
ILERR     LDN    CODE13            * INTERLOCK PROBLEM *
          RJM  ERR
  
RPFM2     LDN    CH.MST 
          RJM  R.RCH               GET MST PSEUDO-CHANNEL 
          RJM  MSTADR              GET MST ADDRESS
          CRD    D.T0 
  
RIL       IF     DEF,TRANSF 
          LDD    D.T0+C.PFMIL 
RILX      IFNONE (ATTACH,QFILE) 
          LPC    UTIL 
RIL1A     EQU    *-1
RILX      ELSE
          LPK    UTIL 
RILX      ENDIF 
          ZJN  RPFM0               IF UTILITY BIT IS NOT ON 
          LCN    1
          UJK  RPFM3
RIL       ENDIF 
  
RPFM0     LDD    D.T0+C.PFMIL 
          LPN    PFMIL
          ZJN  RPFM1               IF PFM INTERLOCK IS NOT SET
          LDN    1
          UJK  RPFM3
RPFM1     LDD    D.T0+C.PFMIL 
          LMN    PFMIL
          STD    D.T0+C.PFMIL      SET PFM INTERLOCK
          RJM  MSTADR 
          CWD    D.T0 
          LDN    1
          STM    PFMI              SET INTERNAL PFM INTERLOCK 
          LDN    0
          UJK  RPFM3
RPFM      ENDIF 
RCAT      SPACE  3,5
RCAT      IF     DEF,RCAT$
**        RCAT
*         ----
* 
*         SET WRAP-AROUND FLAG IN MST 
* 
*         USES   D.T0 - D.T4
* 
*         CALLS  MSTADR 
  
  
RCAT      ENM    X                 ENTRY / EXIT 
  
          RJM  MSTADR 
          ADN    W.MSPFC
          CRD    D.T0 
          LDD    D.T0+C.MSCEOI
          LPK    4000B
          NJN  RCATX
          LDC    4000B
          RAD    D.T0+C.MSCEOI
          RJM  MSTADR 
          ADN    W.MSPFC
          CWD    D.T0 
          LDN    0
          UJN  RCATX
RCAT      ENDIF 
DCAT      SPACE  4,12 
DCAT      IF     DEF,DCAT$
**        DCAT
*         ----
* 
*         CLEAR WRAP-AROUND FLAG IN MST 
* 
*         USES   D.T0 - D.T4
* 
*         CALLS  MSTADR 
  
  
DCAT      ENM    X                 ENTRY / EXIT 
  
          RJM  MSTADR 
          ADN    W.MSPFC
          CRD    D.T0 
          LDD    D.T0+C.MSCEOI
          SCK    4000B
          STD    D.T0+C.MSCEOI
          RJM  MSTADR 
          ADN    W.MSPFC
          CWD    D.T0 
          UJN  DCATX
DCAT      ENDIF 
INTRLCK   SPACE  4,12 
INTRLCK   IFEQ   IP.DEBUG,0 
**        INTRLCK 
*         ------- 
* 
*         SUBROUTINE TO CLEAR INTERLOCKS HELD BY THIS ROUTINE 
* 
*         ENTRY - PFMI IS NON-ZERO IF THIS PP PROGRAM 
*                 HAS THE PFM INTERLOCK AND  CPTFLGS HAS
*                 APFF SET IF THIS ROUTINE HAS THE
*                 APF FLAG ON.
* 
*         EXIT  - ALL INTERLOCKS OFF
* 
*         CALLS - DPFM
*                 APFLAG
  
  
INTRLCK   ENM    X                 ENTRY / EXIT 
  
          LDM    PFMI              CHECK IF PFM INTERLOCK ON
          ZJN  ERRB1
          RJM    DPFM 
* 
ERRB1     LDD    CPTFLGS
          LPK    APFF              CHECK IF APF FLAG ON 
          ZJN  ERRC 
          RJM  APFLAG 
ERRC      BSS    0
          UJN  INTRLCKX 
INTRLCK   ENDIF 
ENDSD     SPACE  4,12 
ENDSD     IF     DEF,ENDSD$ 
CLRSDF    SPACE  4,12 
CLRSDF    IF     DEF,CLRSDF$
**        CLRSDF - CLEAR END OF SUBDIRECTORY FLAG IN A PFD ENTRY
* 
*         ENTRY ((A) = PTRTBL OFFSET TO ENTRY BEING CHANGED 
* 
*        EXIT    (A) = 0  FLAG CLEARED AT GIVEN ENTRY 
*                (A) " 0  ABNORMAL I/O TERMINATION
  
CLRSDF    ENM    X                 ENTRY / EXIT 
  
          RJM  SAVESDF
          ZJN  CLRSDFX             NO POINTER GIVEN, EXIT 
          RJM  GETPFD 
          NJN  CLRSDFX             BAD READ 
          LDM    SAVESDF2 
          STD    D.Z1 
          LDI    D.Z1 
          SCN    PDESD
          STI    D.Z1 
          RJM  PUTPFD 
          UJN  CLRSDFX
CLRSDF    ENDIF 
GETPFD    SPACE  4,12 
GETPFD    IFANY  (CLRSDF$,SETSDF$)
**        GETPFD - READ A GIVEN PFD PRU INTO SECT1 BUFFER 
* 
*         ENTRY  (A) = PFD PRU OFFSET 
* 
*         EXIT   (A) = 0  NORMAL TERIINATION OF READ AND POINT CONTAINS 
*                         PFD POINTER 
  
GETPFD1   RJM  SWAPPTR
  
GETPFD    ENM    X                 ENTRY / EXIT 
  
          STD    D.Z0 
          CVPR.. PRU2=D.Z0,MST=W.MSPFD
          RJM  SWAPPTR
          RJM  READPFD
          NJN  GETPFD1             ABNORMAL READ TERMINATION
          UJN  GETPFDX
GETPFD    ENDIF 
PUTPFD    SPACE  4,12 
PUTPFD    IFANY  (CLRSDF$,SETSDF$)
**        PURPFD - WRITE A GIVEN PFDPRU FROM SECT1 BUFFER 
* 
*         ENTRY  POINT CONTAINS PFD POINTER 
* 
*         EXIT   (A) = 0  NORMAT WRITE
*                POINT IS RESTORED TO ITS ORIGIONAL FORM
  
PUTPFD    ENM    X                 ENTRY / EXIT 
          RJM  WRTPFD 
          STM    PUTPFD1+1
          RJM  SWAPPTR
PUTPFD1   LDC    *-*               MODIFIED TO CONTAIN CHKSTS RETURN
          UJN  PUTPFDX
PUTPFD    ENDIF 
SAVESDF   SPACE  4,12 
SAVESDF   IFANY  (CLRSDF$,SETSDF$)
**        SAVESDF - ENTRY ROUTINE FOR SETSDF AND CLRSDF 
* 
*         EXIT   SAVESDF1 = PRU OFFSET
*                SAVESDF2 = FLAG BYTE ADDRESS 
SAVESDF   ENM    X
  
          ADC    PTRTBL 
          STD    D.Z1 
          LDI    D.Z1 
          ADC    SECT1+5*W.PDHDR+C.PDFLAG 
          STM    SAVESDF2 
          LDM    1,D.Z1 
          UJN  SAVESDFX 
SAVESDF2  BSS    1
SAVESDF   ENDIF 
SETSDF    SPACE  4,12 
SETSDF    IF     DEF,SETSDF$
**        SETSDF - SET S.PDESD IN GIVEN PFD ENTRY 
* 
*         ENTRY  (A) = PTRTBL OFFSET TO PFD POINTER 
* 
*         EXIT   IF SR I/L IS LOST, SETSDF QUITS.  IF NOT, FLAG IS SET
*                IN GIVEN ENTRY.
  
SETSDF    ENM    X                 ENTRY / EXIT 
  
          RJM  SAVESDF
          ZJN  SETSDFX             NO POINTER GIVEN, EXIT 
          RJM  GETPFD 
          NJN  SETSDFX             BAD READ, GIVE UP
          LDM    SAVESDF2 
          STD    D.Z1 
          LDI    D.Z1 
          SCN    PDESD
          ADN    PDESD
          STI    D.Z1 
          RJM  PUTPFD 
          UJK  SETSDFX
SETSDF    ENDIF 
SWAPPTR   SPACE  4,10 
SWAPPTR   IFANY  (CLRSDF$,SETSDF$)
**        SWAPPTR - EXCHANGE CONTENSE OF POINT AND RBTA 
* 
*         ENTRY  NONE 
* 
*         EXIT   POINT AND RBTA THREE CELL ARRAYS SWAPPED 
  
SWAPPTR   ENM    X                 ENTRY / EXIT 
  
          LDN    2
          STD    D.Z1 
SWAPPTR1  LDM    POINT,D.Z1 
          STD    D.Z0 
          LDM    RBTA,D.Z1
          STM    POINT,D.Z1 
          LDD    D.Z0 
          STM    RBTA,D.Z1
          SOD    D.Z1 
          PJN  SWAPPTR1 
          UJN  SWAPPTRX 
SWAPPTR   ENDIF 
ENDSD     ENDIF 
          ENDX
*CALL  PFCD02 (PRU INDEX)/(RBTA,RBTO,PRU) CONVERSIONS 
*CALL     PFCD03 FIND MOUNTED SET TABLE ENTRY 
          LIST   *                 TURN OFF DECKALL LIST X
