*DECK,RHH 
          IDENT  RHH,PPSTART
          COMMENT  RHF UTILITY ROUTINE. 
          COMMENT  COPYRIGHT (C) CONTROL DATA CORP. 1981
          PERIPH
          BASE   D
          TITLE  RHH -- RHF UTILITY ROUTINE.
          SST 
          LIST   F
 RHH      SPACE  4
*****     RHH - RHF UTILITY ROUTINE.
* 
*         N. A. DEILY              04/21/81 
* 
*         COPYRIGHT (C) 1981, CONTROL DATA CORPORATION. 
*         ALL RIGHTS RESERVED.
* 
*         RHH IS THE REMOTE HOST HELPER FOR THE REMOTE HOST FACILITY. 
*         RHH PERFORMS MISCELLANEOUS FUNCTIONS FOR THE RHF SUBSYSTEM
*         THAT ARE WELL SUITED FOR A PP HELPER. 
          SPACE  4,10 
***       RHH CALLING SEQUENCE. 
* 
**T       RA+1   18/RHH,1/0,1/R,4/0,12/FUNC CODE,6/0,18/ADDRESS 
* 
*         WHERE  R = AUTO-RECALL
*                ADDRESS = ADDRESS OF PARAMETER BUFFER
*                FUNC CODE = RHH FUNCTION CODE. 
* 
*         THE FUNCTION COMPLETE BIT IS BIT POSITION 0 OF THE FIRST
*         WORD IN THE PARAMETER BUFFER.  THE REMAINING PORTION OF 
*         THE PARAMETER BUFFER IS DEFINED FOR EACH FUNCTION.
* 
*         FUNCTION CODE 
* 
*                    0.  RHF INITIALIZE.  UPDATE LOCAL NAD TABLE STATUS.
*                    1.  VALIDATE USER CONTROL POINT (UCP). 
*                    2.  RETURN PHYSICAL ID (PID) OF HOST MAINFRAME.
*                    3.  CLEAR RHF ACTIVE IN NAD EST ENTRY. 
*                    4.  SET UP LOCAL COPY OF JOB DAYFILE FNT.
*                    5.  FLUSH JOB DAYFILE. 
*                    6.  INCREMENT JOB TAPE COUNT.
*                    7.  SET/CLEAR S.CPFEP (FORCE-EXIT-PROCESSING FLAG) 
*                        IN JOB CONTROL POINT AREA, AND CLEAR C.CPMSLM
*                        (MASS STORAGE LIMIT).
*                   10.  INITIATE SYSTEM DYNAMIC DUMP OF CONTROL POINT. 
*                   11.  DETERMINE JOB ORIGIN.
*                   12.  RETURN JOBNAME.
*                60-77.  RESERVED FOR INSTALLATIONS.
*                ALL OTHERS ARE RESERVED FOR CDC. 
* 
*         FOR ALL FUNCTIONS, RHH WILL VALIDATE THAT IT WAS CALLED 
*         FROM THE SYSTEM LIBRARY.  FOR FUNCTIONS 0, 1, AND 3,
*         RHH WILL VERIFY THAT IT WAS CALLED FROM THE RHF SYSTEM
*         CONTROL POINT (SCP).
 RHH      TITLE  SYMBOL DEFINITIONS.
*CALL COMNOSDEF 
          SPACE  4,10 
*         DIRECT CELL DEFINITIONS.
  
 D.T0     EQU    D.T0 - D.T4       FOR R.MTR PARAMETERS ONLY
  
 S0       EQU    20B               CELLS 20B - 27B ARE SCRATCH CELLS
 S1       EQU    S0+1 
 S2       EQU    S0+2 
 S3       EQU    S0+3 
 S4       EQU    S0+4 
 S5       EQU    S0+5 
 S6       EQU    S0+6 
 S7       EQU    S0+7 
  
 PB       EQU    30B - 34B         PARAMETER BUFFER 
 FC       EQU    35B               FUNCTION CODE
 BA       EQU    36B - 37B         ADDRESS OF PARAMETER BUFFER
  
 ES       EQU    40B               EST ORDINAL
 NOS      IF     DEF,NOS
 LO       EQU    42B               LAST EST ORDINAL + 1 
 NOS      ELSE
 FE       EQU    41B               FWA OF EST TABLE 
 LE       EQU    42B               LWA+1 OF EST TABLE 
 NOS      ENDIF 
 FN       EQU    43B - 44B         FWA OF LNT 
 NO       EQU    45B               LNT ORDINAL
 LN       EQU    46B               LAST LNT ORDINAL 
 RC       EQU    47B               RHH RECALLED FROM EVENT/DELAY STACK
  
 D.PPIRB  EQU    D.PPIRB
 D.RA     EQU    D.RA 
 D.FL     EQU    D.FL 
 TWO      EQU    57B               CONSTANT TWO 
  
 NT       EQU    60B - 64B         FIRST WORD OF LNT ENTRY
  
*         EQU    65B               UNUSED 
*         EQU    66B               UNUSED 
*         EQU    67B               UNUSED 
  
 ONE      EQU    70B               CONSTANT ONE 
 HN       EQU    71B               CONSTANT ONE HUNDRED (NOS ONLY)
 TH       EQU    72B               CONSTANT ONE THOUSAND (NOS ONLY) 
 TR       EQU    73B               CONSTANT THREE (NOS ONLY)
 D.PPIR   EQU    D.PPIR 
 D.PPMES1 EQU    D.PPMES1 
          SPACE  4,8
*         OPERATING SYSTEM INSTALLATION PARAMETERS. 
  
          IF     -DEF,NOS,1 
          IPARAMS 
          SPACE  4,8
*         FUNCTION CODE 1 DEFINITIONS.
  
 F01SLS   EQU    0                 LOADED FROM SYSTEM LIBRARY 
 F01RSS   EQU    1                 SPECIAL RHF SOURCE ID
 F01SOS   EQU    2                 JOB IS SWAPPED-OUT 
 F01ERS   EQU    3                 INVALID JDT OR CP
  
 F01SLM   BIT    F01SLS 
 F01RSM   BIT    F01RSS 
 F01SOM   BIT    F01SOS 
 F01ERM   BIT    F01ERS 
          SPACE  4,8
*         LOCAL NAD TABLE DEFINITIONS.
  
 LE=LNT   EQU    5                 LENGTH OF LNT ENTRY
  
 W=LN1    EQU    0                 FIRST WORD OFFSET
 C=LNFLGS EQU    0                 FLAGS BYTE 
 S=LNOFF  EQU    9D                LINE IS OFF
 S=LNCWSL EQU    6                 CONTROLWARE NOT LOADED 
 S=LNCGE  EQU    5D                CONFIGURATION ERROR
 LNOFFM   BIT    S=LNOFF
 LNCWSLM  BIT    S=LNCWSL 
 LNCGEM   BIT    S=LNCGE
 C=LNORD  EQU    3
 S=LNORD  EQU    6
 C=LNCHA  EQU    3                 CHANNEL NUMBER 
 L=LNCHA  EQU    77B
 C=LNEST  EQU    4
 S=LNEST  EQU    3
  
 W=LN2    EQU    1
 C=LNQUC  EQU    1
 C=LNCOC  EQU    2
 C=LNANC  EQU    3
 S=LNANC  EQU    6
          SPACE  4,8
*         EST DEFINITIONS.
  
 ESTRHFM  BIT    S.ESTRHF 
          SPACE  4,8
*         OTHER SYMBOLS.
  
 NADMNE   EQU    2RNC              EST MNEMONIC FOR NAD 
 RHFSID   EQU    3R$RH             SPECIAL RHF SOURCE ID
 SC.RHF   EQU    4                 RHF SUBSYSTEM ID 
 DEBUG    EQU    0                 NO DEBUG CODE ASSEMBLED
 NLD      EQU    1                 ASSEMBLE NON-NDR CODE IN *COMBRK*
 NOS      IF     DEF,NOS
 TRACE.   EQU    0                 TURN TRACE ASSEMBLY OFF
 NOS      ELSE
 TRACE.   EQU    1                 TURN TRACE ASSEMBLY ON 
 NOS      ENDIF 
          IF     -DEF,IP.NDEN,1 
 IP.NDEN  EQU    3                 *** DEFAULT TO 1600 BPI
 S=RCL    EQU    40D-36D           INTERNAL PP CALL FLAG
 RCLF     BIT    S=RCL
 RHH      TITLE  MAIN LOOP. 
**        RHH - MAIN LOOP.
* 
*         PERFORM INITIALIZATION. 
*         IF NO ERRORS
*         THEN
*           PERFORM FUNCTION. 
*           IF NO ERRORS
*           THEN
*             COMPLETE PARAMETER BLOCK. 
*             IF NO ERRORS
*             THEN
*               DROP ALL CHANNELS.
*               DROP PP.
*             ELSE
*               ISSUE ERROR MESSAGE.
*               ABORT CP. 
*           ELSE
*             ISSUE ERROR MESSAGE.
*             ABORT CP. 
*         ELSE
*           ISSUE ERROR MESSAGE.
*           ABORT CP. 
  
  
          ORG    PPSTART
  
 RHH      BSS    0
  
          RJM    INI               PERFORM INITIALIZATION 
          MJN    RHH1              IF ERROR DETECTED
          LDM    TFCP,FC           SUBROUTINE FOR THIS FUNCTION CODE
          STM    RHHA              SET FUNCTION ENTRY POINT 
          RJM    *                 PERFORM FUNCTION 
 RHHA     EQU    *-1
          MJN    RHH1              IF ERROR DETECTED
          RJM    CMF               COMPLETE PARAMETER BLOCK 
          MJN    RHH1              IF ERROR DETECTED
          LDK    M.DPP             DROP PP
          UJN    RHH2 
  
 RHH1     RJM    ERR               ISSUE ERROR MESSAGE
          RJM    CMF               COMPLETE PARAMETER BLOCK 
          LDK    M.ABORT           ABORT CP 
  
 RHH2     STD    D.T7              SAVE TERMINATE FUNCTION
          IF     -DEF,NOS,1 
          RJM    DCH               DROP ANY CHANNEL STILL HELD
          LDD    D.T7 
          RJM    R.MTR
          LJM    R.IDLE            EXIT 
  
 TFCP     SPACE  4,10 
**        TFCP - FUNCTION CODE TABLE
* 
  
  
 TFCP     BSS    0
  
          LOC    0
  
          CON    F00               UPDATE LOCAL NAD TABLE IN RHF
          CON    F01               VALIDATE USER CONTROL POINT
          CON    F02               RETURN HOST ID 
          CON    F03               CLEAR RHF ACTIVE IN EST
 NOS      IF     -DEF,NOS 
          CON    F04               SET UP JOB DAYFILE FNT 
          CON    F05               FLUSH JOB DAYFILE
          CON    F06               INCREMENT TAPE COUNT 
          CON    F07               SET FORCE EXIT PROCESSING BIT
          CON    F10               DYNAMIC DUMP 
          CON    F11               DETERMINE JOB ORIGIN 
          CON    F12               RETURN JOBNAME 
 NOS      ENDIF 
  
          LOC    *O 
  
 TFCPL    EQU    *-TFCP 
TEMG      TITLE  ERROR MESSAGE TABLE. 
**        ERCODE - GENERATE DIAGNOSTIC MESSAGE TEXT.
* 
* ERNN    ERCODE (TEXT) 
* 
*         WHERE  NN IS ERROR ORDINAL. 
*                TEXT IS TEXT OF DIAGNOSTIC.
* 
*         GENERATES DIAGNOSTIC OF THE FORM: 
* 
*         RHHNN - TEXT. 
  
  
          PURGMAC ERCODE
          MACRO  ERCODE,LAB,MSG 
 Z        MICRO  3,,*_LAB_* 
 LAB      CON    =C* RHH"Z" - MSG_.*
 ERCODE   ENDM
  
  
 TEMG     BSS    0
  
          LOC    0
  
 ER00     ERCODE (SUBROUTINE FALL-THROUGH TRAP) 
 ER01     ERCODE (INVALID FUNCTION CODE)
 ER02     ERCODE (INVALID PARAMETER BUFFER ADDRESS) 
 ER03     ERCODE (USER NOT SYSTEM ORIGIN) 
 ER04     ERCODE (CALLED FROM CP 0) 
 ER05     ERCODE (NOT CALLED BY SYSTEM CONTROL POINT) 
 ER06     ERCODE (NO SUBSYSTEM CONTROL TABLE FOUND) 
 ER07     ERCODE (INVALID SUBSYSTEM NUMBER) 
 ER08     ERCODE (SCP NOT ACTIVE) 
 ER09     ERCODE (INVALID JDT ORDINAL)
 ER10     ERCODE (NO LOCAL NADS)
 ER11     ERCODE (NAD TABLE OUT OF RANGE) 
 ER12     ERCODE (CHANNEL NOT FOUND)
 ER13     ERCODE (CONFIGURATION ERROR)
 ER14     ERCODE (ATTEMPTING TO RESERVE MULTIPLE CHANNELS)
 ER15     ERCODE (COULD NOT FIND CONTROL POINT DAYFILE) 
 ER16     ERCODE (FILE ALREADY EXISTS)
 ER17     ERCODE (FUNCTION NOT ALLOWED FROM INTERCOM) 
 ER18     ERCODE (CONTROL POINT ERROR FLAG SET) 
 ER19     ERCODE (DAYFILE FNT CANNOT BE LINKED) 
 ER20     ERCODE (NO LOGICAL ID TABLE FOUND)
 ER21     ERCODE (MORE THAN ONE LNT WITH SAME CHANNEL)
 ER22     ERCODE (INVALID EST ORDINAL)
 ER23     ERCODE (EST IS NOT A NAD) 
  
          LOC    *O 
  
 TEMGL    EQU    *-TEMG 
  
          PURGMAC  ERCODE 
          TITLE  GLOBAL SUBROUTINES.
CEE       SPACE  4,10 
**        CEE - CHECK EST ENTRY FOR VALID NAD ENTRY.
* 
*         ENTRY  (ES) = EST ORDINAL 
*                (S7) = CHANNEL TO BE SEARCHED FOR. 
* 
*         EXIT   (A) = 0 IF EST ENTRY IS NAD ON CORRECT CHANNEL.
  
  
 CEE      ENM    X
 NOS      IF     DEF,NOS
          LDD    ES                CURRENT EST ORDINAL
          RJM    .EST              CONVERT EST ORDINAL TO EST ADDRESS 
          ADK    EQDE 
 NOS      ELSE
          LDD    FE                FWA OF EST 
          ADD    ES                CURRENT EST ORDINAL
 NOS      ENDIF 
          CRD    S0                FETCH EST ENTRY
          LDD    S0+C.ESTMNE       DEVICE MNEMONIC
 ESTONM   BIT    S.ESTON
          SCK    ESTONM            CLEAR DEVICE ON/OFF FLAG 
          LMK    NADMNE            NAD MNEMONIC 
          NJN    CEEX              IF NOT A NAD 
          LDD    S0+C.ESTCH1       EST CHANNEL
          LMD    S7                NAD TABLE CHANNEL
          LPN    37B
          UJN    CEEX              RETURN ZERO IFF NAD WITH CORRECT CH
 CMF      SPACE  4,8
**        CMF - SET COMPLETE BIT AND RETURN PARAMTER BLOCK. 
* 
*         ENTRY  (PB) - (PB+4) - PARAMETER BLOCK
*                (BA) - (BA+1) - RELATIVE ADDRESS OF PB.
* 
*         EXIT   (A) = ER02 IF ADDR OUT OF RANGE OR ZERO, 
*                      0, OTHERWISE IN WHICH CASE PB HAS
*                         BEEN WRITTEN TO CP FL WITH
*                         COMPLETE BIT SET. 
  
  
 CMF      ENM    X
          LDD    PB+4              LOW-ORDER BYTE OF PARAMETER BLOCK
          SCN    1                 CLEAR COMPLETE BIT 
          LMN    1                 SET COMPLETE BIT 
          STD    PB+4 
          LDD    BA                ADDRESS OF PARAMETER BLOCK 
          LPN    77B
          SHN    12 
          LMD    BA+1 
          ZJN    CMF1              IF ILLEGAL ADDRESS 
          ADDRA  ER=0 
          ZJN    CMF1              IF ADDRESS OUT OF FL 
          CWD    PB 
          LDN    0
          UJN    CMFX              RETURN 
  
 CMF1     LCN    ER02 
          UJN    CMFX              RETURN 
 CSL      SPACE  4,8
**        CSL - CHECK FOR SYSTEM LIBRARY PROGRAM. 
* 
*         ENTRY  (A) = FWA OF CPA 
* 
*         EXIT   (A) < 0 IF NOT LOADED FROM SYSTEM LIBRARY. 
  
  
 CSL      ENM    X
 NOS      IF     DEF,NOS
          ADK    W.SEP
          CRD    S0                READ SPECIAL ENTRY POINT WORD
          LDD    S0+C.EPI 
          SHN    17-S.SSJ 
          MJN    CSL1              IF SSJ= ENTRY POINT
          LCN    1                 ILLEGAL CALLER 
          UJN    CSLX 
  
 CSL1     LDN    0                 LEGAL CALLER 
 NOS      ELSE
          ADK    W.CPLDR1 
          CRD    S0 
          LDD    S0+C.CPLP
          SHN    17-S.CPLP
 NOS      ENDIF 
          UJN    CSLX              RETURNS MINUS IF NOT FROM SYSTEM LIB 
 NOS      IF     -DEF,NOS 
 DCH      SPACE  4,8
**        DCH - RELEASE SYSTEM INTERLOCK. 
* 
*         EXIT   (A) = 0. 
* 
*         CALLS  R.DCH. 
  
  
 DCH      ENM    X
          LDM    DCHA              GET CURRENT INTERLOCK
          ZJN    DCHX              IF NO INTERLOCK RESERVED 
          RJM    R.DCH             RELEASE INTERLOCK
          LDN    0
          STM    DCHA              FLAG NO INTERLOCK RESERVED 
          UJN    DCHX              RETURN 
  
 DCHA     CON    0
 NOS      ENDIF 
 ERR      SPACE  4,8
**        ERR - ISSUE RHH ERROR MESSAGE.
* 
*         ENTRY  (A) = COMPLEMENT OF ERROR ORDINAL. 
* 
*         EXIT   DIAGNOSTIC ISSUED TO DAYFILE.
* 
*         CALLS  DFM. 
  
  
 ERR      ENM    X
          LMC    777777B           COMPLEMENT ERROR ORDINAL 
          STD    S7 
          LDM    TEMG,S7           FETCH ADDRESS OF ERROR MESSAGE 
          IF     DEF,NOS,1
          ADK    CPON              SEND MESSAGE TO CALLERS DAYFILE
          RJM    R.DFM             ISSUE DAYFILE MESSAGE
          LDN    0
          UJN    ERRX              RETURN 
 ESI      SPACE  4,8
**        ESI - INITIALIZE EST PARAMETERS.
* 
*         EXIT   (FE) = FWA OF EST
*                (LE) = LWA+1 OF EST
*                (ES) = RESET TO LAST EST ORDINAL.
* 
*         CALLS  ESR. 
  
  
 ESI      ENM    X
          LDK    P.EST
          CRD    S0 
 NOS      IF     DEF,NOS
          LDD    S0+C.ESTSIZ
          STD    LO                LAST EST ORDINAL + 1 
 NOS      ELSE
          LDD    S0+C.EST 
          STD    FE                FWA OF EST 
          LDD    S0+C.ESTLWA
          STD    LE                LWA+1 OF EST 
 NOS      ENDIF 
          RJM    ESR               RESET EST ORDINAL
          LDN    0
          UJN    ESIX              RETURN 
 ESR      SPACE  4,8
**        ESR - RESET EST ORDINAL.
* 
*         EXIT   (ES) = RESET TO LAST EST ORDINAL.
  
  
 ESR      ENM    X
 NOS      IF     DEF,NOS
          LDD    LO                LAST EST ORDINAL + 1 
 NOS      ELSE
          LDD    LE                LWA+1 OF EST 
          SBD    FE                MINUS FWA
 NOS      ENDIF 
          SBN    1
          STD    ES                LAST EST ORDINAL 
          LDN    0
          UJN    ESRX              RETURN 
 NOS      IF     -DEF,NOS 
 FJD      SPACE  4,8
**        FJD - FLUSH JOB DAYFILE.
* 
*         EXIT   R.MTR FUNCTION M.DFM ISSUED TO FLUSH CP DAYFILE. 
* 
*         CALLS  R.MTR. 
  
  
 FJD      ENM    X
          LDK    P.ZERO 
          CRD    D.T0              ZERO PARAMETER BYTES 
          LDD    D.CPAD            FWA OF CONTROL POINT AREA
          CPAN                     CONVERT TO CP NUMBER 
          STD    D.T0+2            FLAG TO FLUSH DAYFILE FOR THIS CP
          LDK    M.DFM
          RJM    R.MTR             ISSUE MONITOR REQUEST
          LDN    0
          UJN    FJDX              RETURN 
 JDT      SPACE  4,8
**        JDT - VALIDATE JDT ORDINAL. 
* 
*         ENTRY  (A) = JDT ORDINAL OR CP NUMBER.
* 
*         EXIT   (A) = ER09 IF INVALID JDT ORDINAL, 
*                      0, IF VALID CP NUMBER, 
*                      FWA OF JDT, IF VALID JDT ORDINAL.
*         A JDT ORDINAL IS VALID IFF IT SATISFIES THE FOLLOWING RELATION
* 
*         0 <= LE.JDT * (JDTORD - (N.CP + 1) ) < JDTLEN 
  
  
 JDT      ENM    X
          STD    S7                SAVE JDT ORDINAL 
          LDK    P.NCP
          CRD    S0 
          LDD    S7                JDT ORDINAL
          ZJN    JDT3              IF INVALID CP OR JDT 
          SBD    S0+C.NCP          NUMBER OF CONTROL POINTS 
          SBN    1
          STD    S6                OFFSET FROM START OF JDT 
          MJN    JDT4              IF VALID CONTROL POINT 
          LDK    P.SCH
          CRD    S0 
          LDD    S0+C.LEJDT        LENGTH OF JDT ENTRY
          LPN    77B
          STD    S0+C.LEJDT        ONLY THE LOWER SIX BITS
          LDN    0
          STD    S7                INITIALIZE OFFSET
  
 JDT1     SOD    S6                DECREMENT ORDINAL
          MJN    JDT2              IF MULTIPLICATION FINISHED 
          LDD    S0+C.LEJDT 
          RAD    S7 
          UJN    JDT1              CONTINUE 
  
 JDT2     LDD    S0+C.LJDT         LENGTH OF JDT
          SBD    S7                OFFSET OF THIS JDT 
          MJN    JDT3              IF INVALID JDT 
          LDD    S0+C.JDT          FWA OF JDT DIVIDED BY 10B
          SHN    3                 MULTIPLY BY 10B
          ADD    S7                OFFSET OF JDT ENTRY
          UJN    JDT5              RETURN WITH JDT ENTRY ADDRESS
  
 JDT3     LCN    ER09 
          UJN    JDT5              RETURN 
  
 JDT4     LDN    0
  
 JDT5     LJM    JDTX              RETURN 
 NOS      ENDIF 
 NTA      SPACE  4,8
**        NTA - CALCULATE FWA OF LNT ENTRY. 
* 
*         ENTRY  (FN) - (FN+1) = FWA OF LNT 
*                (NO) = LNT ORDINAL 
* 
*         EXIT   (A) = =, IF LNT ENTRY OUT OF FL, 
*                    = FWA OF LNT ENTRY IN CM, OTHERWISE. 
  
  
 NTA      ENM    X
          LDD    FN                FWA OF LNT 
          LPN    77B
          SHN    12 
          LMD    FN+1 
          DUP    LE=LNT,1 
          ADD    NO                ADD LNT ORDINAL
          ADK    LE=LNT-1          LWA OF LNT ENTRY 
          ADDRA  ER=0 
          ZJN    NTAX              IF ADDRESS OUTSIDE OF FL 
          SBK    LE=LNT-1          POINT TO FIRST WORD ON ENTRY 
          UJN    NTAX              RETURN 
 NOS      IF     -DEF,NOS 
 RCH      SPACE  4,8
**        RCH - RESERVE SYSTEM INTERLOCK. 
* 
*         ENTRY  (A) = ORDINAL OF INTERLOCK TO BE RESERVED. 
* 
*         EXIT   (A) = ER14, IF ANOTHER INTERLOCK WAS ALREADY 
*                            RESERVED,
*                      0, IF REQUESTED INTERLOCK HAS BEEN 
*                         SUCCESSFULLY RESERVED.
* 
*         CALLS  R.RCH. 
  
  
 RCH      ENM    X
          STM    RCHA              SAVE INTERLOCK REQUESTED 
          LDM    DCHA 
          NJN    RCH1              IF INTERLOCK ALREADY RESERVED
          LDM    RCHA              GET INTERLOCK
          STM    DCHA              FLAG INTERLOCK RESERVED
          RJM    R.RCH             RESERVE INTERLOCK
          LDN    0
          UJN    RCHX              RETURN 
  
 RCH1     LCN    ER14 
          UJN    RCHX              RETURN 
  
 RCHA     BSS    1                 TEMPORARY STORAGE
 RWE      SPACE  4,8
**        RWE - DETERMINE JOB ORIGIN. 
* 
*         EXIT   (A) = 0, IF JOB AT THIS CP IS INTERCOM ORIGIN. 
  
  
 RWE      ENM    X
          CPAD   W.CPSWP
          CRD    S0 
          LDD    S0+C.CPORG 
          LPN    77B
          LMN    40B               INTERCOM ORIGIN
          UJN    RWEX              RETURN ZERO IFF INTERCOM ORIGIN
 SCP      SPACE  4,8
**        SCP - FIND CP NUMBER OF SUBSYSTEM (SCP).
* 
*         ENTRY  (A) = SCP SUBSYSTEM ORDINAL
* 
*         EXIT   (A) = ER06, IF T.SSCT DOES NOT EXIST,
*                      ER07, IF ORDINAL NOT IN T.SSCT,
*                      ER08, IF SCP NOT CURRENTLY ACTIVE, 
*                      CP NUMBER OF SCP, OTHERWISE. 
  
  
 SCP      ENM    X
          STD    S7                SAVE SUBSYSTEM NUMBER
          LDK    P.SSCT 
          CRD    S0 
          LDD    S0+C.SSCT
          SHN    3                 FWA OF SUBSYSTEM CONTROL TABLE 
          ZJN    SCP1              IF TABLE DOES NOT EXIST
          STD    S5+1 
          SHN    -12
          STD    S5 
          SHN    12 
          LMD    S5+1 
          CRD    S0                FIRST WORD OF T.SSCT 
          LDD    S0+4 
          SBD    S7                SUBSYSTEM ORDINAL
          MJN    SCP2              IF ORDINAL NOT IN T.SSCT 
          LDD    S5 
          SHN    12 
          LMD    S5+1 
          ADD    S7                ORDINAL
          CRD    S0 
          LDD    S0+3 
          SHN    17-17+12 
          PJN    SCP3              IF SCP NOT CURRENTLY ACTIVE
          LDD    S0+4 
          UJN    SCPX              RETURN WITH CONTROL POINT NO OF SCP
  
 SCP1     LCN    ER06 
          UJN    SCP4 
  
 SCP2     LCN    ER07 
          UJN    SCP4 
 SCP3     LCN    ER08 
 SCP4     LJM    SCPX 
 NOS      ENDIF 
 VSC      SPACE  4,8
**        VSC - VERIFY CALLED FROM SCP. 
* 
*         EXIT   (A) = ER05, IF NOT CALLED FROM RHF SCP,
*                      0, OTHERWISE.
  
  
 VSC      ENM    X
 NOS      IF     DEF,NOS
          LDD    D.CPAD 
          ADK    W.JCI
          CRD    S0                READ JOB CONTROL WORD
          LDD    S0+C.SSID
          LMK    RFSI 
          ZJN    VSCX              IF CALLED BY RHF 
 NOS      ELSE
          LDK    SC.RHF            RHF SUBSYSTEM ORDINAL
          RJM    SCP               FIND CP NUMBER OF RHF
          MJN    VSC1              IF RHF NOT ACTIVE
          CPNA                     CONVERT TO CONTROL POINT AREA ADDRESS
          LMD    D.CPAD            CONTROL POINT AREA OF REQUESTOR
          NJN    VSC1              IF NOT CALLED BY RHF SYSTEM CP 
          LDN    0
          UJN    VSCX              RETURN 
  
 NOS      ENDIF 
 VSC1     LCN    ER05 
          UJN    VSCX              RETURN 
*CALL COMTFL
 F00      TITLE  FC=00 - UPDATE LOCAL NAD TABLE FOR RHF.
  
***       FC=00 - UPDATE LOCAL NAD TABLE FOR RHF. 
* 
**T       REQUEST  12/COUNT,18/0,18/FWA OF LNT,11/0,1/0 
* 
*                WHERE COUNT = NUMBER OF LOCAL NADS DEFINED.
* 
**T       REPLY    59/(UNCHANGED),1/1 
* 
*         THE LOCAL NAD TABLE IS UPDATED TO REFLECT THE PROPER EST
*         ORDINAL AND CHANNEL CORRELATION AS WELL AS THE CURRENT
*         EST STATUS. 
* 
*         CALL VSC TO VERIFY CALL IS FROM SCP.
*         IF NOT CALLED BY SCP THEN 
*           RETURN ER05.
*         CALL ESI TO INITIALIZE EST PARAMETERS.
*         IF NO LOCAL NAD TABLE ENTRIES THEN
*           RETURN ER10.
*         REPEAT
*           CALL ESR TO RESET EST ORDINAL FOR SEARCH. 
*           IF LNT ADDRESS OUT OF RANGE THEN
*             RETURN ER11.
*           READ NEXT LNT ENTRY.
*           CALL CNE TO DETERMINE STATUS OF LNT ENTRY.
*           IF LNT IS IDLE THEN 
*             BEGIN 
*               CALL CNE TO SEARCH FOR NAD EST ENTRY. 
*               IF EST ENTRY NOT FOUND OR IN ERROR THEN 
*                 CALL NER TO ISSUE LNT ERROR MESSAGE 
*               ELSE
*                 CALL MEN TO UPDATE EST STATUS IN LNT
*               WRITE UPDATED LNT ENTRY 
*             END 
*           DECREMENT LNT ORDINAL 
*         UNTIL LNT ORDINAL < 0 
*         RETURN 0. 
  
  
 F00      ENM    X
          RJM    VSC               VERIFY CALLED BY SCP 
          NJN    F00X              IF NOT CALLED BY SCP 
          RJM    ESI               INITIALIZE EST PARAMETERS
          LDD    PB+2              FWA OF LOCAL NAD TABLE 
          LPN    77B
          SHN    12 
          LMD    PB+3 
          STD    FN+1 
          SHN    -12
          STD    FN 
          LDD    PB+0              NUMBER OF TABLE ENTRIES
          NJN    F001              IF TABLE NOT EMPTY 
          LCN    ER10              NO LOCAL NADS
          UJN    F00X 
  
 F001     SBN    1
          STD    NO                LAST TABLE ORDINAL 
          STD    LN                SAVE LAST LNT ORDINAL
  
 F002     RJM    ESR               RESET EST ORDINAL
          RJM    NTA               GET FWA OF LNT ENTRY 
          NJN    F004              IF ENTRY WITHIN FL 
  
 F003     LCN    ER11              NAD TABLE ADDRESS ERROR
          UJN    F00X 
  
 F004     ADK    W=LN1
          CRD    NT                READ FIRST WORD OF TABLE ENTRY 
          ADK    W=LN2-W=LN1       READ SECOND WORD OF LNT
          CRD    S0 
          RJM    CNE               CHECK LNT ENTRY
          ZJN    F007              IF LNT ENTRY NOT IDLE
          RJM    SEN               SEARCH FOR EST ENTRY 
          NJN    F005              IF ENTRY NOT FOUND OR IN ERROR 
          RJM    MEN               MODIFY LNT ENTRY 
          UJN    F006 
  
 F005     RJM    NER               PROCESS LNT ENTRY ERROR
  
 F006     RJM    NTA               GET FWA OF LNT ENTRY 
          ZJN    F003 
          ADK    W=LN1
          CWD    NT                REWRITE LNT ENTRY
  
 F007     SOD    NO                DECREMENT LNT ORDINAL
          PJN    F002              IF MORE TO PROCESS 
          LDN    0                 NORMAL RETURN
          LJM    F00X 
 F00      TITLE  FC=00 - SUBROUTINES. 
 CNE      SPACE  4,8
**        CNE - CHECK NAD TABLE ENTRY.
* 
*         CNE DETERMINES WHETHER AN LNT ENTRY IS CURRENTLY IDLE 
*         AND THUS A CANDIDATE FOR UPDATING EST STATUS. 
* 
*         ENTRY  (NT) - (NT+4) = FIRST WORD OF LNT ENTRY
*                (S0) - (S0+4) = SECOND WORD OF LNT ENTRY 
* 
*         EXIT   (A) .NE. 0,       IFF LNT IS IDLE, THAT IS 
*                IF  (S=LNOFF IS SET) 
*                AND (QUEUE COUNT = 0)
*                AND (CONNECT COUNT = 0)
*                AND (ASSIGNED NDR COUNT = 0) 
  
  
 CNE      ENM    X
          LDD    NT+C=LNFLGS
          SHN    17D-S=LNOFF
          MJN    CNE2              IF NAD IS OFF
  
 CNE1     LDN    0                 LNT IS NOT IDLE
          UJN    CNEX 
  
 CNE2     LDD    S0+C=LNANC 
          SHN    -S=LNANC          ASSIGNED NDR COUNT 
          ADD    S0+C=LNCOC        CONNECTION COUNT 
          ADD    S0+C=LNQUC        QUEUE COUNT
          NJN    CNE1              IF LNT ENTRY IS NOT IDLE 
          LDN    1
          UJN    CNEX 
 MEN      SPACE  4,8
**        MEN - UPDATE EST STATUS IN LNT ENTRY. 
* 
*         ENTRY  (NT) - (NT+4) = LNT ENTRY
*                (ES) = CURRENT EST ORDINAL 
* 
*         EXIT   S=LNOFF UPDATED IN (NT+C=LNFLGS) 
*                S=LNOFF = 1 IF EST OFF OR DOWN OR ASSIGNED TO CVL. 
  
  
 MEN      ENM    X
          LDD    NT+C=LNFLGS       LNT FLAGS BYTE 
          SCK    LNOFFM+LNCWSLM+LNCGEM  CLEAR CONFIG ERROR
          ADK    LNOFFM            ASSUME OFF 
          STD    NT+C=LNFLGS
          LDD    ES                EST ORDINAL OF NAD 
          SHN    S=LNEST
          STD    NT+C=LNEST        SET IN LNT ENTRY 
 NOS      IF     DEF,NOS
          LDD    ES                CURRENT EST ORDINAL
          RJM    .EST              CONVERT EST ORDINAL TO EST ADDRESS 
          ADK    EQDE 
          CRD    S0                READ EST ENTRY 
          LDD    S0+C.ESTAT 
          SHN    17-S.ESTDSO       DEVICE STATUS ON/OFF 
 NOS      ELSE
          LDD    FE                FWA OF EST 
          ADD    ES                CURRENT EST ORDINAL
          CRD    S0                READ EST ENTRY 
          LDD    S0+C.ESTMNE
          SHN    17-S.ESTON 
 NOS      ENDIF 
          MJN    MEN1              IF EST IS OFF
          LDD    NT+C=LNFLGS
          ADK    LNCWSLM           ASSUME C/W NOT LOADED
          STD    NT+C=LNFLGS
 NOS      IF     DEF,NOS
          LDD    S0+C.CWNL
 M.CWNL   BIT    S.CWNL 
          LPK    M.CWNL 
 NOS      ELSE
          LDD    S0+C.ESTAT 
 DNCVLM   BIT    (S.EDN)
          LPK    DNCVLM 
 NOS      ENDIF 
          NJN    MEN1              IF CONTROLWARE NOT LOADED
          LDD    NT+C=LNFLGS
          SCK    LNOFFM+LNCWSLM    CLEAR OFF AND NO C/W FLAGS 
          STD    NT+C=LNFLGS
 MEN1     LDN    0                 NORMAL RETURN
          UJN    MENX 
 NER      SPACE  4,8
**        NER - PROCESS LNT ERROR.
* 
*         NER IS CALLED TO ISSUE DIAGNOSTIC WHEN ANY INCONSISTENCY IS 
*         DETECTED IN LNT ENTRY.  S=LNCGE IS USED TO ENSURE DIAGNOSTIC
*         IS ONLY ISSUED ONCE.
* 
*         ENTRY  (A) = ERROR ORDINAL FOR *ERR*
*                (NT) - (NT+4) = LNT ENTRY
* 
*         EXIT   S=LNCGE SET IN (NT+C=LNFLGS) 
* 
*         CALLS  DFM, ERR.
  
  
 NER      ENM    X
          STM    NERA+1            SAVE ERROR CODE
          SHN    -12
          STM    NERA 
          LDD    NT+C=LNFLGS       LNT ENTRY FLAGS BYTE 
          LPK    LNCGEM            CONFIGURATION ERROR FLAG 
          NJN    NERX              IF ALREADY SET, DO NOT ISSUE MESSAGE 
          LDM    NERA              GET ERROR CODE 
          SHN    12 
          LMM    NERA+1 
          RJM    ERR               ISSUE ERROR MESSAGE
          LDD    NT+C=LNORD 
          SHN    -S=LNORD          LNT ORDINAL
          STD    S6                SAVE TEMPORARILY 
          SHN    -3                GET UPPER OCTAL DIGIT
          ADC    2R 0 
          STM    NERB+11D          STORE IN MESSAGE 
          LDD    S6 
          LPN    7                 GET LOWER DIGIT
          SHN    6
          ADK    2R0B 
          STM    NERB+12D          STORE IN MESSAGE 
          LDC    NERB              FWA OF MESSAGE 
          IF     DEF,NOS,1
          ADK    30000B 
          RJM    R.DFM             ISSUE DAYFILE MESSAGE
          LDD    NT+C=LNFLGS
          SCK    LNCGEM 
          ADK    LNCGEM            FLAG CONFIG ERROR
          STD    NT+C=LNFLGS
          LJM    NERX              RETURN 
  
 NERA     BSS    2
  
 NERB     DIS    ,*  ERROR IN LNT ORDINAL XXB.* 
 SEN      SPACE  4,8
**        SEN - SEARCH EST FOR NAD WITH MATCHING CHANNEL. 
* 
*         SEN IS CALLED FOR EACH LNT ENTRY TO SEARCH EST FOR NAD
*         WITH MATCHING CHANNEL NUMBER. 
* 
*         ENTRY  (NT) - (NT+4) = LNT ENTRY
* 
*         EXIT   (A) = ER12 IF NO NAD WITH MATCHING CH FOUND, 
*                    = ER13 IF MORE THAN ONE EST WITH NAD ON SAME CH
*                    = ER11 IF LNT OUT OF RANGE,
*                    = ER21 IF MORE THAN ONE LNT WITH SAME CH,
*                    = 0 IF NO ERROR DETECTED IN WHICH CASE 
*                      (ES) CONTAINS EST ORDINAL. 
  
  
 SEN      ENM    X
          LDD    NT+C=LNCHA        CHANNEL NUMBER 
          LPK    L=LNCHA
          STD    S7                SAVE CHANNEL NUMBER FOR EST SEARCH 
  
 SEN1     RJM    CEE               CHECK EST ENTRY
          ZJN    SEN2              IF NAD WITH MATCHING CHANNEL 
          SOD    ES                DECREMENT EST ORDINAL
          PJN    SEN1              IF MORE ENTRIES TO CHECK 
          LCN    ER12              CHANNEL NOT FOUND
          UJN    SENX 
  
 SEN2     LDD    ES 
          STM    SENA              SAVE EST ORDINAL 
          ZJN    SEN5              IF END OF EST
          SOD    ES                LOOK FOR DUPLICATE ENTRIES 
  
 SEN3     RJM    CEE               CHECK NEXT EST ENTRY 
          NJN    SEN4              IF EST ENTRY HAS CORRECT NAD 
          LCN    ER13              MORE THAN ONE NAD ON CHANNEL 
          UJN    SENX 
  
 SEN4     SOD    ES                DECREMENT ES 
          PJN    SEN3              IF MORE ENTRIES
          LDM    SENA 
          STD    ES                RESTORE ORDINAL OF GOOD ENTRY
  
 SEN5     LDD    NO                CURRENT LNT ORDINAL
          LMD    LN                LAST LNT ORDINAL 
          NJN    SEN6              IF MORE LNTS TO CHECK
          LJM    SEN11
  
 SEN6     LDD    NO 
          STM    SENA              SAVE CURRENT LNT ORDINAL 
          AOD    NO                INCREMENT ORDINAL
  
 SEN7     RJM    NTA               GET FWA OF LNT ENTRY 
          NJN    SEN8              IF ADDRESS WITHIN FL 
          LCN    ER11              ADDRESS ERROR
          LJM    SENX 
  
 SEN8     ADK    W=LN1
          CRD    S0                READ FIRST WORD OF ENTRY 
          LDD    S0+C=LNFLGS
          SHN    17D-S=LNCGE
          MJN    SEN9              IF CONFIGURATION ERROR DETECTED
          LDD    S0+C=LNCHA        CHANNEL OF THIS ENTRY
          LMD    NT+C=LNCHA        COMPARE WITH CURRENT ENTRY 
          LPK    L=LNCHA
          STD    S7                SAVE FOR EXIT TEST 
          ZJN    SEN10             IF DUPLICATE CHANNEL 
  
 SEN9     AOD    NO                INCREMENT LNT ORDINAL
          SBD    LN                LAST LNT ORDINAL 
          SBN    1
          MJN    SEN7              IF MORE ENTRIES TO CHECK 
          LDN    1
          STD    S7                SIGNAL NO DUPLICATES FOUND 
  
 SEN10    LDM    SENA 
          STD    NO                RESTORE CURRENT LNT ORDINAL
          LDD    S7                CHECK DUPLICATE FLAG 
          NJN    SEN11             IF NO DUPLICATES 
          LCN    ER21              MORE THAN ONE LNT WITH SAME CHANNEL
          UJN    SEN12
  
 SEN11    LDN    0                 NORMAL RETURN, (ES) = EST ORDINAL
  
 SEN12    LJM    SENX 
  
 SENA     BSS    1                 TEMPORARY STORAGE
  
 F01      TITLE  FC=01 - VALIDATE USER CONTROL POINT. 
  
***       FC=01 - VALIDATE USER CONTROL POINT.
* 
**T       REQUEST  36/0,12/JDT,11/0,1/0 
* 
**T       REPLY    24/0,12/FLAGS,12/JDT,11/0,1/1
* 
*         FLAGS RETURNED: 
* 
*         BIT  0 F01SL - LOADED FROM SYSTEM LIBRARY.
*              1 F01RS - SPECIAL RHF SID ($RH). 
*              2 F01SO - UCP CURRENTLY SWAPPED OUT. 
*              3 F01ER - INVALID OR UNOCCUPIED JDT OR CP. 
* 
*         INITIALIZE FLAGS TO F01ER (INVALID JDT).
*         CALL VSC TO VERIFY CALL IS FROM SCP.
*         IF NOT CALLED FROM SCP THEN 
*           RETURN ER05.
*         CALL JDT TO VALIDATE JDT ORDINAL. 
*         IF INVALID JDT THEN 
*           RETURN 0. 
*         IF CONTROL POINT NUMBER THEN
*           BEGIN 
*             IF JOB NAME = ZERO OR 'NEXT' THEN 
*               RETURN 0. 
*             IF JDT ADDRESS NOT EQUAL 7777B THEN 
*               RETURN 0. 
*             CLEAR F01ER.
*             CALL TSL TO CHECK FOR SYSTEM LIBRARY LOAD.
*             CALL SID TO CHECK FOR RHF SID.
*             RETURN 0. 
*           END 
*         ELSE  (* JDT ORDINAL GIVEN *) 
*           BEGIN 
*             IF JOB NAME = ZERO THEN 
*               RETURN 0. 
*             CLEAR F01ER.
*             SET F01S0  (* ASSUME SWAPPED OUT *).
*             CALL SID TO CHECK FOR RHF SID.
*             IF JOB NOT ACTIVE AT CONTROL POINT THEN 
*               RETURN 0. 
*             CLEAR F01SO.
*             CALL TSL TO CHECK FOR SYSTEM LIBRARY LOAD.
*             RETURN 0. 
*           END.
* 
*         NOTE   (THIS NOTE ONLY APPLIES TO NOS)
* 
*         THIS FUNCTION IS NOT IMPLEMENTED FOR NOS.  THEREFORE
*         IT IS AN ILLEGAL FUNCTION AND AN ERROR CODE OF 1 WILL 
*         BE RETURNED TO THE CALLER.
  
  
 F01      ENM    X
 NOS      IF     DEF,NOS
          LCN    ER01              ILLEGAL FUNCTION 
          UJN    F01X 
 NOS      ELSE
          LDK    F01ERM 
          STD    PB+2              ASSUME INVALID JDT ORDINAL 
          RJM    VSC               VERIFY CALLED FROM SCP 
          NJN    F01X              IF NOT CALLED FROM SCP 
          LDD    PB+3              JDT ORDINAL
          RJM    JDT               GET ADDRESS OF JDT 
          ZJN    F012              IF CONTROL POINT NUMBER
          MJN    F011              IF INVALID JDT ORDINAL 
          LJM    F014              VALID JDT ORDINAL
  
 F011     LDN    0
          UJN    F01X 
  
*         JDT WAS REALLY CONTROL POINT NUMBER.
  
 F012     LDD    PB+3              CONTROL POINT NUMBER 
          CPNA                     CONVERT TO FWA OF CPA
          ADK    W.CPJNAM 
          CRD    S0                READ JOB NAME
          LDD    S0+C.CPJNAM+3     LAST (SEVENTH) CHARACTER 
          SCN    77B
          ADD    S0+C.CPJNAM+2     FIFTH AND SIXTH CHARS
          ADD    S0+C.CPJNAM+1     THIRD AND FOURTH CHARS 
          ADD    S0+C.CPJNAM       FIRST AND SECOND CHARS 
          ZJN    F01X              IF JOB NAME = ZERO 
          LMK    2RNE+2RXT+0
          ZJN    F01X              IF JOB NAME = 'NEXT' 
          LDD    PB+3              CONTROL POINT NUMBER 
          CPNA                     FWA OF CPA 
          ADK    W.CPSCH
          CRD    S0                READ SCHEDULER WORD
          LDD    S0+C.CPJDA        JDT OFFSET 
          LMC    7777B             NON-EXISTANT JDT FLAG
          NJN    F013              IF JDT EXISTS
          LDD    PB+2 
          SCK    F01ERM            CLEAR INVALID JDT FLAG 
          STD    PB+2 
          LDD    PB+3              CONTROL POINT NUMBER 
          CPNA                     FWA OF CPA 
          RJM    TSL               CHECK FOR SYSTEM LIBRARY LOAD
          LDD    PB+3              CONTROL POINT NUMBER 
          CPNA                     FWA OF CPA 
          ADK    W.CPID 
          CRD    S0                READ LOGICAL ID WORD 
          LDD    S0+C.CPSID        LOAD SOURCE ID 
          LPN    77B
          SHN    12 
          LMD    S0+C.CPSID+1 
          RJM    SID               CHECK FOR RHF SID
  
 F013     LDN    0                 NORMAL RETURN
          LJM    F01X 
  
*         JDT ORDINAL WAS GIVEN.
  
 F014     STD    S6+1              STORE JDT ADDRESS
          SHN    -12
          STD    S6 
          SHN    12 
          LMD    S6+1              RESTORE JDT ADDRESS
          ADK    W.JDNAM
          CRD    S0                READ JOB NAME
          LDD    S0+0              FIRST BYTE OF JOB NAME 
          ZJN    F013              IF JDT IS EMPTY
          LDD    PB+2 
          SCK    F01ERM+F01SOM     CLEAR INVALID JDT FLAG 
          LMK    F01SOM            ASSUME JOB IS SWAPPED OUT
          STD    PB+2 
          LDD    S6                LOAD JDT ADDRESS 
          SHN    12 
          LMD    S6+1 
          ADK    W.JDINT
          CRD    S0                READ JDT SID 
          LDD    S0+C.JDSID+1      THIRD CHARACTER OF SID 
          SCN    77B
          SHN    6
          LMD    S0+C.JDSID        FIRST TWO CHARACTERS OF SID
          SHN    6
          RJM    SID               CHECK FOR RHF SID
          LDD    S6                LOAD JDT ADDRESS 
          SHN    12 
          LMD    S6+1 
          ADK    W.JDMGR
          CRD    S0                READ JOB STATUS WORD 
          LDD    S0+C.JDJST        JOB STATUS 
          SHN    -6 
          LMK    F.JDLMB+F.JDACT   ACTIVE AT CONTROL POINT STATUS 
          NJN    F015              IF NOT ACTIVE AT CP
          LDD    PB+2 
          SCK    F01SOM            CLEAR SWAPPED OUT STATUS 
          STD    PB+2 
          LDD    S6                LOAD JDT ADDRESS 
          SHN    12 
          LMD    S6+1 
          ADK    W.JDDSD
          CRD    S0                READ WORD WITH CP NUMBER 
          LDD    S0+C.JDCPN 
          SHN    -6                CONTROL POINT NUMBER 
          CPNA                     FWA OF CPA 
          RJM    TSL               CHECK FOR SYSTEM LIBRARY LOAD
  
 F015     LDN    0                 NORMAL RETURN
          LJM    F01X 
 F01      TITLE  FC=01 - SUBROUTINES. 
 SID      SPACE  4,8
**        SID - CHECK FOR RHF SID.
* 
*         ENTRY  (A) = SOURCE ID (FROM JDT OR CPA)
* 
*         EXIT   (A) = ZERO IFF RHH SID,
*                F01RS SET IN PB+2, IF RHH SID. 
  
  
 SID      ENM    X
          LMK    RHFSID            COMPARE TO SPECIAL RHF SID 
          NJN    SIDX              IF NOT SPECIAL SID 
          LDD    PB+2 
          SCK    F01RSM 
          LMK    F01RSM            SET SPECIAL SID FLAG 
          STD    PB+2 
          LDN    0                 NORMAL RETURN
          UJN    SIDX 
 TSL      SPACE  4,8
**        TSL - CHECK FOR SYSTEM LIBRARY LOAD.
* 
*         ENTRY  (A) = FWA OF CPA TO TEST.
* 
*         EXIT   (A) = ZERO IFF C.CPLP NOT SET, 
*                F01SL SET IN PB+2, IF C.CPLP NOT SET.
* 
*         CALLS  CSL. 
  
  
 TSL      ENM    X
          RJM    CSL               CHECK FOR SYSTEM LIBRARY LOAD
          MJN    TSLX              IF NOT LOADED FROM SYSTEM LIBRARY
          LDD    PB+2 
          SCK    F01SLM 
          LMK    F01SLM            SET SYSTEM LOAD FLAG 
          STD    PB+2 
          LDN    0                 NORMAL RETURN
          UJN    TSLX 
  
 NOS      ENDIF 
 F02      TITLE  FC=02 - RETURN HOST ID.
  
***       FC=02 - RETURN HOST ID. 
* 
**T       REQUEST  59/0,1/0 
* 
**T       REPLY    18/PID,41/0,1/1
* 
*         RHH HAS RETURNED THE THREE-CHARACTER PHYSICAL ID OF THE 
*         HOST MAINFRAME. 
* 
*         READ P.IDT. 
*         IF IDT DOES NOT EXIST THEN
*           RETURN ER20.
*         READ HOSD ID FROM IDT.
*         STORE ID IN PB. 
*         RETURN 0. 
  
  
 F02      ENM    X
 NOS      IF     DEF,NOS
          LDK    T.MID
          CRD    S0                READ MAINFRAME ID WORD 
          LDD    S0+C.MID          (A) = #0ID#
          SHN    6                 (A) = #ID0#
          STD    PB+1              (PB+1) = #D0#
          LMN    1RM               (A) = #IDM#
          SHN    6                 (A) = #DMI#
          STD    PB                (PB) = #MI#
 NOS      ELSE
          LDK    P.IDT             POINTER TO ID TABLE
          CRD    S0 
          LDD    S0+C.LIDT         LENGTH OF ID TABLE 
          NJN    F022              IF TABLE NOT EMPTY 
  
 F021     LCN    ER20              TABLE IS EMPTY 
          UJN    F02X 
  
 F022     LDD    S0+C.IDT          FWA OF ID TABLE / 10B
          ZJN    F021              IF TABLE DOES NOT EXIST
          SHN    3                 MULTIPLY BY 10B
          ADK    W.IDTHID          WORD CONTAINING HOST ID
          CRD    S0 
          LDD    S0+4              LOWER TWO CHARACTERS, *0ID*
          SHN    6                 *ID0*
          STD    PB+1              STORE *D0* IN PARAMETER BLOCK
          LMD    S0+3              MERGE UPPER CHARACTER, *IXH* 
          SHN    6                 *XHI*
          STD    PB+0              STORE *HI* IN PARAMETER BLOCK
 NOS      ENDIF 
          LDN    0                 NORMAL RETURN
          UJN    F02X 
 F03      TITLE  FC=03 - CLEAR RHF ACTIVE IN EST ENTRY. 
  
***       FC=03 - CLEAR RHF ACTIVE IN EST ENTRY.
* 
**T       REQUEST  36/0,12/EST ORD,11/0,1/0 
* 
**T       REPLY    59/(UNCHANGED),1/1 
* 
*         CALL VSC TO VERIFY CALL IS FROM SCP.
*         IF NOT CALLED FROM SCP THEN 
*           RETURN ER05.
*         CALL RCH TO RESERVE EST INTERLOCK.
*         CALL ESI TO INITIALIZE EST PARAMETERS.
*         IF EST ORDINAL OUT OF RANGE THEN
*           RETURN ER22.
*         READ EST ENTRY. 
*         IF NOT NAD DEVICE TYPE THEN 
*           RETURN ER23.
*         CLEAR S.ESTRHF (RHF ACTIVE) IN C.ESTUNT.
*         REWRITE EST ENTRY.
*         RELEASE EST INTERLOCK.
*         RETURN 0. 
  
  
 F03      ENM    X
          RJM    VSC               VERIFY CALLED FROM SCP 
          NJN    F03X              IF NOT CALLED FROM SCP 
          IF     -DEF,NOS,2 
          LDK    CH.EST 
          RJM    RCH               RESERVE EST INTERLOCK
          RJM    ESI               INITIALIZE EST PARAMETERS
          LDD    ES                LAST EST ORDINAL 
          SBD    PB+3              EST ORDINAL PARAMETER
          PJN    F031              IF VALID PARAMETER 
          LCN    ER22              PARAMETER OUT OF RANGE 
          UJN    F03X 
  
 F031     LDD    PB+3 
          STD    ES                SET EST ORDINAL
 NOS      IF     DEF,NOS
          RJM    .EST              CONVERT EST ORDINAL TO EST ADDRESS 
          ADK    EQDE 
 NOS      ELSE
          ADD    FE                FWA OF EST 
 NOS      ENDIF 
          CRD    S0                READ EST ENTRY 
          LDD    S0+C.ESTMNE       DEVICE MNEMONIC
          SCK    ESTONM            CLEAR DEVICE ON/OFF FLAG 
          LMK    NADMNE            NAD MNEMONIC 
          ZJN    F032              IF NAD EST 
          LCN    ER23              NOT A NAD EST
          UJN    F03X 
  
 NOS      IF     DEF,NOS
 F032     LDD    PB+3 
          STD    D.T1              SET EST ORDINAL
          LDK    C.ESTDA+4
          STD    D.T2              SET FUNCTION 
          LDK    -ESTRHFM 
          STD    D.T3              SET FUNCTION MASK
          LDK    0
          STD    D.T4              VALUE TO BE PLUGGED
          LDK    M.SEQ             CALL MONITOR TO CLEAR RHF ACTIVE 
          RJM    R.MTR
 NOS      ELSE
 F032     LDD    S0+C.ESTUNT
          SCK    ESTRHFM           CLEAR RHF ACTIVE FLAG
          STD    S0+C.ESTUNT
          LDD    FE                FWA OF EST 
          ADD    ES                EST ORDINAL
          CWD    S0                REWRITE EST ENTRY
          RJM    DCH               RELEASE EST INTERLOCK
 NOS      ENDIF 
          LDN    0                 NORMAL RETURN
          LJM    F03X 
 NOS      IF     -DEF,NOS 
 F04      TITLE  FC=04 - SET UP JOB DAYFILE FNT.
  
***       FC=04 - SET UP JOB DAYFILE FNT. 
* 
**T       REQUEST  59/0,1/0 
* 
**T       REPLY    59/0,1/1 
* 
*         RHH HAS CREATED A LOCAL COPY OF THE JOB DAYFILE WITH LFN
*         ZZZZZDF SO THAT IT MAY BE READ LATER BY THE JOB.
* 
*         CALL RWE TO DETERMINE JOB ORIGIN. 
*         IF INTERCOM ORIGIN THEN 
*           RETURN ER17  (* SINCE DAYFILE RBT CHAINS ARE NOT PRESERVED
*                           FOR INTERCOM JOBS OVER SWAPS *) 
*         REPEAT
*           CALL FJD TO FLUSH JOB DAYFILE 
*           CALL PCP TO INITIALIZE MODEL FNTS FOR SEARCH
*           CALL FNI TO INITIALIZE FNT PARAMETERS 
*           CALL RCH TO RESERVE FNT INTERLOCK 
*           FOR EACH FNT ENTRY DO 
*             CALL DOF TO READ AND CHECK FNT ENTRY. 
*           IF FNT FOR CP DAYFILE NOT FOUND THEN
*             RETURN ER15.
*           IF ZZZZZDF FOUND THEN 
*             RETURN ER16.
*           IF FNT NOT FULL THEN
*             BEGIN 
*               CALL SDF TO SET UP ZZZZZDF FNT
*               IF RBT CHAIN EXISTS FOR CP DAYFILE THEN 
*                 BEGIN 
*                   CALL DCH TO RELEASE FNT INTERLOCK 
*                   RETURN 0
*                 END 
*             END 
*           (* EITHER FNT IS FULL OR RBT DID NOT EXISTS. *) 
*           CALL DCH TO RELEASE INTERLOCK 
*         UNTIL CP ERROR FLAG SET 
*         RETURN ER18.
  
  
 F04      ENM    X
          RJM    RWE               CHECK JOB ORIGIN 
          NJN    F041              IF NOT AN INTERCOM JOB 
          LCN    ER17              INVALID CALLER 
          UJN    F04X 
  
 F041     RJM    FJD               FLUSH JOB DAYFILE
          RJM    PCP               PLUG CONTROL POINT NUMBER INTO FNTS
          RJM    FNI               INITIALIZE FNT PARAMETERS
          LDK    CH.FNT 
          RJM    RCH               RESERVE FNT INTERLOCK
          MJN    F04X              IF ERROR ENCOUNTERED 
  
 F042     RJM    DOF               DO ONE FNT ENTRY 
          LDK    -LE.FNT           LENGTH OF FNT ENTRY
          RAD    ES                DECREMENT OFFSET 
          PJN    F042              IF MORE FNT ENTRIES TO EXAMINE 
          LDM    F04A              ADDRESS OF *DFILENN* FNT 
          NJN    F043              IF CP DAYFILE FOUND
          LCN    ER15              CP DAYFILE NOT FOUND 
          UJN    F045              RETURN 
  
 F043     LDM    F04B              *ZZZZZDF*
          ZJN    F044              IF UNIQUE FILE NAME
          LCN    ER16              FILE NAME ALREADY EXISTS 
          UJN    F045              RETURN 
  
 F044     LDM    F04C              EMPTY SLOT 
          ZJN    F046              IF FNT FULL
          RJM    SDF               SET UP DAYFILE FNT 
          MJN    F045              IF ERROR ENCOUNTERED 
          ZJN    F046              IF NO RBT CHAIN EXISTS 
          RJM    DCH               RELEASE INTERLOCK
          LDN    0                 NORMAL RETURN
 F045     LJM    F04X 
  
 F046     RJM    DCH               RELEASE INTERLOCK
          RJM    DEL               DELAY A WHILE
          ZJN    F047              IF ERROR FLAGS NOT SET 
          LCN    ER18              CONTROL POINT ERROR FLAG SET 
          UJN    F045              RETURN 
  
 F047     LJM    F041              START OVER 
 F04      TITLE  FC=04 - DATA STRUCTURES. 
*         MODEL FOR CONTROL POINT DAYFILE FNT.
  
 F04A     CON    0
          LOC    0
          DATA   7LDFILEXX
 C.FLNKAD CON    0
          LOC    *O 
  
  
*         MODEL FOR LOCAL DAYFILE COPY FNT. 
  
 F04B     CON    0
          LOC    0
          DATA   7LZZZZZDF
 C.FLNKAD CON    0
          LOC    *O 
  
  
*         MODEL FOR EMPTY FNT ENTRY.
  
 F04C     CON    0
          LOC    0
          DATA   0,0,0,0
 C.FLNKAD CON    0
          LOC    *O 
  
  
*         FNT WORD 3 (= FST WORD 2) OF LOCAL DAYFILE COPY.
  
 F04D     BSS    0
  
          LOC    0
          CON    0
          CON    0
          CON    0
 NRRDM    BIT    (8,S.FNRRBT) 
 C.FCS    CON    NRRDM
 C.FCST   CON    50B
          LOC    *O 
 F04      TITLE  FC=04 - SUBROUTINES. 
 CFN      SPACE  4,8
**        CFN - COMPARE FILE NAME.
* 
*         CFN IS CALLED TO COMPARE CURRENT FNT ENTRY AGAINST MODEL FNT. 
* 
*         ENTRY  (A) = FWA - 1 OF MODEL FNT 
*                (S0) - (S0+4) = FNT ENTRY
* 
*         EXIT   (A) = 0 IFF LFN AND CP NUMBERS MATCHED,
*                      IN WHICH CASE (FWA-1) CONTAINS CM ADDRESS
*                      OF FNT ENTRY.
  
  
 CFN      ENM    X
          STM    CFNA              STORE FWA - 1 OF FNT 
          ADN    4                 COMPARE FIRST FOUR BYTES OF FNT
          STD    S7                LAST BYTE OF FILE NAME 
          LDK    S0+3              LAST BYTE TO COMPARE 
          STD    S6 
 FLILOM   BIT    (S.FLINK,S.FLOCK)
          LDK    -FLILOM           MASK FOR LAST BYTE OF NAME 
          STM    CFNB+1 
  
 CFN1     LDI    S6                GET BYTE 
          LMI    S7                COMPARE
 CFNB     LPC    **                MASK 
          NJN    CFNX              IF NO MATCH
          LCN    0                 ALL ONES 
          STM    CFNB+1            MASK NOTHING 
          SOD    S6                DECREMENT ADDRESS
          SOD    S7 
          SBM    CFNA              FWA - 1 OF COMPARISON
          NJN    CFN1              IF MORE TO COMPARE 
          LDD    FE                FWA OF FNT 
          ADD    ES                FNT OFFSET 
          STI    S7                SAVE FNT ADDRESS 
          LDN    0                 NORMAL RETURN
          UJN    CFNX 
  
 CFNA     BSS    1                 TEMPORARY STORAGE
 DEL      SPACE  4,8
**        DEL - DELAY.
* 
*         EXIT   FIELD ACCESS RESERVED
*                (A) = CONTROL POINT ERROR FLAG BYTE
* 
*         CALLS  R.RAFL, R.TAFL 
  
  
 DEL      ENM    X
          RJM    R.TAFL            TERMINATE FIELD ACCESS 
          LDK    1000B             DELAY COUNT
  
 DEL1     SBN    1                 DECREMENT DELAY
          PJN    DEL1              IF MORE TO DELAY 
          RJM    R.RAFL            REQUEST FIELD ACCESS 
          LDD    D.T0+C.CPEF
          UJN    DELX 
 DOF      SPACE  4,8
**        DOF - PROCESS ONE FNT ENTRY.
* 
*         DOF IS CALLED TO COMPARE FNT ENTRY AGAINST THE VARIOUS
*         MODEL FNTS BEING SEARCHED FOR.
* 
*         ENTRY  (ES) = CURRENT FNT ORDINAL 
* 
*         EXIT   FWA OF MODEL FNTS ARE UPDATED BY *CFN* 
*                FOR ANY MATCHES
* 
*         CALLS  CFN
  
  
 DOF      ENM    X
          LDD    FE                FWA OF FNT 
          ADD    ES                OFFSET OF CURRENT ENTRY
          ADK    W.FNT1 
          CRD    S0                READ FIRST WORD OF CURRENT FNT 
          LDC    F04A              *DFILEXX*
          RJM    CFN               COMPARE FNT
          LDC    F04B              *ZZZZZDF*
          RJM    CFN               COMPARE FNT
          LDC    F04C              EMPTY ENTRY
          RJM    CFN               COMPARE FNT
          LDN    0                 NORMAL RETURN
          UJN    DOFX 
 FNI      SPACE  4,8
**        FNI - INITIALIZE FNT PARAMETERS.
* 
*         EXIT   (FE) = FWA OF FNT
*                (LE) = LWA+1 OF FNT
*                (ES) = ORDINAL OF LAST FNT ENTRY 
  
  
 FNI      ENM    X
          LDK    P.FNT             FNT POINTER WORD 
          CRD    S0 
          LDD    S0+C.FNT 
          STD    FE                FWA OF FNT 
          LDD    S0+C.FNTLWA
          STD    LE                LWA+1 OF FNT 
          SBD    FE                MINUS FWA
          SBK    LE.FNT 
          STD    ES                OFFSET OF LAST FNT ENTRY 
          LDN    0                 NORMAL RETURN
          UJN    FNIX 
 PCP      SPACE  4,8
**        PCP - PLUG CONTROL POINT NUMBER INTO FNTS.
* 
*         EXIT   MODEL FNT ENTRIES ARE SET UP FOR SEARCH
  
  
 PCP      ENM    X
          LDN    0
          STM    F04A              FLAG NO FNTS FOUND 
          STM    F04B 
          STM    F04C 
          LDD    D.CPAD            FWA OF CONTROL POINT AREA
          CPAN                     CONVERT TO CP NUMBER 
          STD    S0 
          SHN    -3                UPPER BIT OF CP NUMBER 
          ADK    2RE0              FORM DISPLAY CODED DIGIT 
          STM    F04A+3            *DFILENX*
          LDD    S0 
          LPN    7B                LOWER BITS OF CP NUMBER
          ADK    1R0               CONVERT TO DPC 
          SHN    6
          STM    F04A+4            *DFILENN * 
          LDM    F04B+4            *ZZZZZDF*
          SCK    L.CPNUM
          LMD    S0                ADD CONTROL POINT NUMBER 
          STM    F04B+4 
          LDN    0                 NORMAL RETURN
          UJN    PCPX 
 SDF      SPACE  4,8
**        SDF - SET UP DAYFILE FNT. 
* 
*         SDF SETS UP THE FNT ENTRY FOR LOCAL DAYFILE COPY BY 
*         COPYING FST WORD 1 FROM CONTROL POINT DAYFILE FNT 
*         (WHICH IS AT CP 0), THEN CALLING CPMTR FUNCTION 
*         EX.RBT TO CREATE FST ENTRY FOR BEGINNING-OF-INFORMATION 
*         (EFFECTIVELY REWINDING THE FILE). 
* 
*         ENTRY  (F04A) = FNT ADDRESS OF CP DAYFILE 
*                (F04C) = ADDRESS OF FREE FNT 
* 
*         EXIT   (A) = 0 IF NO RBT CHAIN EXISTS FOR DAYFILE YET 
*                    = ER19 IF DAYFILE FNT HAS A SUPPLEMENT 
*                    > 0 OTHERWISE IN WHICH CASE LOCAL COPY 
*                        FNT WRITTEN TO CM AT (F04A)
  
  
 SDF      ENM    X
          LDM    F04A              ADDRESS OF CP DAYFILE FNT
          ADK    W.FNT1            FIRST WORD OF FNT
          CRD    S0 
          LDD    S0+C.FLINK 
          SHN    17-S.FLINK 
          PJN    SDF1              IF NO SUPPLEMENT 
          LCN    ER19              SUPPLEMENT ALREADY EXISTS
          UJN    SDFX 
  
 SDF1     LDM    F04A              GET FNT ADDRESS
          ADK    W.FCST 
          CRD    S0                READ FILE CONTROL STATUS WORD
          LDD    S0+C.FCST
          SHN    17-0 
          MJN    SDF2              IF COMPLETE BIT SET
          LDN    0                 FLUSH IN PROGRESS, MUST DELAY
          UJK    SDFX 
  
 SDF2     LDM    F04A 
          ADK    W.FNT2            READ FST WORD
          CRD    S0                READ DAYFILE FST 
          LDM    S0+C.FFRBA        FIRST RBT WORD PAIR
          ZJN    SDFX              IF NO RBT CHAIN EXISTS YET 
          LDM    F04C              ADDRESS OF FREE FNT
          ADK    W.FNT1 
          CWM    F04B+1,ONE        WRITE FNT NAME 
 W.FNT2   EQU    W.FNT1+1 
          CWM    S0,ONE            WRITE FST WORD ONE FROM CP DAYFILE 
 W.FCST   EQU    W.FNT2+1 
          CWM    F04D,ONE          WRITE LAST WORD OF FNT 
          RJM    DCH               RELEASE FNT INTERLOCK
          LDK    P.ZERO 
          CRD    D.T0              ZERO PARAMETER BYTES 
          LDN    1
          STD    D.T0+2            PRU NUMBER 1 (REWIND FILE) 
          LDM    F04A              FNT ADDRESS
          ADK    W.FNT2 
          STD    D.T0+3            FST ADDRESS OF FILE
          LDK    EX.RBT 
          STD    D.T0+4 
          LDK    M.ICE             INITIATE CENTRAL EXECUTIVE 
          RJM    R.MTR
          LDD    D.PPMES1 
          CRD    S0                READ W.PPMES1
          LDM    F04C              FNT ADDRESS
          ADK    W.FNT2 
          CWD    S0                WRITE NEW FST1 
          ADK    W.FCST-W.FNT2
          CRD    S0 
          LDD    S0+C.FCST
          SCK    1
          LMN    1                 SET COMPLETE BIT 
          STD    S0+C.FCST
          LDM    F04C 
          ADK    W.FNT3 
          CWD    S0 
          LJM    SDFX              RETURN 
  
 F05      TITLE  FC=05 - FLUSH JOB DAYFILE. 
  
***       FC=05 - FLUSH JOB DAYFILE.
* 
**T       REQUEST  59/0,1/0 
* 
**T       REPLY    59/0,1/1 
* 
*         RHH HAS FLUSHED THE JOB DAYFILE SO THAT THE LOCAL COPY
*         OF THE DAYFILE (ZZZZZDF) WILL BE UP-TO-DATE.
* 
*         CALL FJD TO FLUSH JOB DAYFILE.
*         CALL PCP TO PRESET CONTROL POINT NUMBER IN MATCH WORD.
*         CALL FNI TO INITIALIZE FNT SEARCH PARAMETERS. 
*         ASLONGAS MATCHING FNT NOT FOUND 
*           AND NOT END OF FNT
*         DO
*           CALL DOF TO READ AND COMPARE FNT. 
*         IF NO MATCH 
*         THEN
*           ASLONGAS FST NOT COMPLETE 
*             AND NO ERRORS 
*           DO
*             DELAY A WHILE.
*         ELSE
*           RETURN ERROR NO MATCHING FNT FOUND. 
*         RETURN 0. 
  
  
 F05      ENM    X
          RJM    FJD               FLUSH JOB DAYFILE
          RJM    PCP               PLUG CP NUMBER IN LFN
          RJM    FNI               PRESET FNT SEARCH PARAMETERS 
 F051     RJM    DOF               CHECH ONE FNT ENTRY
          LDM    F04A 
          NJN    F052              IF DAYFILE FNT FOUNT 
          LDK    -LE.FNT
          RAD    ES 
          PJN    F051              IF MORE FNT#S TO SCAN
          LCN    ER15              NO DAYFILE FNT FOUND 
          UJK    F05X 
  
 F052     LDM    F04A 
          ADK    W.FCST 
          CRD    S0                READ FNT COMPLETION STATUS WORD
          LDD    S0+C.FCST
          SHN    17-0 
          MJN    F053              IF FNT COMPLETE
          RJM    DEL               DELAY A WHILE
          ZJN    F052              IF NO ERRORS 
          LCN    ER18              CP ERROR FLAGS SET 
          UJK    F05X 
  
 F053     LDN    0
          UJK    F05X 
  
 F06      TITLE  FC=06 - INCREMENT TAPE COUNT.
  
***       FC=06 - INCREMENT TAPE COUNT. 
* 
**T       REQUEST  1/A,1/B,1/C,1/D,1/E,54/0,1/0 
* 
*         A = INCREMENT MT COUNT
*         B = INCREMENT NT COUNT
*         C = INCREMENT HD COUNT
*         D = INCREMENT PE COUNT
*         E = INCREMENT GE COUNT
* 
**T       REPLY    1/A,1/B,1/C,1/D,1/E,7/0,12/ERROR,35/0,1/1
* 
*         A,B,C,D,E - UNCHANGED 
*         ERROR = 0 IF SUCCESSFUL COMPLETION
*               = 1 NO ACTION, EITHER NONE OR MORE THAN 
*                   ONE OF BITS WERE SET IN REQUEST.
* 
*         SET ERROR RETURN IN PB. 
*         CALL RWE TO DETERMINE JOB ORIGIN. 
*         IF INTERCOM ORIGIN THEN 
*           RETURN ER17.
*         INITIALIZE COUNTS.
*         FOR EACH PARAMETER BIT DO 
*           BEGIN 
*             GET NEXT PARAMETER BIT
*             IF COUNT FIELD FOR THIS BIT NOT ALREADY SET THEN
*               BEGIN 
*                 STORE PARAMETER BIT IN CPA COUNT FIELD
*                 STORE PARAMETER BIT IN T.TSG ADJUSTMENT FIELD 
*               END 
*             ACCUMULATE PARAMETER BIT COUNT
*           END.
*         IF (NO PARAMETER BIT SET) OR (MORE THAN ONE SET) THEN 
*           RETURN 0  (* WITH ERROR RETURN STILL SET IN PB *) 
*         CALL RCH TO RESERVE CPA INTERLOCK 
*         READ OLD TAPE COUNTS FROM CPA.
*         FOR EACH TAPE COUNT FIELD DO
*           BEGIN 
*             IF ANY UNITS CURRENTLY ASSIGNED THEN
*               RETURN 0 (* WITH ERROR RETURN STILL SET IN PB *)
*             COMPUTE TSG-ADJUSTMENT =
*                   PARAMETER-BIT - OLD-CPA-TAPE-COUNT. 
*                     (* 0 OR 1 *)  (* CPA UNFULFILLED DEMAND *)
*           END 
*         WRITE NEW TAPE COUNTS TO CPA. 
*         CALL DCH TO RELEASE CPA INTERLOCK.
*         CALL RCH TO RESERVE T.TSG INTERLOCK.
*         READ T.TSG UNFULFILLED DEMAND COUNTS. 
*         FOR EACH TAPE COUNT FIELD DO
*           ADJUST COUNT BY TSG-ADJUSTMENT. 
*         WRITE NEW T.TSG UNFULFILLED DEMAND COUNTS.
*         CALL DCH TO RELEASE T.TSG INTERLOCK.
*         CLEAR ERROR RETURN. 
*         RETURN 0. 
 F06      SPACE  4,8
****      TEST ASSUMPTIONS. 
  
 STGL     EQU    4-1               NUMBER OF TAPE COUNT FIELDS MINUS 1
 F06MAX   MAX    C.CPTMT,C.CPTNT,C.CPTHD,C.CPTPE,C.CPTGE
 STGL     EQU    F06MAX            LARGEST FIELD USED 
 C.STGMT  EQU    C.CPTMT           CPA FIELDS MUST PARALLEL T.TSG FIELDS
 C.STGNT  EQU    C.CPTNT
 C.STGHD  EQU    C.CPTHD
 C.STGPE  EQU    C.CPTPE
 C.STGGE  EQU    C.CPTGE
  
****
  
 F06      ENM    X
          LDN    1
          STD    PB+1              ASSUME ERROR STATUS
          RJM    RWE               CHECK JOB ORIGIN 
          NJN    F061              IF NOT INTERCOM REQUEST
          LCN    ER17              CANNOT BE CALLED FROM INTERCOM USER
          UJN    F06X 
  
 F061     LDK    P.ZERO 
          CRD    NT                CLEAR COUNTS 
          CRM    F06A,ONE          AND OTHER COUNTS 
          LDD    PB+0              PARAMETER BITS 
          STD    S1                SAVE 
          LDN    0
          STD    S0                INITIALIZE LOOP COUNT
          STD    S2                INITIALIZE BIT COUNT 
  
 F062     LDM    F06B,S0           LOAD OFFSET OF COUNT FOR THIS BIT
          STD    S3                SAVE 
          LDD    S1                GET PARAMETER BITS 
          SHN    12-11             ISOLATE NEXT BIT 
          STD    S1                SAVE SHIFTED BITS
          SHN    0-12              RIGHT-JUSTIFY
          STD    S4                SAVE COUNT 
          LDM    NT,S3             GET ACCUMULATED COUNT
          NJN    F063              IF ALREADY SET (NT AND IP.NDEN)
          LDD    S4                GET COUNT
          STM    NT,S3             STORE COUNT FIELD (0 OR 1) 
          STM    F06A,S3           STORE COUNT FOR CPA
          LDM    F06A,S3           GET CPA COUNT
          SHN    6                 FORM MAXIMUM COUNT 
          RAM    F06A,S3           CPA FIELD IS EITHER 0000 OR 0101 
  
 F063     LDD    S4                GET COUNT
          RAD    S2                ACCUMULATE BIT COUNT 
          AOD    S0                INCREMENT LOOP COUNT 
          SBN    5                 MAXIMUM NUMBER OF PARAMETER BITS 
          MJN    F062              IF MORE PARAMETERS TO PROCESS
  
*         WE HAVE PROCESSED ALL PARAMETER BITS.  ENSURE ONE AND ONLY
*         ONE BIT WAS SET.
  
          SOD    S2                ACCUMULATED BIT COUNT - 1
          ZJN    F065              IF EXACTLY ONE BIT SET 
  
 F063.5   LDN    0
  
 F064     LJM    F06X              RETURN 
  
 F065     LDK    CH.CPA 
          RJM    RCH               RESERVE CPA INTERLOCK
  
 F066     MJN    F064              IF ERROR DETECTED
          CPAD   W.CPSTG
          CRD    S0                READ TAPE COUNTS FROM CPA
          LDD    S0+STGL+1         TRANSFER NON-COUNT BYTE FROM CPA 
          STM    F06A+STGL+1       SAVE IN NEW TAPE COUNT WORD
          LDK    STGL 
          STD    S7                INITIALIZE LOOP COUNT
  
 F067     LDM    S0,S7             FETCH OLD TAPE COUNT FIELD 
          LPN    77B               ISOLATE UNUSED COUNT 
          STD    S6                SAVE UNUSED COUNT
          LDM    S0,S7
          SHN    -6                ISOLATE MAXIMUM UNITS COUNT
          LMD    S6                COMPARE WITH UNUSED COUNT
          NJN    F063.5            IF UNUSED .NE. MAX(TAPE UNIT ASSIGNED
          LDD    S6                GET UNUSED COUNT 
          LMC    777777B           COMPLEMENT 
          RAM    NT,S7             SUBTRACT FROM PARAMETER COUNT
          SOD    S7                DECREMENT LOOP COUNT 
          PJN    F067              IF MORE FIELDS TO PROCESS
          CPAD   W.CPSTG
          CWM    F06A,ONE          WRITE NEW TAPE COUNT TO CP AREA
          RJM    DCH               RELEASE CPA INTERLOCK
          LDK    CH.EST 
          RJM    RCH               RESERVE EST INTERLOCK FOR T.TSG
          PJN    F067A             NO ERROR 
          LJM    F066              ERROR
  
 F067A    LDK    P.STG
          CRD    S0                READ POINTER TO T.TSG
          LDD    S0+C.STG          FWA OF T.TSG 
          STD    S6                SAVE FWA 
          ADK    W.STGUFD 
          CRD    S0                READ UNFULFILLED DEMAND COUNTS 
          LDK    STGL 
          STD    S7                INITIALIZE LOOP COUNT
  
 F068     LDM    NT,S7             GET ADJUSTMENT FOR THIS FIELD
          SHN    0-11              ISOLATE SIGN BIT 
          STD    S5                SAVE SIGN BIT FOR INDEX
          LDM    F06C,S5           LOAD SIGN EXTENSION (00B OR 77B) 
          SHN    12D               MOVE TO HIGH-ORDER BITS
          LMM    NT,S7             MERGE LOW-ORDER BITS 
          RAM    S0,S7             ADJUST UNFULFILLED DEMAND COUNT
          PJN    F069              IF COUNT STILL POSITIVE
          LDN    0                 COUNT WENT NEGATIVE
          STM    S0,S7             SET TO ZERO
  
 F069     SOD    S7                DECREMENT LOOP COUNT 
          PJN    F068              IF MORE FIELDS TO ADJUST 
          LDD    S6                FWA OF T.TSG 
          ADK    W.STGUFD 
          CWD    S0                REWRITE UNFULFILLED DEMAND 
          RJM    DCH               RELEASE INTERLOCK
          LDN    0                 NORMAL RETURN
          STD    PB+1              CLEAR ERROR RETURN 
          LJM    F06X 
 F06      TITLE  FC=06 - DATA STRUCTURES. 
*         NEW CPA TAPE COUNTS.
  
 F06A     BSS    5
  
  
*         PARAMETER BIT TO TAPE COUNT FIELD MAPPING.
  
 F06B     BSS    0
  
 .A       IFEQ   IP.SCHDE,0 
  
          CON    C.CPTMT           A - MT 
          CON    C.CPTNT           B - NT 
          CON    C.CPTNT           C - HD 
          CON    C.CPTNT           D - PE 
          CON    C.CPTNT           E - GE 
  
 .A       ELSE
  
          CON    C.CPTMT           A - MT 
          IFEQ   IP.NDEN,1,2
          CON    C.CPTGE           B - NT (=GE) 
 .B       SKIP
          IFEQ   IP.NDEN,2,2
          CON    C.CPTHD           B - NT (=HD) 
 .B       SKIP
          IFEQ   IP.NDEN,3,2
          CON    C.CPTPE           B - NT (=PE) 
 .B       SKIP
          ERR    IP.NDEN HAS UNDEFINED VALUE
 .B       ENDIF 
  
          CON    C.CPTHD           C - HD 
          CON    C.CPTPE           D - PE 
          CON    C.CPTGE           E - GE 
  
 .A       ENDIF 
  
  
*         SIGN EXTENSION TABLE. 
  
 F06C     BSS    0
          CON    00B
          CON    77B
  
 FC7      TITLE  FC=07 - SET FORCE EXIT PROCESSING BIT. 
  
**        FC=07 - CLEAR/SET FORCE-EXIT-PROCESSING FLAG, CLEAR C.CPMSLM. 
* 
**T       REQUEST  1/A,58/0,1/0 
*                  A = 0, SET FORCE-EXIT-PROCESSING FLAG. 
*                  A = 1, CLEAR FORCE-EXIT-PROCESSING FLAG. 
* 
**T       REPLY    1/A,58/0,1/0 
*                  A = NEW VALUE OF FORCE-EXIT-PROCESSING FLAG. 
*                    = 0 OR 1, CLEAR OR SET.
* 
*         UPON COMPLETION, BIT S.CPFEP (FORCE EXIT PROCESSING) IN 
*         BYTE C.CPFP OF CPA WORD W.CPFP WILL BE CLEARED OR SET, AND
*         THE MASS STORAGE LIMIT IN CPA WORD W.CPMSLM WILL BE CLEARED.
* 
*         CALL RCH TO RESERVE CPA INTERLOCK.
*         RESET S.CPFEP (IN BYTE C.CPFP OF CPA WORD W.CPFP).
*         CLEAR MAXIMUM PRU LIMIT (C.CPMSLM). 
*         CALL DCH TO RELEASE CPA INTERLOCK.
*         RETURN 0. 
  
  
 F07      ENM    X
          LDC    4000B
          RAD    PB                TOGGLE REQUEST FLAG
          SHN    18-11
          LPN    1                 NEW VALUE OF S.CPFEP 
          SHN    S.CPFEP
          STM    F07A              RESET INSTRUCTION
          LDK    CH.CPA 
          RJM    RCH               RESERVE CPA INTERLOCK
          MJN    F07X              IF ERROR DETECTED
          CPAD   W.CPFP 
          CRD    S0                READ FLAGS WORD FROM CPA 
          LDD    S0+C.CPFP
 S.CPFEP  EQU    6
 CPFEPM   BIT    S.CPFEP
          SCK    CPFEPM 
          LMK    CPFEPM            SET S.CPFEP
*         LMK    0                 CLEAR S.CPFEP
 F07A     EQU    *-1
          STD    S0+C.CPFP
          CPAD   W.CPFP 
          CWD    S0                REWRITE FLAGS WORD 
          LDD    D.CPAD 
          ADK    W.CPMSLM 
          CRD    S0                READ PRU LIMITS WORD 
          LDD    S0+C.CPMSLM
          LPK    4000B             PRESERVE SWAP FLAG 
          STD    S0+C.CPMSLM       CLEAR MAXIMUM PRU LIMIT
          LDN    0
          STD    S0+C.CPMSLM+1
          LDD    D.CPAD 
          ADK    W.CPMSLM 
          CWD    S0                REWRITE PRU LIMITS WORD
          RJM    DCH               RELEASE INTERLOCK
          UJK    F07X 
  
 F10      TITLE  FC=10 - DYNAMIC DUMP.
  
***       FC=10 - DYNAMIC DUMP. 
* 
**T       REQUEST  60/0 
* 
**T       REPLY    59/0,1/1 
* 
*         UPON COMPLETION, RHH HAS CALLED 1DD TO DUMP THE RHF FIELD 
*         LENGTH AND TO CATALOG THE DYNAMIC DUMP. 
* 
*         IF INTERNAL CALL THEN 
*           (*WE ARE RETURNING FROM EVENT STACK WAITING FOR 1DD TO
*             COMPLETE DUMP.  EXIT AND SET COMPLETE BIT.*)
*           RETURN 0. 
*         SET UP PPMES4 WITH FL OF CONTROL POINT. 
*         CALL 1DD TO PERFORM DYNAMIC DUMP. 
*         ENTER EVENT STACK AND DROP. 
*         (* RHH WILL BE RECALLED TO SET COMPLETE BIT WHEN 1DD IS 
*            FINISHED. *) 
* 
*           W A R N I N G -- THE C1DD MACRO EXITS THROUGH M.EESD. 
  
  
 F10      ENM    X
          LDK    P.ZERO 
          CRD    S0                CLEAR PARAMETER AREA 
          LDD    RC                INTERNAL RECALL FLAG 
          ZJN    F101              IF NOT RECALLED
          LDD    D.CPAD 
          ADK    W.CPDFM+5
          CWD    S0                CLEAR POSSIBLE B-DISPLAY MESSAGE 
          LDN    0                 RETURN TO SET COMPLETE BIT 
          UJN    F10X 
  
 F101     LDD    D.CPAD 
          CPAN                     CONVERT TO CP NUMBER 
          STD    S0+0              STORE IN 1DD PARAMETER LIST
          LDD    D.FL 
          STD    S0+4              LWA+1 = CP FL
          LDD    D.PPMES1 
          ADK    W.PPMES4-W.PPMES1
          CWD    S0                STORE 1DD PARAMETER LIST 
          LDD    D.PPIRB+C.CPNUM   RHH INPUT REGISTER IMAGE 
          SCK    RCLF 
          LMK    RCLF              SET INTERNAL CALL FLAG 
          STD    D.PPIRB+C.CPNUM
          LDD    D.PPIR            ADDRESS OF PP INPUT REGISTER 
          CWD    D.PPIRB           REWRITE FOR 1DD TO USE 
          LDN    3
          STD    S0 
          LDD    D.CPAD 
          ADK    W.CPDFM+5
          CWM    F10A,S0           PLACE WAIT MESSAGE IN B-DISPLAY
          C1DD   CM=(PPM4,CP4),RECALL=YES 
          LCN    ER00              (SHOULD NEVER RETURN HERE) 
          LJM    F10X 
  
 F10A     DIS    ,*RHH - WAIT DYNAMIC DUMP.*
  
 F11      TITLE  FC=11 - DETERMINE JOB ORIGIN.
  
***       FC=11 - DETERMINE JOB ORIGIN. 
* 
**T       REQUEST  59/0,1/0 
* 
**T       REPLY    57/0,1/RHFSID,1/SYSORG,1/1 
* 
*         FLAGS RETURNED: 
* 
*         BIT  1 - SET IF SYSTEM-ORIGIN JOB 
*              2 - SET IF JOB SOURCE ID EQUALS SPECIAL RHF SID ($RH)
* 
*         READ JDT ADDRESS FROM CONTROL POINT AREA
*         IF JDT ADDRESS = 7777B THEN 
*           SET BIT 1 IN PARAMETER BLOCK
*         READ LOGICAL ID WORD FROM CPA 
*         IF SID = $RH THEN 
*           SET BIT 2 IN PARAMETER BLOCK
*         RETURN 0. 
  
  
 F11      ENM    X
          LDK    P.ZERO 
          CRD    PB                ZERO REPLY WORD
          CPAD   W.CPSCH
          CRD    S0                READ SCHEDULER WORD
          LDD    S0+C.CPJDA        JDT OFFSET 
          LMC    7777B             NON-EXISTANT JDT FLAG
          NJN    F111              IF JDT EXISTS
          LDN    1S1               SYSTEM-ORIGIN JOB
          RAD    PB+4              SET BIT 1
  
 F111     CPAD   W.CPID 
          CRD    S0                READ LOGICAL ID WORD 
          LDD    S0+C.CPSID        UPPER BYTE OF SOURCE ID
          LPN    77B
          SHN    12 
          LMD    S0+C.CPSID+1      LOWER TWO CHARS OF SOURCE ID 
          LMK    RHFSID            COMPARE TO SPECIAL RHF SID 
          NJN    F112              IF NOT RHF SID 
          LDN    1S2
          RAD    PB+4              SET BIT 2
  
 F112     BSS    0
          LDN    0                 NORMAL RETURN
          UJN    F11X 
F12       TITLE  FC=12 - RETURN JOBNAME.
***       FC=12 - RETURN JOBNAME. 
* 
**T       REQUEST  59/0,1/0 
* 
**T       REPLY    42/JOBNAME,17/0,1/1
* 
*         READ JOBNAME FROM CONTROL POINT AREA
*           INTO THE REPLY BUFFER.
*         ZERO OUT UNUSED FIELDS. 
*         RETURN 0. 
  
  
 F12      ENM    X
          LDD    D.CPAD 
          ADK    W.CPJNAM 
          CRD    PB                READ JOBNAME 
          LDD    PB+3 
          LPK    7700B
          STD    PB+3              ZERO UNUSED FIELDS 
          LDN    0
          STD    PB+4 
          UJN    F12X              ZERO IS IN A-REGISTER
  
  
 NOS      ENDIF 
*CALL COMBRK
 INI      TITLE  INITIALIZATION ROUTINES. 
**        INI - INITIALIZE RHH. 
  
 INI      ENM    X
          IF     -DEF,NOS,1 
          PPENTRY D.PPIRB,D.T0
          LDN    1
          STD    ONE               CONSTANT ONE 
          LDN    2
          STD    TWO               CONSTANT TWO 
          LDD    D.PPIRB+3
          LPN    77B
          STD    BA                ADDRESS OF PARAMETER BLOCK 
          LDD    D.PPIRB+4
          STD    BA+1 
          LDD    D.PPIRB+2
          STD    FC                FUNCTION CODE
          IF     -DEF,NOS,3 
          LDD    D.PPIRB+C.CPNUM
          LPK    RCLF              MASK INTERNAL CALL BIT 
          STD    RC                (RC) <> 0 IF INTERNAL CALL 
          LDD    D.CPAD 
          NJN    INI1              IF LEGAL CONTROL POINT 
          LCN    ER04              CALLED FROM CP 0 
          UJN    INI6 
  
 INI1     RJM    CSL               CHECK FOR SYSTEM LIBRARY PROGRAM 
          PJN    INI2              IF CALLED FROM SYSTEM LIBRARY
          LCN    ER03              PROGRAM NOT CALLED FROM SYSTEM LIB 
          UJN    INI6 
  
 INI2     LDD    FC 
          SBK    TFCPL             LAST VALID FUNCTION + 1
          MJN    INI3              IF VALID FUNCTION CODE 
          LCN    ER01              INVALID FUNCTION 
          UJN    INI6 
  
 INI3     LDD    BA                LOAD PARAMETER BLOCK ADDRESS 
          SHN    12 
          LMD    BA+1 
          ZJN    INI4              IF INVALID ADDRESS 
          ADDRA  OK=INI5
 INI4     LCN    ER02              INVALID ADDRESS
          UJN    INI6 
  
 INI5     CRD    PB                READ PARAMETER BLOCK 
          LDN    0                 NORMAL RETURN
 INI6     LJM    INIX 
  
 NOS      IF     DEF,NOS
          OVERFLOW
 NOS      ENDIF 
  
          ERRMI  7773B-LWARHH      SPACE REMAINING IN RHH 
  
 LWARHH   END 
